1 module Rakka.Wiki.Formatter
7 import Control.Arrow.ArrowIf
8 import Control.Arrow.ArrowList
9 import Control.Arrow.ArrowTree
13 import Network.URI hiding (fragment)
16 import Text.XML.HXT.Arrow.XmlArrow
17 import Text.XML.HXT.DOM.TypeDefs
20 formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
22 = proc (baseURI, blocks)
23 -> do block <- arrL id -< blocks
24 tree <- formatBlock -< (baseURI, block)
28 formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
32 Block b -> formatBlock -< (baseURI, b)
33 Inline i -> formatInline -< (baseURI, i)
36 formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
38 = proc (baseURI, block)
41 -> formatHeading -< (level, text)
47 -> formatListElement -< (baseURI, list)
50 -> formatDefinitionList -< (baseURI, list)
53 -> formatPreformatted -< (baseURI, inlines)
56 -> formatParagraph -< (baseURI, inlines)
59 -> formatElem "div" -< (baseURI, attrs, contents)
64 _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
66 formatElem :: (ArrowXml a, ArrowChoice a) =>
68 -> a (URI, [Attribute], [Element]) XmlTree
70 = proc (baseURI, attrs, contents)
76 += ( (arr fst &&& arrL (snd . snd))
80 ) -< (baseURI, (attrs, contents))
83 formatHeading :: ArrowXml a => a (Int, String) XmlTree
86 -> mkelem ("h" ++ show level)
91 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
93 = proc (baseURI, list)
94 -> let tag = case listType list of
99 += ( (constA baseURI &&& constL (listItems list))
105 formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
107 = proc (baseURI, item)
109 += ( (arr fst &&& arrL snd)
115 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
117 = proc (baseURI, list)
119 += ( (arr fst &&& arrL snd)
125 formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
127 = proc (baseURI, def)
129 += ( (arr fst &&& arrL (defTerm . snd))
135 += ( (arr fst &&& arrL (defDesc . snd))
142 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
145 += ( (arr fst &&& arrL snd)
151 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
154 += ( (arr fst &&& arrL snd)
160 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
168 -> formatElem "i" -< (baseURI, [], contents)
171 -> formatElem "b" -< (baseURI, [], contents)
173 link@(ObjectLink _ _)
174 -> formatObjectLink -< (baseURI, link)
176 link@(PageLink _ _ _)
177 -> formatPageLink -< (baseURI, link)
179 link@(ExternalLink _ _)
180 -> formatExternalLink -< link
183 -> formatElem "br" -< (baseURI, attrs, [])
186 -> formatElem "span" -< (baseURI, attrs, contents)
189 -> formatImage -< (baseURI, img)
191 Anchor attrs contents
192 -> formatElem "a" -< (baseURI, attrs, contents)
195 -> formatElem "input" -< (baseURI, attrs, [])
200 _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
202 formatElem :: (ArrowXml a, ArrowChoice a) =>
204 -> a (URI, [Attribute], [InlineElement]) XmlTree
206 = proc (baseURI, attrs, contents)
208 += ( arrL (fst . snd)
212 += ( (arr fst &&& arrL (snd . snd))
216 ) -< (baseURI, (attrs, contents))
219 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
220 attrFromPair = proc (name, value)
221 -> attr name (txt value) -<< ()
224 formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
226 = proc (baseURI, ObjectLink page text)
227 -> let uri = mkObjectURI baseURI page
228 href = uriToString id uri ""
229 label = fromMaybe ("{" ++ page ++ "}") text
231 mkAnchor -< (href, label)
234 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
236 = proc (baseURI, PageLink page fragment text)
237 -> let uri = case (page, fragment) of
238 (Just x, Just y) -> mkPageFragmentURI baseURI x y
239 (Just x, Nothing) -> mkPageURI baseURI x
240 (Nothing, Just y) -> mkFragmentURI y
242 href = uriToString id uri ""
243 dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
244 label = fromMaybe dLabel text
246 mkAnchor -< (href, label)
249 formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
250 formatImage = proc (baseURI, Image src alt)
251 -> let uri = case src of
253 Right name -> mkObjectURI baseURI name
254 href = uriToString id uri ""
259 Just x -> sattr "alt" x
265 formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
267 = proc (ExternalLink uri text)
268 -> let href = uriToString id uri ""
269 label = fromMaybe href text
271 mkAnchor -< (href, label)
274 mkAnchor :: (ArrowXml a) => a (String, String) XmlTree
276 += attr "href" (arr fst >>> mkText)
277 += (arr snd >>> mkText)
280 attachXHtmlNS :: (ArrowXml a) => a XmlTree XmlTree
281 attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
283 attach :: QName -> QName
286 , namespaceUri = "http://www.w3.org/1999/xhtml"