Rakka/Wiki/Formatter.hs

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