1 module Rakka.Wiki.Formatter
7 import Control.Arrow.ArrowList
14 import Text.XML.HXT.Arrow.XmlArrow
15 import Text.XML.HXT.DOM.TypeDefs
18 formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
20 = proc (baseURI, blocks)
21 -> do block <- arrL id -< blocks
22 formatBlock -< (baseURI, block)
25 formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
27 = proc (baseURI, block)
30 -> formatHeading -< (level, text)
36 -> formatListElement -< (baseURI, list)
39 -> formatDefinitionList -< (baseURI, list)
42 -> formatPreformatted -< (baseURI, inlines)
45 -> formatParagraph -< (baseURI, inlines)
53 += ( (arr fst &&& arrL (snd . snd))
57 ) -< (baseURI, (attrs, contents))
60 formatHeading :: ArrowXml a => a (Int, String) XmlTree
63 -> mkelem ("h" ++ show level)
68 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
70 = proc (baseURI, list)
71 -> let tag = case listType list of
76 += ( (constA baseURI &&& constL (listItems list))
82 formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
84 = proc (baseURI, item)
86 += ( (arr fst &&& arrL snd)
91 formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
95 Left nestedList -> formatListElement -< (baseURI, nestedList)
96 Right inline -> formatInline -< (baseURI, inline )
99 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
101 = proc (baseURI, list)
103 += ( (arr fst &&& arrL snd)
109 formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
111 = proc (baseURI, def)
113 += ( (arr fst &&& arrL (defTerm . snd))
119 += ( (arr fst &&& arrL (defDesc . snd))
126 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
129 += ( (arr fst &&& arrL snd)
135 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
138 += ( (arr fst &&& arrL snd)
144 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
153 += ( (arr fst &&& arrL snd)
157 ) -< (baseURI, inlines)
161 += ( (arr fst &&& arrL snd)
165 ) -< (baseURI, inlines)
167 link@(PageLink _ _ _)
168 -> formatPageLink -< (baseURI, link)
172 += (arrL id >>> attrFromPair)
177 += ( arrL (fst . snd)
181 += ( (arr fst &&& arrL (snd . snd))
185 ) -< (baseURI, (attrs, contents))
188 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
189 attrFromPair = proc (name, value)
190 -> attr name (txt value) -<< ()
193 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
195 = proc (baseURI, PageLink page fragment text)
196 -> let uri = case (page, fragment) of
197 (Just x, Just y) -> mkPageFragmentURI baseURI (fix x) y
198 (Just x, Nothing) -> mkPageURI baseURI (fix x)
199 (Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
200 fix = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
201 href = uriToString id uri ""
202 dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
203 label = fromMaybe dLabel text
206 += attr "href" (arr fst >>> mkText)
207 += (arr snd >>> mkText)