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