X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=Rakka%2FWiki%2FFormatter.hs;h=5f7c7d8c10b952a1c7d7df404da7bc1667e2113c;hb=fcddebcc3cc02ae8d1904b9338334d538019e74a;hp=3f0960604887663d1a479719339d0d8a480339bb;hpb=e43bb104a7313dd696b8bb8aa3bafff94706a187;p=Rakka.git diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 3f09606..5f7c7d8 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -4,12 +4,11 @@ module Rakka.Wiki.Formatter 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 @@ -21,13 +20,13 @@ formatWikiBlocks = 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, elem) - -> case elem of + = proc (baseURI, e) + -> case e of Block b -> formatBlock -< (baseURI, b) Inline i -> formatInline -< (baseURI, i) @@ -59,6 +58,8 @@ formatBlock EmptyBlock -> none -< () + + _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block where formatElem :: (ArrowXml a, ArrowChoice a) => String @@ -188,8 +189,13 @@ formatInline 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 @@ -229,7 +235,8 @@ formatPageLink -> let uri = case (page, fragment) of (Just x, Just y) -> mkPageFragmentURI baseURI x y (Just x, Nothing) -> mkPageURI baseURI x - (Nothing, Just y) -> nullURI { uriFragment = ('#':y) } + (Nothing, Just y) -> mkFragmentURI y + _ -> undefined href = uriToString id uri "" dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment) label = fromMaybe dLabel text @@ -238,8 +245,10 @@ formatPageLink formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree -formatImage = proc (baseURI, Image name alt) - -> let uri = mkObjectURI baseURI name +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" @@ -266,11 +275,9 @@ mkAnchor = eelem "a" += (arr snd >>> mkText) -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 = setNamePrefix' (newXName "xhtml") . + setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")