Rakka/Wiki/Formatter.hs

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