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