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           Data.Char
   9 import           Data.List
  10 import           Data.Maybe
  11 import           Network.URI
  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           formatBlock -< (baseURI, block)
  23
  24
  25 formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
  26 formatBlock
  27     = proc (baseURI, block)
  28     -> case block of
  29          Heading level text
  30              -> formatHeading -< (level, text)
  31
  32          HorizontalLine
  33              -> eelem "hr" -< ()
  34
  35          List list
  36              -> formatListElement -< (baseURI, list)
  37
  38          DefinitionList list
  39              -> formatDefinitionList -< (baseURI, list)
  40
  41          Preformatted inlines
  42              -> formatPreformatted -< (baseURI, inlines)
  43
  44          Paragraph inlines
  45              -> formatParagraph -< (baseURI, inlines)
  46
  47          Div attrs contents
  48              -> formatElem "div" -< (baseURI, attrs, contents)
  49     where
  50       formatElem :: (ArrowXml a, ArrowChoice a) =>
  51                     String
  52                  -> a (URI, [Attribute], [BlockElement]) XmlTree
  53       formatElem name
  54           = proc (baseURI, attrs, contents)
  55           -> ( eelem name
  56                += ( arrL (fst . snd)
  57                        >>>
  58                        attrFromPair
  59                   )
  60                += ( (arr fst &&& arrL (snd . snd))
  61                     >>>
  62                     formatBlock
  63                   )
  64              ) -< (baseURI, (attrs, contents))
  65
  66
  67 formatHeading :: ArrowXml a => a (Int, String) XmlTree
  68 formatHeading
  69     = proc (level, text)
  70     -> mkelem ("h" ++ show level)
  71        [ sattr "id" text ]
  72        [ txt text        ] -<< ()
  73
  74
  75 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
  76 formatListElement
  77     = proc (baseURI, list)
  78     -> let tag = case listType list of
  79                    Bullet   -> "ul"
  80                    Numbered -> "ol"
  81        in
  82          ( eelem tag
  83            += ( (constA baseURI &&& constL (listItems list))
  84                 >>>
  85                 formatListItem
  86               )
  87          ) -<< ()
  88       where
  89         formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
  90         formatListItem
  91             = proc (baseURI, item)
  92             -> eelem "li"
  93                += ( (arr fst &&& arrL snd)
  94                     >>>
  95                     formatListItem'
  96                   ) -< (baseURI, item)
  97
  98         formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
  99         formatListItem'
 100             = proc (baseURI, x)
 101             -> case x of
 102                  Left  nestedList -> formatListElement -< (baseURI, nestedList)
 103                  Right inline     -> formatInline      -< (baseURI, inline    )
 104
 105
 106 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
 107 formatDefinitionList
 108     = proc (baseURI, list)
 109     -> ( eelem "dl"
 110          += ( (arr fst &&& arrL snd)
 111               >>>
 112               formatDefinition
 113             )
 114        ) -< (baseURI, list)
 115     where
 116       formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
 117       formatDefinition
 118           = proc (baseURI, def)
 119           -> ( eelem "dt"
 120                += ( (arr fst &&& arrL (defTerm . snd))
 121                     >>>
 122                     formatInline
 123                   )
 124                <+>
 125                eelem "dd"
 126                += ( (arr fst &&& arrL (defDesc . snd))
 127                     >>>
 128                     formatInline
 129                   )
 130              ) -< (baseURI, def)
 131
 132
 133 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
 134 formatPreformatted
 135     = eelem "pre"
 136       += ( (arr fst &&& arrL snd)
 137            >>>
 138            formatInline
 139          )
 140
 141
 142 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
 143 formatParagraph
 144     = eelem "p"
 145       += ( (arr fst &&& arrL snd)
 146            >>>
 147            formatInline
 148          )
 149
 150
 151 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
 152 formatInline
 153     = proc (baseURI, i)
 154     -> case i of
 155          Text text
 156              -> mkText -< text
 157
 158          Italic contents
 159              -> formatElem "i" -< (baseURI, [], contents)
 160
 161          Bold contents
 162              -> formatElem "b" -< (baseURI, [], contents)
 163
 164          link@(PageLink _ _ _)
 165              -> formatPageLink -< (baseURI, link)
 166
 167          LineBreak attrs
 168              -> formatElem "br" -< (baseURI, attrs, [])
 169
 170          Span attrs contents
 171              -> formatElem "span" -< (baseURI, attrs, contents)
 172
 173          Image attrs
 174              -> formatElem "img" -< (baseURI, attrs, [])
 175
 176          Anchor attrs contents
 177              -> formatElem "a" -< (baseURI, attrs, contents)
 178     where
 179       formatElem :: (ArrowXml a, ArrowChoice a) =>
 180                     String
 181                  -> a (URI, [Attribute], [InlineElement]) XmlTree
 182       formatElem name
 183           = proc (baseURI, attrs, contents)
 184           -> ( eelem name
 185                += ( arrL (fst . snd)
 186                        >>>
 187                        attrFromPair
 188                   )
 189                += ( (arr fst &&& arrL (snd . snd))
 190                     >>>
 191                     formatInline
 192                   )
 193              ) -< (baseURI, (attrs, contents))
 194
 195
 196 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
 197 attrFromPair = proc (name, value)
 198              -> attr name (txt value) -<< ()
 199
 200
 201 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
 202 formatPageLink
 203     = proc (baseURI, PageLink page fragment text)
 204     -> let uri    = case (page, fragment) of
 205                       (Just  x, Just  y) -> mkPageFragmentURI baseURI (fix x) y
 206                       (Just  x, Nothing) -> mkPageURI baseURI (fix x)
 207                       (Nothing, Just  y) -> nullURI { uriFragment = ('#':y) }
 208            fix    = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
 209            href   = uriToString id uri ""
 210            dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
 211            label  = fromMaybe dLabel text
 212        in
 213          ( eelem "a"
 214            += attr "href" (arr fst >>> mkText)
 215            += (arr snd >>> mkText)
 216          ) -< (href, label)