X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FFormatter.hs;h=90687f4e8479a1c11593e770b6cf899fd67f71ee;hb=706ee842873fdceb9465cdf6a583176ab855fae2;hp=b81c510594f75253678f9dfc7995899e627615c5;hpb=3c5211253dc61c31196a47486c538b64c32d8c5e;p=Rakka.git diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index b81c510..90687f4 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -4,12 +4,13 @@ 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,7 +22,15 @@ 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, e) + -> case e of + Block b -> formatBlock -< (baseURI, b) + Inline i -> formatInline -< (baseURI, i) formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree @@ -34,7 +43,7 @@ formatBlock HorizontalLine -> eelem "hr" -< () - List list + list@(List _ _) -> formatListElement -< (baseURI, list) DefinitionList list @@ -51,10 +60,12 @@ formatBlock 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 @@ -64,7 +75,7 @@ formatBlock ) += ( (arr fst &&& arrL (snd . snd)) >>> - formatBlock + formatElement ) ) -< (baseURI, (attrs, contents)) @@ -77,7 +88,7 @@ formatHeading [ 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 @@ -97,16 +108,9 @@ formatListElement -> 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 @@ -166,6 +170,9 @@ formatInline Bold contents -> formatElem "b" -< (baseURI, [], contents) + link@(ObjectLink _ _) + -> formatObjectLink -< (baseURI, link) + link@(PageLink _ _ _) -> formatPageLink -< (baseURI, link) @@ -178,14 +185,19 @@ formatInline 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 @@ -209,22 +221,45 @@ 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) - (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 @@ -233,17 +268,18 @@ formatExternalLink -> 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 = setNamePrefix' (newXName "xhtml") . + setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")