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)
48 -> formatElem "div" -< (baseURI, attrs, contents)
50 formatElem :: (ArrowXml a, ArrowChoice a) =>
52 -> a (URI, [Attribute], [BlockElement]) XmlTree
54 = proc (baseURI, attrs, contents)
60 += ( (arr fst &&& arrL (snd . snd))
64 ) -< (baseURI, (attrs, contents))
67 formatHeading :: ArrowXml a => a (Int, String) XmlTree
70 -> mkelem ("h" ++ show level)
75 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
77 = proc (baseURI, list)
78 -> let tag = case listType list of
83 += ( (constA baseURI &&& constL (listItems list))
89 formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
91 = proc (baseURI, item)
93 += ( (arr fst &&& arrL snd)
98 formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
102 Left nestedList -> formatListElement -< (baseURI, nestedList)
103 Right inline -> formatInline -< (baseURI, inline )
106 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
108 = proc (baseURI, list)
110 += ( (arr fst &&& arrL snd)
116 formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
118 = proc (baseURI, def)
120 += ( (arr fst &&& arrL (defTerm . snd))
126 += ( (arr fst &&& arrL (defDesc . snd))
133 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
136 += ( (arr fst &&& arrL snd)
142 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
145 += ( (arr fst &&& arrL snd)
151 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
159 -> formatElem "i" -< (baseURI, [], contents)
162 -> formatElem "b" -< (baseURI, [], contents)
164 link@(PageLink _ _ _)
165 -> formatPageLink -< (baseURI, link)
167 link@(ExternalLink _ _)
168 -> formatExternalLink -< link
171 -> formatElem "br" -< (baseURI, attrs, [])
174 -> formatElem "span" -< (baseURI, attrs, contents)
177 -> formatElem "img" -< (baseURI, attrs, [])
179 Anchor attrs contents
180 -> formatElem "a" -< (baseURI, attrs, contents)
182 formatElem :: (ArrowXml a, ArrowChoice a) =>
184 -> a (URI, [Attribute], [InlineElement]) XmlTree
186 = proc (baseURI, attrs, contents)
188 += ( arrL (fst . snd)
192 += ( (arr fst &&& arrL (snd . snd))
196 ) -< (baseURI, (attrs, contents))
199 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
200 attrFromPair = proc (name, value)
201 -> attr name (txt value) -<< ()
204 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
206 = proc (baseURI, PageLink page fragment text)
207 -> let uri = case (page, fragment) of
208 (Just x, Just y) -> mkPageFragmentURI baseURI (fix x) y
209 (Just x, Nothing) -> mkPageURI baseURI (fix x)
210 (Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
211 fix = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
212 href = uriToString id uri ""
213 dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
214 label = fromMaybe dLabel text
217 += attr "href" (arr fst >>> mkText)
218 += (arr snd >>> mkText)
222 formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
224 = proc (ExternalLink uri text)
225 -> let href = uriToString id uri ""
226 label = fromMaybe href text
229 += attr "href" (arr fst >>> mkText)
230 += (arr snd >>> mkText)