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