+{-# 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
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" -< ()
) -< (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
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)
_ -> 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")
projects / Rakka.git / blobdiff