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 tree <- formatBlock -< (baseURI, block)
26 formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
28 = proc (baseURI, elem)
30 Block b -> formatBlock -< (baseURI, b)
31 Inline i -> formatInline -< (baseURI, i)
34 formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
36 = proc (baseURI, block)
39 -> formatHeading -< (level, text)
45 -> formatListElement -< (baseURI, list)
48 -> formatDefinitionList -< (baseURI, list)
51 -> formatPreformatted -< (baseURI, inlines)
54 -> formatParagraph -< (baseURI, inlines)
57 -> formatElem "div" -< (baseURI, attrs, contents)
62 formatElem :: (ArrowXml a, ArrowChoice a) =>
64 -> a (URI, [Attribute], [Element]) XmlTree
66 = proc (baseURI, attrs, contents)
72 += ( (arr fst &&& arrL (snd . snd))
76 ) -< (baseURI, (attrs, contents))
79 formatHeading :: ArrowXml a => a (Int, String) XmlTree
82 -> mkelem ("h" ++ show level)
87 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
89 = proc (baseURI, list)
90 -> let tag = case listType list of
95 += ( (constA baseURI &&& constL (listItems list))
101 formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
103 = proc (baseURI, item)
105 += ( (arr fst &&& arrL snd)
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)
191 -> formatElem "input" -< (baseURI, attrs, [])
196 formatElem :: (ArrowXml a, ArrowChoice a) =>
198 -> a (URI, [Attribute], [InlineElement]) XmlTree
200 = proc (baseURI, attrs, contents)
202 += ( arrL (fst . snd)
206 += ( (arr fst &&& arrL (snd . snd))
210 ) -< (baseURI, (attrs, contents))
213 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
214 attrFromPair = proc (name, value)
215 -> attr name (txt value) -<< ()
218 formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
220 = proc (baseURI, ObjectLink page text)
221 -> let uri = mkObjectURI baseURI page
222 href = uriToString id uri ""
223 label = fromMaybe ("{" ++ page ++ "}") text
225 mkAnchor -< (href, label)
228 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
230 = proc (baseURI, PageLink page fragment text)
231 -> let uri = case (page, fragment) of
232 (Just x, Just y) -> mkPageFragmentURI baseURI x y
233 (Just x, Nothing) -> mkPageURI baseURI x
234 (Nothing, Just y) -> mkFragmentURI y
235 href = uriToString id uri ""
236 dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
237 label = fromMaybe dLabel text
239 mkAnchor -< (href, label)
242 formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
243 formatImage = proc (baseURI, Image src alt)
244 -> let uri = case src of
246 Right name -> mkObjectURI baseURI name
247 href = uriToString id uri ""
252 Just x -> sattr "alt" x
258 formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
260 = proc (ExternalLink uri text)
261 -> let href = uriToString id uri ""
262 label = fromMaybe href text
264 mkAnchor -< (href, label)
267 mkAnchor :: (ArrowXml a) => a (String, String) XmlTree
269 += attr "href" (arr fst >>> mkText)
270 += (arr snd >>> mkText)