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          LeadingSpaced inlines
  39              -> formatLeadingSpaced -< (baseURI, inlines)
  40
  41          Paragraph inlines
  42              -> formatParagraph -< (baseURI, inlines)
  43
  44
  45 formatHeading :: ArrowXml a => a (Int, String) XmlTree
  46 formatHeading
  47     = proc (level, text)
  48     -> selem ("h" ++ show level) [txt text] -<< ()
  49
  50
  51 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
  52 formatListElement
  53     = proc (baseURI, list)
  54     -> let tag = case listType list of
  55                    Bullet   -> "ul"
  56                    Numbered -> "ol"
  57        in
  58          ( eelem tag
  59            += ( (constA baseURI &&& constL (listItems list))
  60                 >>>
  61                 formatListItem
  62               )
  63          ) -<< ()
  64       where
  65         formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
  66         formatListItem
  67             = proc (baseURI, item)
  68             -> eelem "li"
  69                += ( (arr fst &&& arrL snd)
  70                     >>>
  71                     formatListItem'
  72                   ) -< (baseURI, item)
  73
  74         formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
  75         formatListItem'
  76             = proc (baseURI, x)
  77             -> case x of
  78                  Left  nestedList -> formatListElement -< (baseURI, nestedList)
  79                  Right inline     -> formatInline      -< (baseURI, inline    )
  80
  81
  82 formatLeadingSpaced :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
  83 formatLeadingSpaced
  84     = eelem "pre"
  85       += ( (arr fst &&& arrL snd)
  86            >>>
  87            formatInline
  88          )
  89
  90
  91 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
  92 formatParagraph
  93     = eelem "p"
  94       += ( (arr fst &&& arrL snd)
  95            >>>
  96            formatInline
  97          )
  98
  99
 100 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
 101 formatInline
 102     = proc (baseURI, i)
 103     -> case i of
 104          Text text
 105              -> mkText -< text
 106
 107          link@(PageLink _ _ _)
 108              -> formatPageLink -< (baseURI, link)
 109
 110
 111 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
 112 formatPageLink
 113     = proc (baseURI, PageLink page fragment text)
 114     -> let uri    = case (page, fragment) of
 115                       (Just  x, Just  y) -> mkPageFragmentURI baseURI (fix x) y
 116                       (Just  x, Nothing) -> mkPageURI baseURI (fix x)
 117                       (Nothing, Just  y) -> nullURI { uriFragment = ('#':y) }
 118            fix    = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
 119            href   = uriToString id uri ""
 120            dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
 121            label  = fromMaybe dLabel text
 122        in
 123          ( eelem "a"
 124            += attr "href" (arr fst >>> mkText)
 125            += (arr snd >>> mkText)
 126          ) -< (href, label)