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          Paragraph inlines
  33              -> formatParagraph -< (baseURI, inlines)
  34
  35
  36 formatHeading :: ArrowXml a => a (Int, String) XmlTree
  37 formatHeading
  38     = proc (level, text)
  39     -> selem ("h" ++ show level) [txt text] -<< ()
  40
  41
  42 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
  43 formatParagraph
  44     = eelem "p"
  45       += ( (arr fst &&& arrL snd)
  46            >>>
  47            formatInline
  48          )
  49
  50
  51 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
  52 formatInline
  53     = proc (baseURI, i)
  54     -> case i of
  55          Text text
  56              -> mkText -< text
  57
  58          link@(PageLink _ _ _)
  59              -> formatPageLink -< (baseURI, link)
  60
  61
  62 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
  63 formatPageLink
  64     = proc (baseURI, PageLink page fragment text)
  65     -> let uri    = case (page, fragment) of
  66                       (Just  x, Just  y) -> mkPageFragmentURI baseURI (fix x) y
  67                       (Just  x, Nothing) -> mkPageURI baseURI (fix x)
  68                       (Nothing, Just  y) -> nullURI { uriFragment = ('#':y) }
  69            fix    = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
  70            href   = uriToString id uri ""
  71            dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
  72            label  = fromMaybe dLabel text
  73        in
  74          ( eelem "a"
  75            += attr "href" (arr fst >>> mkText)
  76            += (arr snd >>> mkText)
  77          ) -< (href, label)