Rakka/Wiki/Formatter.hs

   1 {-# LANGUAGE
   2     Arrows
   3   , OverloadedStrings
   4   , TypeOperators
   5   , UnicodeSyntax
   6   , ViewPatterns
   7   #-}
   8 module Rakka.Wiki.Formatter
   9     ( formatWikiBlocks
  10     )
  11     where
  12 import Control.Arrow
  13 import Control.Arrow.ArrowIf
  14 import Control.Arrow.ArrowList
  15 import Control.Arrow.ArrowTree
  16 import Control.Arrow.Unicode
  17 import qualified Data.CaseInsensitive as CS
  18 import Data.Maybe
  19 import Data.Monoid.Unicode
  20 import Data.Text (Text)
  21 import qualified Data.Text as T
  22 import Network.URI hiding (fragment)
  23 import Prelude.Unicode
  24 import Rakka.Page
  25 import Rakka.Wiki
  26 import Text.XML.HXT.Arrow.XmlArrow
  27 import Text.XML.HXT.DOM.TypeDefs
  28
  29 formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
  30 formatWikiBlocks
  31     = proc (baseURI, blocks)
  32     -> do block   <- arrL id     -< blocks
  33           tree    <- formatBlock -< (baseURI, block)
  34           attachXHtmlNS -< tree
  35
  36
  37 formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
  38 formatElement
  39     = proc (baseURI, e)
  40     -> case e of
  41          Block  b -> formatBlock  -< (baseURI, b)
  42          Inline i -> formatInline -< (baseURI, i)
  43
  44 formatBlock ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, BlockElement) ⇝ XmlTree
  45 formatBlock
  46     = proc (baseURI, block)
  47     → case block of
  48          Heading level text
  49              → formatHeading ⤙ (level, text)
  50
  51          HorizontalLine
  52              -> eelem "hr" -< ()
  53
  54          list@(List _ _)
  55              -> formatListElement -< (baseURI, list)
  56
  57          DefinitionList list
  58              -> formatDefinitionList -< (baseURI, list)
  59
  60          Preformatted inlines
  61              -> formatPreformatted -< (baseURI, inlines)
  62
  63          Paragraph inlines
  64              -> formatParagraph -< (baseURI, inlines)
  65
  66          Div attrs contents
  67              -> formatElem "div" -< (baseURI, attrs, contents)
  68
  69          EmptyBlock
  70              -> none -< ()
  71
  72          _   -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
  73     where
  74       formatElem :: (ArrowXml a, ArrowChoice a) =>
  75                     String
  76                  -> a (URI, [Attribute], [Element]) XmlTree
  77       formatElem name
  78           = proc (baseURI, attrs, contents)
  79           -> ( eelem name
  80                += ( arrL (fst . snd)
  81                        >>>
  82                        attrFromPair
  83                   )
  84                += ( (arr fst &&& arrL (snd . snd))
  85                     >>>
  86                     formatElement
  87                   )
  88              ) -< (baseURI, (attrs, contents))
  89
  90
  91 formatHeading ∷ ArrowXml (⇝) ⇒ (Int, Text) ⇝ XmlTree
  92 formatHeading
  93     = proc (level, T.unpack → text)
  94     -> mkelem ("h" ⊕ show level)
  95        [ sattr "id" text ]
  96        [ txt text        ] ⤛ ()
  97
  98
  99 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
 100 formatListElement
 101     = proc (baseURI, list)
 102     -> let tag = case listType list of
 103                    Bullet   -> "ul"
 104                    Numbered -> "ol"
 105        in
 106          ( eelem tag
 107            += ( (constA baseURI &&& constL (listItems list))
 108                 >>>
 109                 formatListItem
 110               )
 111          ) -<< ()
 112       where
 113         formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
 114         formatListItem
 115             = proc (baseURI, item)
 116             -> eelem "li"
 117                += ( (arr fst &&& arrL snd)
 118                     >>>
 119                     formatElement
 120                   ) -< (baseURI, item)
 121
 122
 123 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
 124 formatDefinitionList
 125     = proc (baseURI, list)
 126     -> ( eelem "dl"
 127          += ( (arr fst &&& arrL snd)
 128               >>>
 129               formatDefinition
 130             )
 131        ) -< (baseURI, list)
 132     where
 133       formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
 134       formatDefinition
 135           = proc (baseURI, def)
 136           -> ( eelem "dt"
 137                += ( (arr fst &&& arrL (defTerm . snd))
 138                     >>>
 139                     formatInline
 140                   )
 141                <+>
 142                eelem "dd"
 143                += ( (arr fst &&& arrL (defDesc . snd))
 144                     >>>
 145                     formatInline
 146                   )
 147              ) -< (baseURI, def)
 148
 149
 150 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
 151 formatPreformatted
 152     = eelem "pre"
 153       += ( (arr fst &&& arrL snd)
 154            >>>
 155            formatInline
 156          )
 157
 158
 159 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
 160 formatParagraph
 161     = eelem "p"
 162       += ( (arr fst &&& arrL snd)
 163            >>>
 164            formatInline
 165          )
 166
 167 formatInline ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, InlineElement) ⇝ XmlTree
 168 formatInline
 169     = proc (baseURI, i)
 170     → case i of
 171          Text text
 172              → mkText ⤙ T.unpack text
 173
 174          Italic contents
 175              -> formatElem "i" -< (baseURI, [], contents)
 176
 177          Bold contents
 178              -> formatElem "b" -< (baseURI, [], contents)
 179
 180          link@(ObjectLink _ _)
 181              -> formatObjectLink -< (baseURI, link)
 182
 183          link@(PageLink _ _ _)
 184              -> formatPageLink -< (baseURI, link)
 185
 186          link@(ExternalLink _ _)
 187              -> formatExternalLink -< link
 188
 189          LineBreak attrs
 190              -> formatElem "br" -< (baseURI, attrs, [])
 191
 192          Span attrs contents
 193              -> formatElem "span" -< (baseURI, attrs, contents)
 194
 195          img@(Image _ _)
 196              -> formatImage -< (baseURI, img)
 197
 198          Anchor attrs contents
 199              -> formatElem "a" -< (baseURI, attrs, contents)
 200
 201          Input attrs
 202              -> formatElem "input" -< (baseURI, attrs, [])
 203
 204          EmptyInline
 205              -> none -< ()
 206
 207          _   -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
 208     where
 209       formatElem ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒
 210                     String
 211                  → (URI, [Attribute], [InlineElement]) ⇝ XmlTree
 212       formatElem name
 213           = proc (baseURI, attrs, contents)
 214           → ( eelem name
 215                += ( arrL (fst ∘ snd)
 216                     ⋙
 217                     attrFromPair
 218                   )
 219                += ( (arr fst &&& arrL (snd . snd))
 220                     ⋙
 221                     formatInline
 222                   )
 223              ) ⤙ (baseURI, (attrs, contents))
 224
 225 attrFromPair ∷ ArrowXml (⇝) ⇒ Attribute ⇝ XmlTree
 226 attrFromPair = proc (T.unpack ∘ CS.original → name, T.unpack → value)
 227              → attr name (txt value) ⤛ ()
 228
 229 formatObjectLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
 230 formatObjectLink
 231     = proc (baseURI, ObjectLink page text)
 232     → let uri   = mkObjectURI baseURI page
 233           label = fromMaybe ("{" ⊕ page ⊕ "}") text
 234       in
 235         mkAnchor ⤙ (uri, label)
 236
 237 formatPageLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
 238 formatPageLink
 239     = proc (baseURI, PageLink page fragment text)
 240     → let uri    = case (page, fragment) of
 241                       (Just  x, Just  y) → mkPageFragmentURI baseURI x y
 242                       (Just  x, Nothing) → mkPageURI baseURI x
 243                       (Nothing, Just  y) → mkFragmentURI y
 244                       _                  → (⊥)
 245           dLabel = fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragment
 246           label  = fromMaybe dLabel text
 247       in
 248         mkAnchor ⤙ (uri, label)
 249
 250 formatImage ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
 251 formatImage = proc (baseURI, Image src alt)
 252             → let uri  = case src of
 253                            Left  u    → u
 254                            Right name → mkObjectURI baseURI name
 255                   href = uriToString id uri ""
 256               in
 257                 ( eelem "img"
 258                   += sattr "src" href
 259                   += ( case alt of
 260                          Just x  → sattr "alt" (T.unpack x)
 261                          Nothing → none
 262                      )
 263                 ) ⤛ ()
 264
 265
 266 formatExternalLink ∷ ArrowXml (⇝) ⇒ InlineElement ⇝ XmlTree
 267 formatExternalLink
 268     = proc (ExternalLink uri text)
 269     → let href  = uriToString id uri ""
 270           label = fromMaybe (T.pack href) text
 271       in
 272         mkAnchor -< (uri, label)
 273
 274 mkAnchor ∷ ArrowXml (⇝) ⇒ (URI, Text) ⇝ XmlTree
 275 mkAnchor = eelem "a"
 276            += attr "href" (arr (flip (uriToString id) "" ∘ fst) ⋙ mkText)
 277            += (arr (T.unpack ∘ snd) ⋙ mkText)
 278
 279 attachXHtmlNS ∷ ArrowXml (⇝) ⇒ XmlTree ⇝ XmlTree
 280 attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
 281     where
 282       attach ∷ QName → QName
 283       attach = setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")