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