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@(ObjectLink _ _)
170 -> formatObjectLink -< (baseURI, link)
172 link@(PageLink _ _ _)
173 -> formatPageLink -< (baseURI, link)
175 link@(ExternalLink _ _)
176 -> formatExternalLink -< link
179 -> formatElem "br" -< (baseURI, attrs, [])
182 -> formatElem "span" -< (baseURI, attrs, contents)
185 -> formatImage -< (baseURI, img)
187 Anchor attrs contents
188 -> formatElem "a" -< (baseURI, attrs, contents)
193 formatElem :: (ArrowXml a, ArrowChoice a) =>
195 -> a (URI, [Attribute], [InlineElement]) XmlTree
197 = proc (baseURI, attrs, contents)
199 += ( arrL (fst . snd)
203 += ( (arr fst &&& arrL (snd . snd))
207 ) -< (baseURI, (attrs, contents))
210 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
211 attrFromPair = proc (name, value)
212 -> attr name (txt value) -<< ()
215 formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
217 = proc (baseURI, ObjectLink page text)
218 -> let uri = mkObjectURI baseURI page
219 href = uriToString id uri ""
220 label = fromMaybe ("{" ++ page ++ "}") text
222 mkAnchor -< (href, label)
225 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
227 = proc (baseURI, PageLink page fragment text)
228 -> let uri = case (page, fragment) of
229 (Just x, Just y) -> mkPageFragmentURI baseURI x y
230 (Just x, Nothing) -> mkPageURI baseURI x
231 (Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
232 href = uriToString id uri ""
233 dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
234 label = fromMaybe dLabel text
236 mkAnchor -< (href, label)
239 formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
240 formatImage = proc (baseURI, Image name alt)
241 -> let uri = mkObjectURI baseURI name
242 href = uriToString id uri ""
247 Just x -> sattr "alt" x
253 formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
255 = proc (ExternalLink uri text)
256 -> let href = uriToString id uri ""
257 label = fromMaybe href text
259 mkAnchor -< (href, label)
262 mkAnchor :: (ArrowXml a) => a (String, String) XmlTree
264 += attr "href" (arr fst >>> mkText)
265 += (arr snd >>> mkText)
268 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
269 attachXHtmlNs = processBottomUp (changeQName attach')
271 attach' :: QName -> QName
274 , namespaceUri = "http://www.w3.org/1999/xhtml"