where
import Control.Arrow
+import Control.Arrow.ArrowIf
import Control.Arrow.ArrowList
-import Data.Char
-import Data.List
+import Control.Arrow.ArrowTree
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)
- returnA -< tree
+ attachXHtmlNS -< tree
formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
formatElement
- = proc (baseURI, elem)
- -> case elem of
+ = proc (baseURI, e)
+ -> case e of
Block b -> formatBlock -< (baseURI, b)
Inline i -> formatInline -< (baseURI, i)
EmptyBlock
-> none -< ()
+
+ _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
where
formatElem :: (ArrowXml a, ArrowChoice a) =>
String
EmptyInline
-> none -< ()
+
+ _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
where
formatElem :: (ArrowXml a, ArrowChoice a) =>
String
(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
formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
formatImage = proc (baseURI, Image src alt)
- -> let uri = mkObjectURI baseURI src
+ -> let uri = case src of
+ Left u -> u
+ Right name -> mkObjectURI baseURI name
href = uriToString id uri ""
in
( eelem "img"
mkAnchor = eelem "a"
+= attr "href" (arr fst >>> mkText)
+= (arr snd >>> mkText)
+
+
+attachXHtmlNS :: (ArrowXml a) => a XmlTree XmlTree
+attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
+ where
+ attach :: QName -> QName
+ attach = setNamePrefix' (newXName "xhtml") .
+ setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")