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