module Rakka.Wiki.Formatter
- ( formatWikiElements
+ ( formatWikiBlocks
)
where
import Control.Arrow
import Control.Arrow.ArrowList
+import Data.Char
import Data.List
import Data.Maybe
import Network.URI
import Text.XML.HXT.DOM.TypeDefs
--- 複數の Inline を一つに纏める
-packParagraph :: [WikiElement] -> [Either BlockElement [InlineElement]]
-packParagraph elems = map pack grp
- where
- grp :: [[WikiElement]]
- grp = groupBy criteria elems
-
- criteria :: WikiElement -> WikiElement -> Bool
- criteria (Inline _) (Inline _) = True
- criteria _ _ = False
-
- pack :: [WikiElement] -> Either BlockElement [InlineElement]
- pack (Block b : []) = Left b
- pack xs = Right [ case x of
- Inline i -> i | x <- xs ]
-
+formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
+formatWikiBlocks
+ = proc (baseURI, blocks)
+ -> do block <- arrL id -< blocks
+ formatBlock -< (baseURI, block)
-formatWikiElements :: (ArrowXml a, ArrowChoice a) => a (URI, [WikiElement]) XmlTree
-formatWikiElements
- = proc (baseURI, elems)
- -> do chunk <- arrL id -< packParagraph elems
- case chunk of
- Left x -> formatBlock -< x
- Right xs -> formatParagraph -< (baseURI, xs)
-
-formatBlock :: (ArrowXml a, ArrowChoice a) => a BlockElement XmlTree
+formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
formatBlock
- = proc b
- -> case b of
+ = proc (baseURI, block)
+ -> case block of
Heading level text
-> formatHeading -< (level, text)
- EmptyLine
- -> none -< ()
+
+ HorizontalLine
+ -> eelem "hr" -< ()
+
+ List list
+ -> formatListElement -< (baseURI, list)
+
+ DefinitionList list
+ -> formatDefinitionList -< (baseURI, list)
+
+ Preformatted inlines
+ -> formatPreformatted -< (baseURI, inlines)
+
+ Paragraph inlines
+ -> formatParagraph -< (baseURI, inlines)
formatHeading :: ArrowXml a => a (Int, String) XmlTree
-> selem ("h" ++ show level) [txt text] -<< ()
+formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
+formatListElement
+ = proc (baseURI, list)
+ -> let tag = case listType list of
+ Bullet -> "ul"
+ Numbered -> "ol"
+ in
+ ( eelem tag
+ += ( (constA baseURI &&& constL (listItems list))
+ >>>
+ formatListItem
+ )
+ ) -<< ()
+ where
+ formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
+ formatListItem
+ = proc (baseURI, item)
+ -> eelem "li"
+ += ( (arr fst &&& arrL snd)
+ >>>
+ formatListItem'
+ ) -< (baseURI, item)
+
+ formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
+ formatListItem'
+ = proc (baseURI, x)
+ -> case x of
+ Left nestedList -> formatListElement -< (baseURI, nestedList)
+ Right inline -> formatInline -< (baseURI, inline )
+
+
+formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
+formatDefinitionList
+ = proc (baseURI, list)
+ -> ( eelem "dl"
+ += ( (arr fst &&& arrL snd)
+ >>>
+ formatDefinition
+ )
+ ) -< (baseURI, list)
+ where
+ formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
+ formatDefinition
+ = proc (baseURI, def)
+ -> ( eelem "dt"
+ += ( (arr fst &&& arrL (defTerm . snd))
+ >>>
+ formatInline
+ )
+ <+>
+ eelem "dd"
+ += ( (arr fst &&& arrL (defDesc . snd))
+ >>>
+ formatInline
+ )
+ ) -< (baseURI, def)
+
+
+formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
+formatPreformatted
+ = eelem "pre"
+ += ( (arr fst &&& arrL snd)
+ >>>
+ formatInline
+ )
+
+
formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
formatParagraph
= eelem "p"
Text text
-> mkText -< text
+ Italic inlines
+ -> ( eelem "i"
+ += ( (arr fst &&& arrL snd)
+ >>>
+ formatInline
+ )
+ ) -< (baseURI, inlines)
+
+ Bold inlines
+ -> ( eelem "b"
+ += ( (arr fst &&& arrL snd)
+ >>>
+ formatInline
+ )
+ ) -< (baseURI, inlines)
+
link@(PageLink _ _ _)
-> formatPageLink -< (baseURI, link)
formatPageLink
= proc (baseURI, PageLink page fragment text)
-> let uri = case (page, fragment) of
- (Just x, Just y) -> mkPageFragmentURI baseURI x y
- (Just x, Nothing) -> mkPageURI baseURI x
+ (Just x, Just y) -> mkPageFragmentURI baseURI (fix x) y
+ (Just x, Nothing) -> mkPageURI baseURI (fix x)
(Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
+ fix = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
href = uriToString id uri ""
dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
label = fromMaybe dLabel text