1 module Rakka.Wiki.Formatter
7 import Control.Arrow.ArrowList
8 import Control.Arrow.ArrowTree
15 import Text.XML.HXT.Arrow.XmlArrow
16 import Text.XML.HXT.DOM.TypeDefs
19 formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
21 = proc (baseURI, blocks)
22 -> do block <- arrL id -< blocks
23 tree <- formatBlock -< (baseURI, block)
27 formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
29 = proc (baseURI, block)
32 -> formatHeading -< (level, text)
38 -> formatListElement -< (baseURI, list)
41 -> formatDefinitionList -< (baseURI, list)
44 -> formatPreformatted -< (baseURI, inlines)
47 -> formatParagraph -< (baseURI, inlines)
50 -> formatElem "div" -< (baseURI, attrs, contents)
55 formatElem :: (ArrowXml a, ArrowChoice a) =>
57 -> a (URI, [Attribute], [BlockElement]) XmlTree
59 = proc (baseURI, attrs, contents)
65 += ( (arr fst &&& arrL (snd . snd))
69 ) -< (baseURI, (attrs, contents))
72 formatHeading :: ArrowXml a => a (Int, String) XmlTree
75 -> mkelem ("h" ++ show level)
80 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
82 = proc (baseURI, list)
83 -> let tag = case listType list of
88 += ( (constA baseURI &&& constL (listItems list))
94 formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
96 = proc (baseURI, item)
98 += ( (arr fst &&& arrL snd)
103 formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
107 Left nestedList -> formatListElement -< (baseURI, nestedList)
108 Right inline -> formatInline -< (baseURI, inline )
111 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
113 = proc (baseURI, list)
115 += ( (arr fst &&& arrL snd)
121 formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
123 = proc (baseURI, def)
125 += ( (arr fst &&& arrL (defTerm . snd))
131 += ( (arr fst &&& arrL (defDesc . snd))
138 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
141 += ( (arr fst &&& arrL snd)
147 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
150 += ( (arr fst &&& arrL snd)
156 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
164 -> formatElem "i" -< (baseURI, [], contents)
167 -> formatElem "b" -< (baseURI, [], contents)
169 link@(PageLink _ _ _)
170 -> formatPageLink -< (baseURI, link)
172 link@(ExternalLink _ _)
173 -> formatExternalLink -< link
176 -> formatElem "br" -< (baseURI, attrs, [])
179 -> formatElem "span" -< (baseURI, attrs, contents)
182 -> formatElem "img" -< (baseURI, attrs, [])
184 Anchor attrs contents
185 -> formatElem "a" -< (baseURI, attrs, contents)
190 formatElem :: (ArrowXml a, ArrowChoice a) =>
192 -> a (URI, [Attribute], [InlineElement]) XmlTree
194 = proc (baseURI, attrs, contents)
196 += ( arrL (fst . snd)
200 += ( (arr fst &&& arrL (snd . snd))
204 ) -< (baseURI, (attrs, contents))
207 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
208 attrFromPair = proc (name, value)
209 -> attr name (txt value) -<< ()
212 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
214 = proc (baseURI, PageLink page fragment text)
215 -> let uri = case (page, fragment) of
216 (Just x, Just y) -> mkPageFragmentURI baseURI (fix x) y
217 (Just x, Nothing) -> mkPageURI baseURI (fix x)
218 (Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
219 fix = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
220 href = uriToString id uri ""
221 dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
222 label = fromMaybe dLabel text
225 += attr "href" (arr fst >>> mkText)
226 += (arr snd >>> mkText)
230 formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
232 = proc (ExternalLink uri text)
233 -> let href = uriToString id uri ""
234 label = fromMaybe href text
237 += attr "href" (arr fst >>> mkText)
238 += (arr snd >>> mkText)
242 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
243 attachXHtmlNs = processBottomUp (changeQName attach')
245 attach' :: QName -> QName
248 , namespaceUri = "http://www.w3.org/1999/xhtml"