X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FWiki%2FFormatter.hs;fp=Rakka%2FWiki%2FFormatter.hs;h=c1e63f5c05138ab1a4caa4b4de7f84b3dd8a49fe;hp=5f7c7d8c10b952a1c7d7df404da7bc1667e2113c;hb=42f51754dea02201aececaacbf194d714cd58aaf;hpb=98fd1cb53a837a9bda7145544c34872acb13a634 diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 5f7c7d8..c1e63f5 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -1,19 +1,30 @@ +{-# LANGUAGE + Arrows + , OverloadedStrings + , TypeOperators + , UnicodeSyntax + , ViewPatterns + #-} module Rakka.Wiki.Formatter ( formatWikiBlocks ) where - -import Control.Arrow -import Control.Arrow.ArrowIf -import Control.Arrow.ArrowList -import Control.Arrow.ArrowTree -import Data.Maybe -import Network.URI hiding (fragment) -import Rakka.Page -import Rakka.Wiki -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.DOM.TypeDefs - +import Control.Arrow +import Control.Arrow.ArrowIf +import Control.Arrow.ArrowList +import Control.Arrow.ArrowTree +import Control.Arrow.Unicode +import qualified Data.CaseInsensitive as CS +import Data.Maybe +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import Network.URI hiding (fragment) +import Prelude.Unicode +import Rakka.Page +import Rakka.Wiki +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.DOM.TypeDefs formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree formatWikiBlocks @@ -30,13 +41,12 @@ formatElement Block b -> formatBlock -< (baseURI, b) Inline i -> formatInline -< (baseURI, i) - -formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree +formatBlock ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, BlockElement) ⇝ XmlTree formatBlock = proc (baseURI, block) - -> case block of + → case block of Heading level text - -> formatHeading -< (level, text) + → formatHeading ⤙ (level, text) HorizontalLine -> eelem "hr" -< () @@ -78,12 +88,12 @@ formatBlock ) -< (baseURI, (attrs, contents)) -formatHeading :: ArrowXml a => a (Int, String) XmlTree +formatHeading ∷ ArrowXml (⇝) ⇒ (Int, Text) ⇝ XmlTree formatHeading - = proc (level, text) - -> mkelem ("h" ++ show level) + = proc (level, T.unpack → text) + -> mkelem ("h" ⊕ show level) [ sattr "id" text ] - [ txt text ] -<< () + [ txt text ] ⤛ () formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree @@ -154,13 +164,12 @@ formatParagraph formatInline ) - -formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree +formatInline ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, InlineElement) ⇝ XmlTree formatInline = proc (baseURI, i) - -> case i of + → case i of Text text - -> mkText -< text + → mkText ⤙ T.unpack text Italic contents -> formatElem "i" -< (baseURI, [], contents) @@ -197,87 +206,78 @@ formatInline _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i where - formatElem :: (ArrowXml a, ArrowChoice a) => + formatElem ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ String - -> a (URI, [Attribute], [InlineElement]) XmlTree + → (URI, [Attribute], [InlineElement]) ⇝ XmlTree formatElem name = proc (baseURI, attrs, contents) - -> ( eelem name - += ( arrL (fst . snd) - >>> - attrFromPair + → ( eelem name + += ( arrL (fst ∘ snd) + ⋙ + attrFromPair ) += ( (arr fst &&& arrL (snd . snd)) - >>> + ⋙ formatInline ) - ) -< (baseURI, (attrs, contents)) + ) ⤙ (baseURI, (attrs, contents)) +attrFromPair ∷ ArrowXml (⇝) ⇒ Attribute ⇝ XmlTree +attrFromPair = proc (T.unpack ∘ CS.original → name, T.unpack → value) + → attr name (txt value) ⤛ () -attrFromPair :: (ArrowXml a) => a (String, String) XmlTree -attrFromPair = proc (name, value) - -> attr name (txt value) -<< () - - -formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree +formatObjectLink ∷ ArrowXml (⇝) ⇒ (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) + → let uri = mkObjectURI baseURI page + label = fromMaybe ("{" ⊕ page ⊕ "}") text + in + mkAnchor ⤙ (uri, label) - -formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree +formatPageLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree formatPageLink = proc (baseURI, PageLink page fragment text) - -> let uri = case (page, fragment) of - (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 - mkAnchor -< (href, label) - - -formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree + → let uri = case (page, fragment) of + (Just x, Just y) → mkPageFragmentURI baseURI x y + (Just x, Nothing) → mkPageURI baseURI x + (Nothing, Just y) → mkFragmentURI y + _ → (⊥) + dLabel = fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragment + label = fromMaybe dLabel text + in + mkAnchor ⤙ (uri, label) + +formatImage ∷ ArrowXml (⇝) ⇒ (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 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" (T.unpack x) + Nothing → none + ) + ) ⤛ () + + +formatExternalLink ∷ ArrowXml (⇝) ⇒ InlineElement ⇝ XmlTree formatExternalLink = proc (ExternalLink uri text) - -> let href = uriToString id uri "" - label = fromMaybe href text - in - mkAnchor -< (href, label) + → let href = uriToString id uri "" + label = fromMaybe (T.pack href) text + in + mkAnchor -< (uri, label) - -mkAnchor :: (ArrowXml a) => a (String, String) XmlTree +mkAnchor ∷ ArrowXml (⇝) ⇒ (URI, Text) ⇝ XmlTree mkAnchor = eelem "a" - += attr "href" (arr fst >>> mkText) - += (arr snd >>> mkText) - + += attr "href" (arr (flip (uriToString id) "" ∘ fst) ⋙ mkText) + += (arr (T.unpack ∘ snd) ⋙ mkText) -attachXHtmlNS :: (ArrowXml a) => a XmlTree XmlTree +attachXHtmlNS ∷ ArrowXml (⇝) ⇒ XmlTree ⇝ XmlTree attachXHtmlNS = processTopDown (changeQName attach `when` isElem) where - attach :: QName -> QName - attach = setNamePrefix' (newXName "xhtml") . - setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml") + attach ∷ QName → QName + attach = setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")