1 module Rakka.Wiki.Formatter
7 import Control.Arrow.ArrowList
11 import Network.URI hiding (fragment)
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
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 _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
64 formatElem :: (ArrowXml a, ArrowChoice a) =>
66 -> a (URI, [Attribute], [Element]) XmlTree
68 = proc (baseURI, attrs, contents)
74 += ( (arr fst &&& arrL (snd . snd))
78 ) -< (baseURI, (attrs, contents))
81 formatHeading :: ArrowXml a => a (Int, String) XmlTree
84 -> mkelem ("h" ++ show level)
89 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
91 = proc (baseURI, list)
92 -> let tag = case listType list of
97 += ( (constA baseURI &&& constL (listItems list))
103 formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
105 = proc (baseURI, item)
107 += ( (arr fst &&& arrL snd)
113 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
115 = proc (baseURI, list)
117 += ( (arr fst &&& arrL snd)
123 formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
125 = proc (baseURI, def)
127 += ( (arr fst &&& arrL (defTerm . snd))
133 += ( (arr fst &&& arrL (defDesc . snd))
140 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
143 += ( (arr fst &&& arrL snd)
149 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
152 += ( (arr fst &&& arrL snd)
158 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
166 -> formatElem "i" -< (baseURI, [], contents)
169 -> formatElem "b" -< (baseURI, [], contents)
171 link@(ObjectLink _ _)
172 -> formatObjectLink -< (baseURI, link)
174 link@(PageLink _ _ _)
175 -> formatPageLink -< (baseURI, link)
177 link@(ExternalLink _ _)
178 -> formatExternalLink -< link
181 -> formatElem "br" -< (baseURI, attrs, [])
184 -> formatElem "span" -< (baseURI, attrs, contents)
187 -> formatImage -< (baseURI, img)
189 Anchor attrs contents
190 -> formatElem "a" -< (baseURI, attrs, contents)
193 -> formatElem "input" -< (baseURI, attrs, [])
198 _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
200 formatElem :: (ArrowXml a, ArrowChoice a) =>
202 -> a (URI, [Attribute], [InlineElement]) XmlTree
204 = proc (baseURI, attrs, contents)
206 += ( arrL (fst . snd)
210 += ( (arr fst &&& arrL (snd . snd))
214 ) -< (baseURI, (attrs, contents))
217 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
218 attrFromPair = proc (name, value)
219 -> attr name (txt value) -<< ()
222 formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
224 = proc (baseURI, ObjectLink page text)
225 -> let uri = mkObjectURI baseURI page
226 href = uriToString id uri ""
227 label = fromMaybe ("{" ++ page ++ "}") text
229 mkAnchor -< (href, label)
232 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
234 = proc (baseURI, PageLink page fragment text)
235 -> let uri = case (page, fragment) of
236 (Just x, Just y) -> mkPageFragmentURI baseURI x y
237 (Just x, Nothing) -> mkPageURI baseURI x
238 (Nothing, Just y) -> mkFragmentURI y
240 href = uriToString id uri ""
241 dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
242 label = fromMaybe dLabel text
244 mkAnchor -< (href, label)
247 formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
248 formatImage = proc (baseURI, Image src alt)
249 -> let uri = case src of
251 Right name -> mkObjectURI baseURI name
252 href = uriToString id uri ""
257 Just x -> sattr "alt" x
263 formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
265 = proc (ExternalLink uri text)
266 -> let href = uriToString id uri ""
267 label = fromMaybe href text
269 mkAnchor -< (href, label)
272 mkAnchor :: (ArrowXml a) => a (String, String) XmlTree
274 += attr "href" (arr fst >>> mkText)
275 += (arr snd >>> mkText)