Rakka/Wiki/Formatter.hs

   1 module Rakka.Wiki.Formatter
   2     ( formatWikiElements
   3     )
   4     where
   5
   6 import           Control.Arrow
   7 import           Control.Arrow.ArrowList
   8 import           Data.List
   9 import           Data.Maybe
  10 import           Network.URI
  11 import           Rakka.Page
  12 import           Rakka.Wiki
  13 import           Text.XML.HXT.Arrow.XmlArrow
  14 import           Text.XML.HXT.DOM.TypeDefs
  15
  16
  17 -- 複數の Inline を一つに纏める
  18 packParagraph :: [WikiElement] -> [Either BlockElement [InlineElement]]
  19 packParagraph elems = map pack grp
  20     where
  21       grp :: [[WikiElement]]
  22       grp = groupBy criteria elems
  23
  24       criteria :: WikiElement -> WikiElement -> Bool
  25       criteria (Inline _) (Inline _) = True
  26       criteria _ _                   = False
  27
  28       pack :: [WikiElement] -> Either BlockElement [InlineElement]
  29       pack (Block b : []) = Left b
  30       pack xs             = Right [ case x of
  31                                       Inline i -> i | x <- xs ]
  32
  33
  34 formatWikiElements :: (ArrowXml a, ArrowChoice a) => a (URI, [WikiElement]) XmlTree
  35 formatWikiElements
  36     = proc (baseURI, elems)
  37     -> do chunk <- arrL id -< packParagraph elems
  38           case chunk of
  39             Left  x  -> formatBlock     -< x
  40             Right xs -> formatParagraph -< (baseURI, xs)
  41
  42
  43 formatBlock :: (ArrowXml a, ArrowChoice a) => a BlockElement XmlTree
  44 formatBlock
  45     = proc b
  46     -> case b of
  47          Heading level text
  48              -> formatHeading -< (level, text)
  49          EmptyLine
  50              -> none -< ()
  51
  52
  53 formatHeading :: ArrowXml a => a (Int, String) XmlTree
  54 formatHeading
  55     = proc (level, text)
  56     -> selem ("h" ++ show level) [txt text] -<< ()
  57
  58
  59 formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
  60 formatParagraph
  61     = eelem "p"
  62       += ( (arr fst &&& arrL snd)
  63            >>>
  64            formatInline
  65          )
  66
  67
  68 formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
  69 formatInline
  70     = proc (baseURI, i)
  71     -> case i of
  72          Text text
  73              -> mkText -< text
  74
  75          link@(PageLink _ _ _)
  76              -> formatPageLink -< (baseURI, link)
  77
  78
  79 formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
  80 formatPageLink
  81     = proc (baseURI, PageLink page fragment text)
  82     -> let uri    = case (page, fragment) of
  83                       (Just  x, Just  y) -> mkPageFragmentURI baseURI x y
  84                       (Just  x, Nothing) -> mkPageURI baseURI x
  85                       (Nothing, Just  y) -> nullURI { uriFragment = ('#':y) }
  86            href   = uriToString id uri ""
  87            dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
  88            label  = fromMaybe dLabel text
  89        in
  90          ( eelem "a"
  91            += attr "href" (arr fst >>> mkText)
  92            += (arr snd >>> mkText)
  93          ) -< (href, label)