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 formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
29 = proc (baseURI, elem)
31 Block b -> formatBlock -< (baseURI, b)
32 Inline i -> formatInline -< (baseURI, i)
35 formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
37 = proc (baseURI, block)
40 -> formatHeading -< (level, text)
46 -> formatListElement -< (baseURI, list)
49 -> formatDefinitionList -< (baseURI, list)
52 -> formatPreformatted -< (baseURI, inlines)
55 -> formatParagraph -< (baseURI, inlines)
58 -> formatElem "div" -< (baseURI, attrs, contents)
63 formatElem :: (ArrowXml a, ArrowChoice a) =>
65 -> a (URI, [Attribute], [Element]) XmlTree
67 = proc (baseURI, attrs, contents)
73 += ( (arr fst &&& arrL (snd . snd))
77 ) -< (baseURI, (attrs, contents))
80 formatHeading :: ArrowXml a => a (Int, String) XmlTree
83 -> mkelem ("h" ++ show level)
88 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
90 = proc (baseURI, list)
91 -> let tag = case listType list of
96 += ( (constA baseURI &&& constL (listItems list))
102 formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
104 = proc (baseURI, item)
106 += ( (arr fst &&& arrL snd)
112 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
114 = proc (baseURI, list)
116 += ( (arr fst &&& arrL snd)
122 formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
124 = proc (baseURI, def)
126 += ( (arr fst &&& arrL (defTerm . snd))
132 += ( (arr fst &&& arrL (defDesc . snd))
139 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
142 += ( (arr fst &&& arrL snd)
148 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
151 += ( (arr fst &&& arrL snd)
157 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
165 -> formatElem "i" -< (baseURI, [], contents)
168 -> formatElem "b" -< (baseURI, [], contents)
170 link@(ObjectLink _ _)
171 -> formatObjectLink -< (baseURI, link)
173 link@(PageLink _ _ _)
174 -> formatPageLink -< (baseURI, link)
176 link@(ExternalLink _ _)
177 -> formatExternalLink -< link
180 -> formatElem "br" -< (baseURI, attrs, [])
183 -> formatElem "span" -< (baseURI, attrs, contents)
186 -> formatImage -< (baseURI, img)
188 Anchor attrs contents
189 -> formatElem "a" -< (baseURI, attrs, contents)
194 formatElem :: (ArrowXml a, ArrowChoice a) =>
196 -> a (URI, [Attribute], [InlineElement]) XmlTree
198 = proc (baseURI, attrs, contents)
200 += ( arrL (fst . snd)
204 += ( (arr fst &&& arrL (snd . snd))
208 ) -< (baseURI, (attrs, contents))
211 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
212 attrFromPair = proc (name, value)
213 -> attr name (txt value) -<< ()
216 formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
218 = proc (baseURI, ObjectLink page text)
219 -> let uri = mkObjectURI baseURI page
220 href = uriToString id uri ""
221 label = fromMaybe ("{" ++ page ++ "}") text
223 mkAnchor -< (href, label)
226 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
228 = proc (baseURI, PageLink page fragment text)
229 -> let uri = case (page, fragment) of
230 (Just x, Just y) -> mkPageFragmentURI baseURI x y
231 (Just x, Nothing) -> mkPageURI baseURI x
232 (Nothing, Just y) -> mkFragmentURI y
233 href = uriToString id uri ""
234 dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
235 label = fromMaybe dLabel text
237 mkAnchor -< (href, label)
240 formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
241 formatImage = proc (baseURI, Image name alt)
242 -> let uri = mkObjectURI baseURI name
243 href = uriToString id uri ""
248 Just x -> sattr "alt" x
254 formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
256 = proc (ExternalLink uri text)
257 -> let href = uriToString id uri ""
258 label = fromMaybe href text
260 mkAnchor -< (href, label)
263 mkAnchor :: (ArrowXml a) => a (String, String) XmlTree
265 += attr "href" (arr fst >>> mkText)
266 += (arr snd >>> mkText)
269 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
270 attachXHtmlNs = processBottomUp (changeQName attach')
272 attach' :: QName -> QName
275 , namespaceUri = "http://www.w3.org/1999/xhtml"