import Control.Arrow
import Control.Arrow.ArrowList
+import Control.Arrow.ArrowTree
import Data.Char
import Data.List
import Data.Maybe
formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
formatWikiBlocks
= proc (baseURI, blocks)
- -> do block <- arrL id -< blocks
- formatBlock -< (baseURI, block)
+ -> do block <- arrL id -< blocks
+ tree <- formatBlock -< (baseURI, block)
+ attachXHtmlNs -< tree
formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
DefinitionList list
-> formatDefinitionList -< (baseURI, list)
- LeadingSpaced inlines
- -> formatLeadingSpaced -< (baseURI, inlines)
+ Preformatted inlines
+ -> formatPreformatted -< (baseURI, inlines)
Paragraph inlines
-> formatParagraph -< (baseURI, inlines)
+ Div attrs contents
+ -> formatElem "div" -< (baseURI, attrs, contents)
+
+ EmptyBlock
+ -> none -< ()
+ where
+ formatElem :: (ArrowXml a, ArrowChoice a) =>
+ String
+ -> a (URI, [Attribute], [BlockElement]) XmlTree
+ formatElem name
+ = proc (baseURI, attrs, contents)
+ -> ( eelem name
+ += ( arrL (fst . snd)
+ >>>
+ attrFromPair
+ )
+ += ( (arr fst &&& arrL (snd . snd))
+ >>>
+ formatBlock
+ )
+ ) -< (baseURI, (attrs, contents))
+
formatHeading :: ArrowXml a => a (Int, String) XmlTree
formatHeading
= proc (level, text)
- -> selem ("h" ++ show level) [txt text] -<< ()
+ -> mkelem ("h" ++ show level)
+ [ sattr "id" text ]
+ [ txt text ] -<< ()
formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
) -< (baseURI, def)
-formatLeadingSpaced :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
-formatLeadingSpaced
+formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
+formatPreformatted
= eelem "pre"
+= ( (arr fst &&& arrL snd)
>>>
Text text
-> mkText -< text
+ Italic contents
+ -> formatElem "i" -< (baseURI, [], contents)
+
+ Bold contents
+ -> formatElem "b" -< (baseURI, [], contents)
+
+ link@(ObjectLink _ _)
+ -> formatObjectLink -< (baseURI, link)
+
link@(PageLink _ _ _)
-> formatPageLink -< (baseURI, link)
+ link@(ExternalLink _ _)
+ -> formatExternalLink -< link
+
+ LineBreak attrs
+ -> formatElem "br" -< (baseURI, attrs, [])
+
+ Span attrs contents
+ -> formatElem "span" -< (baseURI, attrs, contents)
+
+ img@(Image _ _)
+ -> formatImage -< (baseURI, img)
+
+ Anchor attrs contents
+ -> formatElem "a" -< (baseURI, attrs, contents)
+
+ EmptyInline
+ -> none -< ()
+ where
+ formatElem :: (ArrowXml a, ArrowChoice a) =>
+ String
+ -> a (URI, [Attribute], [InlineElement]) XmlTree
+ formatElem name
+ = proc (baseURI, attrs, contents)
+ -> ( eelem name
+ += ( arrL (fst . snd)
+ >>>
+ attrFromPair
+ )
+ += ( (arr fst &&& arrL (snd . snd))
+ >>>
+ formatInline
+ )
+ ) -< (baseURI, (attrs, contents))
+
+
+attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
+attrFromPair = proc (name, value)
+ -> attr name (txt value) -<< ()
+
+
+formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
+formatObjectLink
+ = proc (baseURI, ObjectLink page text)
+ -> let uri = mkObjectURI baseURI page
+ href = uriToString id uri ""
+ label = fromMaybe ("{" ++ page ++ "}") text
+ in
+ mkAnchor -< (href, label)
+
formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
formatPageLink
= proc (baseURI, PageLink page fragment text)
-> let uri = case (page, fragment) of
- (Just x, Just y) -> mkPageFragmentURI baseURI (fix x) y
- (Just x, Nothing) -> mkPageURI baseURI (fix x)
+ (Just x, Just y) -> mkPageFragmentURI baseURI x y
+ (Just x, Nothing) -> mkPageURI baseURI x
(Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
- fix = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
href = uriToString id uri ""
dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
label = fromMaybe dLabel text
in
- ( eelem "a"
+ mkAnchor -< (href, label)
+
+
+formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
+formatImage = proc (baseURI, Image name alt)
+ -> let uri = mkObjectURI baseURI name
+ href = uriToString id uri ""
+ in
+ ( eelem "img"
+ += sattr "src" href
+ += ( case alt of
+ Just x -> sattr "alt" x
+ Nothing -> none
+ )
+ ) -<< ()
+
+
+formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
+formatExternalLink
+ = proc (ExternalLink uri text)
+ -> let href = uriToString id uri ""
+ label = fromMaybe href text
+ in
+ mkAnchor -< (href, label)
+
+
+mkAnchor :: (ArrowXml a) => a (String, String) XmlTree
+mkAnchor = eelem "a"
+= attr "href" (arr fst >>> mkText)
+= (arr snd >>> mkText)
- ) -< (href, label)
+
+
+attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
+attachXHtmlNs = processBottomUp (changeQName attach')
+ where
+ attach' :: QName -> QName
+ attach' qn = qn {
+ namePrefix = "xhtml"
+ , namespaceUri = "http://www.w3.org/1999/xhtml"
+ }