8 module Rakka.Wiki.Formatter
13 import Control.Arrow.ArrowIf
14 import Control.Arrow.ArrowList
15 import Control.Arrow.ArrowTree
16 import Control.Arrow.Unicode
17 import qualified Data.CaseInsensitive as CS
19 import Data.Monoid.Unicode
20 import Data.Text (Text)
21 import qualified Data.Text as T
22 import Network.URI hiding (fragment)
23 import Prelude.Unicode
26 import Text.XML.HXT.Arrow.XmlArrow
27 import Text.XML.HXT.DOM.TypeDefs
29 formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
31 = proc (baseURI, blocks)
32 -> do block <- arrL id -< blocks
33 tree <- formatBlock -< (baseURI, block)
37 formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
41 Block b -> formatBlock -< (baseURI, b)
42 Inline i -> formatInline -< (baseURI, i)
44 formatBlock ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, BlockElement) ⇝ XmlTree
46 = proc (baseURI, block)
49 → formatHeading ⤙ (level, text)
55 -> formatListElement -< (baseURI, list)
58 -> formatDefinitionList -< (baseURI, list)
61 -> formatPreformatted -< (baseURI, inlines)
64 -> formatParagraph -< (baseURI, inlines)
67 -> formatElem "div" -< (baseURI, attrs, contents)
72 _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
74 formatElem :: (ArrowXml a, ArrowChoice a) =>
76 -> a (URI, [Attribute], [Element]) XmlTree
78 = proc (baseURI, attrs, contents)
84 += ( (arr fst &&& arrL (snd . snd))
88 ) -< (baseURI, (attrs, contents))
91 formatHeading ∷ ArrowXml (⇝) ⇒ (Int, Text) ⇝ XmlTree
93 = proc (level, T.unpack → text)
94 -> mkelem ("h" ⊕ show level)
99 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
101 = proc (baseURI, list)
102 -> let tag = case listType list of
107 += ( (constA baseURI &&& constL (listItems list))
113 formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
115 = proc (baseURI, item)
117 += ( (arr fst &&& arrL snd)
123 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
125 = proc (baseURI, list)
127 += ( (arr fst &&& arrL snd)
133 formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
135 = proc (baseURI, def)
137 += ( (arr fst &&& arrL (defTerm . snd))
143 += ( (arr fst &&& arrL (defDesc . snd))
150 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
153 += ( (arr fst &&& arrL snd)
159 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
162 += ( (arr fst &&& arrL snd)
167 formatInline ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, InlineElement) ⇝ XmlTree
172 → mkText ⤙ T.unpack text
175 -> formatElem "i" -< (baseURI, [], contents)
178 -> formatElem "b" -< (baseURI, [], contents)
180 link@(ObjectLink _ _)
181 -> formatObjectLink -< (baseURI, link)
183 link@(PageLink _ _ _)
184 -> formatPageLink -< (baseURI, link)
186 link@(ExternalLink _ _)
187 -> formatExternalLink -< link
190 -> formatElem "br" -< (baseURI, attrs, [])
193 -> formatElem "span" -< (baseURI, attrs, contents)
196 -> formatImage -< (baseURI, img)
198 Anchor attrs contents
199 -> formatElem "a" -< (baseURI, attrs, contents)
202 -> formatElem "input" -< (baseURI, attrs, [])
207 _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
209 formatElem ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒
211 → (URI, [Attribute], [InlineElement]) ⇝ XmlTree
213 = proc (baseURI, attrs, contents)
215 += ( arrL (fst ∘ snd)
219 += ( (arr fst &&& arrL (snd . snd))
223 ) ⤙ (baseURI, (attrs, contents))
225 attrFromPair ∷ ArrowXml (⇝) ⇒ Attribute ⇝ XmlTree
226 attrFromPair = proc (T.unpack ∘ CS.original → name, T.unpack → value)
227 → attr name (txt value) ⤛ ()
229 formatObjectLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
231 = proc (baseURI, ObjectLink page text)
232 → let uri = mkObjectURI baseURI page
233 label = fromMaybe ("{" ⊕ page ⊕ "}") text
235 mkAnchor ⤙ (uri, label)
237 formatPageLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
239 = proc (baseURI, PageLink page fragment text)
240 → let uri = case (page, fragment) of
241 (Just x, Just y) → mkPageFragmentURI baseURI x y
242 (Just x, Nothing) → mkPageURI baseURI x
243 (Nothing, Just y) → mkFragmentURI y
245 dLabel = fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragment
246 label = fromMaybe dLabel text
248 mkAnchor ⤙ (uri, label)
250 formatImage ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
251 formatImage = proc (baseURI, Image src alt)
252 → let uri = case src of
254 Right name → mkObjectURI baseURI name
255 href = uriToString id uri ""
260 Just x → sattr "alt" (T.unpack x)
266 formatExternalLink ∷ ArrowXml (⇝) ⇒ InlineElement ⇝ XmlTree
268 = proc (ExternalLink uri text)
269 → let href = uriToString id uri ""
270 label = fromMaybe (T.pack href) text
272 mkAnchor -< (uri, label)
274 mkAnchor ∷ ArrowXml (⇝) ⇒ (URI, Text) ⇝ XmlTree
276 += attr "href" (arr (flip (uriToString id) "" ∘ fst) ⋙ mkText)
277 += (arr (T.unpack ∘ snd) ⋙ mkText)
279 attachXHtmlNS ∷ ArrowXml (⇝) ⇒ XmlTree ⇝ XmlTree
280 attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
282 attach ∷ QName → QName
283 attach = setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")