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