where
import Control.Arrow
+import Control.Arrow.ArrowIf
import Control.Arrow.ArrowList
import Control.Arrow.ArrowTree
import Data.Char
import Data.List
import Data.Maybe
-import Network.URI
+import Network.URI hiding (fragment)
import Rakka.Page
import Rakka.Wiki
import Text.XML.HXT.Arrow.XmlArrow
= proc (baseURI, blocks)
-> do block <- arrL id -< blocks
tree <- formatBlock -< (baseURI, block)
- attachXHtmlNs -< tree
+ attachXHtmlNS -< tree
+
+
+formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
+formatElement
+ = proc (baseURI, e)
+ -> case e of
+ Block b -> formatBlock -< (baseURI, b)
+ Inline i -> formatInline -< (baseURI, i)
formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
HorizontalLine
-> eelem "hr" -< ()
- List list
+ list@(List _ _)
-> formatListElement -< (baseURI, list)
DefinitionList list
EmptyBlock
-> none -< ()
+
+ _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
where
formatElem :: (ArrowXml a, ArrowChoice a) =>
String
- -> a (URI, [Attribute], [BlockElement]) XmlTree
+ -> a (URI, [Attribute], [Element]) XmlTree
formatElem name
= proc (baseURI, attrs, contents)
-> ( eelem name
)
+= ( (arr fst &&& arrL (snd . snd))
>>>
- formatBlock
+ formatElement
)
) -< (baseURI, (attrs, contents))
[ txt text ] -<< ()
-formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
+formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
formatListElement
= proc (baseURI, list)
-> let tag = case listType list of
-> eelem "li"
+= ( (arr fst &&& arrL snd)
>>>
- formatListItem'
+ formatElement
) -< (baseURI, item)
- formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
- formatListItem'
- = proc (baseURI, x)
- -> case x of
- Left nestedList -> formatListElement -< (baseURI, nestedList)
- Right inline -> formatInline -< (baseURI, inline )
-
formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
formatDefinitionList
Bold contents
-> formatElem "b" -< (baseURI, [], contents)
+ link@(ObjectLink _ _)
+ -> formatObjectLink -< (baseURI, link)
+
link@(PageLink _ _ _)
-> formatPageLink -< (baseURI, link)
Span attrs contents
-> formatElem "span" -< (baseURI, attrs, contents)
- Image attrs
- -> formatElem "img" -< (baseURI, attrs, [])
+ img@(Image _ _)
+ -> formatImage -< (baseURI, img)
Anchor attrs contents
-> formatElem "a" -< (baseURI, attrs, contents)
+ Input attrs
+ -> formatElem "input" -< (baseURI, attrs, [])
+
EmptyInline
-> none -< ()
+
+ _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
where
formatElem :: (ArrowXml a, ArrowChoice a) =>
String
-> 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)
- (Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
- fix = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
+ (Just x, Just y) -> mkPageFragmentURI baseURI x y
+ (Just x, Nothing) -> mkPageURI baseURI x
+ (Nothing, Just y) -> mkFragmentURI y
+ _ -> undefined
href = uriToString id uri ""
dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
label = fromMaybe dLabel text
in
- ( eelem "a"
- += attr "href" (arr fst >>> mkText)
- += (arr snd >>> mkText)
- ) -< (href, label)
+ mkAnchor -< (href, label)
+
+
+formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
+formatImage = proc (baseURI, Image src alt)
+ -> let uri = case src of
+ Left u -> u
+ Right name -> 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
-> let href = uriToString id uri ""
label = fromMaybe href text
in
- ( eelem "a"
+ 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')
+attachXHtmlNS :: (ArrowXml a) => a XmlTree XmlTree
+attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
where
- attach' :: QName -> QName
- attach' qn = qn {
- namePrefix = "xhtml"
- , namespaceUri = "http://www.w3.org/1999/xhtml"
- }
+ attach :: QName -> QName
+ attach qn = qn {
+ namePrefix = "xhtml"
+ , namespaceUri = "http://www.w3.org/1999/xhtml"
+ }