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           tree    <- formatBlock -< (baseURI, block)
  23           returnA -< tree
  24
  25
  26 formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
  27 formatElement
  28     = proc (baseURI, elem)
  29     -> case elem of
  30          Block  b -> formatBlock  -< (baseURI, b)
  31          Inline i -> formatInline -< (baseURI, i)
  32
  33
  34 formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
  35 formatBlock
  36     = proc (baseURI, block)
  37     -> case block of
  38          Heading level text
  39              -> formatHeading -< (level, text)
  40
  41          HorizontalLine
  42              -> eelem "hr" -< ()
  43
  44          list@(List _ _)
  45              -> formatListElement -< (baseURI, list)
  46
  47          DefinitionList list
  48              -> formatDefinitionList -< (baseURI, list)
  49
  50          Preformatted inlines
  51              -> formatPreformatted -< (baseURI, inlines)
  52
  53          Paragraph inlines
  54              -> formatParagraph -< (baseURI, inlines)
  55
  56          Div attrs contents
  57              -> formatElem "div" -< (baseURI, attrs, contents)
  58
  59          EmptyBlock
  60              -> none -< ()
  61     where
  62       formatElem :: (ArrowXml a, ArrowChoice a) =>
  63                     String
  64                  -> a (URI, [Attribute], [Element]) XmlTree
  65       formatElem name
  66           = proc (baseURI, attrs, contents)
  67           -> ( eelem name
  68                += ( arrL (fst . snd)
  69                        >>>
  70                        attrFromPair
  71                   )
  72                += ( (arr fst &&& arrL (snd . snd))
  73                     >>>
  74                     formatElement
  75                   )
  76              ) -< (baseURI, (attrs, contents))
  77
  78
  79 formatHeading :: ArrowXml a => a (Int, String) XmlTree
  80 formatHeading
  81     = proc (level, text)
  82     -> mkelem ("h" ++ show level)
  83        [ sattr "id" text ]
  84        [ txt text        ] -<< ()
  85
  86
  87 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
  88 formatListElement
  89     = proc (baseURI, list)
  90     -> let tag = case listType list of
  91                    Bullet   -> "ul"
  92                    Numbered -> "ol"
  93        in
  94          ( eelem tag
  95            += ( (constA baseURI &&& constL (listItems list))
  96                 >>>
  97                 formatListItem
  98               )
  99          ) -<< ()
 100       where
 101         formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
 102         formatListItem
 103             = proc (baseURI, item)
 104             -> eelem "li"
 105                += ( (arr fst &&& arrL snd)
 106                     >>>
 107                     formatElement
 108                   ) -< (baseURI, item)
 109
 110
 111 formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
 112 formatDefinitionList
 113     = proc (baseURI, list)
 114     -> ( eelem "dl"
 115          += ( (arr fst &&& arrL snd)
 116               >>>
 117               formatDefinition
 118             )
 119        ) -< (baseURI, list)
 120     where
 121       formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
 122       formatDefinition
 123           = proc (baseURI, def)
 124           -> ( eelem "dt"
 125                += ( (arr fst &&& arrL (defTerm . snd))
 126                     >>>
 127                     formatInline
 128                   )
 129                <+>
 130                eelem "dd"
 131                += ( (arr fst &&& arrL (defDesc . snd))
 132                     >>>
 133                     formatInline
 134                   )
 135              ) -< (baseURI, def)
 136
 137
 138 formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
 139 formatPreformatted
 140     = eelem "pre"
 141       += ( (arr fst &&& arrL snd)
 142            >>>
 143            formatInline
 144          )
 145
 146
 147 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
 148 formatParagraph
 149     = eelem "p"
 150       += ( (arr fst &&& arrL snd)
 151            >>>
 152            formatInline
 153          )
 154
 155
 156 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
 157 formatInline
 158     = proc (baseURI, i)
 159     -> case i of
 160          Text text
 161              -> mkText -< text
 162
 163          Italic contents
 164              -> formatElem "i" -< (baseURI, [], contents)
 165
 166          Bold contents
 167              -> formatElem "b" -< (baseURI, [], contents)
 168
 169          link@(ObjectLink _ _)
 170              -> formatObjectLink -< (baseURI, link)
 171
 172          link@(PageLink _ _ _)
 173              -> formatPageLink -< (baseURI, link)
 174
 175          link@(ExternalLink _ _)
 176              -> formatExternalLink -< link
 177
 178          LineBreak attrs
 179              -> formatElem "br" -< (baseURI, attrs, [])
 180
 181          Span attrs contents
 182              -> formatElem "span" -< (baseURI, attrs, contents)
 183
 184          img@(Image _ _)
 185              -> formatImage -< (baseURI, img)
 186
 187          Anchor attrs contents
 188              -> formatElem "a" -< (baseURI, attrs, contents)
 189
 190          Input attrs
 191              -> formatElem "input" -< (baseURI, attrs, [])
 192
 193          EmptyInline
 194              -> none -< ()
 195     where
 196       formatElem :: (ArrowXml a, ArrowChoice a) =>
 197                     String
 198                  -> a (URI, [Attribute], [InlineElement]) XmlTree
 199       formatElem name
 200           = proc (baseURI, attrs, contents)
 201           -> ( eelem name
 202                += ( arrL (fst . snd)
 203                        >>>
 204                        attrFromPair
 205                   )
 206                += ( (arr fst &&& arrL (snd . snd))
 207                     >>>
 208                     formatInline
 209                   )
 210              ) -< (baseURI, (attrs, contents))
 211
 212
 213 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
 214 attrFromPair = proc (name, value)
 215              -> attr name (txt value) -<< ()
 216
 217
 218 formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
 219 formatObjectLink
 220     = proc (baseURI, ObjectLink page text)
 221     -> let uri   = mkObjectURI baseURI page
 222            href  = uriToString id uri ""
 223            label = fromMaybe ("{" ++ page ++ "}") text
 224        in
 225          mkAnchor -< (href, label)
 226
 227
 228 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
 229 formatPageLink
 230     = proc (baseURI, PageLink page fragment text)
 231     -> let uri    = case (page, fragment) of
 232                       (Just  x, Just  y) -> mkPageFragmentURI baseURI x y
 233                       (Just  x, Nothing) -> mkPageURI baseURI x
 234                       (Nothing, Just  y) -> mkFragmentURI y
 235            href   = uriToString id uri ""
 236            dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
 237            label  = fromMaybe dLabel text
 238        in
 239          mkAnchor -< (href, label)
 240
 241
 242 formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
 243 formatImage = proc (baseURI, Image src alt)
 244             -> let uri  = mkObjectURI baseURI src
 245                    href = uriToString id uri ""
 246                in
 247                  ( eelem "img"
 248                    += sattr "src" href
 249                    += ( case alt of
 250                           Just x  -> sattr "alt" x
 251                           Nothing -> none
 252                       )
 253                  ) -<< ()
 254
 255
 256 formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
 257 formatExternalLink
 258     = proc (ExternalLink uri text)
 259     -> let href  = uriToString id uri ""
 260            label = fromMaybe href text
 261        in
 262          mkAnchor -< (href, label)
 263
 264
 265 mkAnchor :: (ArrowXml a) => a (String, String) XmlTree
 266 mkAnchor = eelem "a"
 267            += attr "href" (arr fst >>> mkText)
 268            += (arr snd >>> mkText)