Rakka/Wiki/Interpreter/Outline.hs

   1 module Rakka.Wiki.Interpreter.Outline
   2     ( interpreters
   3     )
   4     where
   5
   6 import           Data.Maybe
   7 import           Rakka.Wiki
   8 import           Rakka.Wiki.Interpreter
   9
  10
  11 interpreters :: [Interpreter]
  12 interpreters = [ outlineInterp ]
  13
  14
  15 outlineInterp :: Interpreter
  16 outlineInterp = BlockCommandInterpreter {
  17                   bciName      = "outline"
  18                 , bciInterpret
  19                     = \ ctx _ ->
  20                       case ctxMainWiki ctx of
  21                         Just tree -> return $ Div [("class", "outline")] [Block $ mkOutline tree]
  22                         Nothing   -> return EmptyBlock
  23                 }
  24
  25
  26 mkOutline :: WikiPage -> BlockElement
  27 mkOutline tree = fst (mkOutline' emptyOutline 1 headings)
  28     where
  29       headings :: [BlockElement]
  30       headings = concatMap collectInBlock tree
  31
  32       collectInBlock :: BlockElement -> [BlockElement]
  33       collectInBlock hd@(Heading _ _)
  34           = [hd]
  35       collectInBlock (Div _ xs)
  36           = concatMap collectInBlock $ catMaybes (map castToBlock xs)
  37       collectInBlock (BlockCmd (BlockCommand _ _ xs))
  38           = concatMap collectInBlock xs
  39       collectInBlock _
  40           = []
  41
  42       castToBlock :: Element -> Maybe BlockElement
  43       castToBlock (Block e) = Just e
  44       castToBlock _         = Nothing
  45
  46
  47 emptyOutline :: BlockElement
  48 emptyOutline = List Bullet []
  49
  50
  51 mkOutline' :: BlockElement -> Int -> [BlockElement] -> (BlockElement, [BlockElement])
  52 mkOutline' soFar _     []     = (soFar, [])
  53 mkOutline' soFar level (x:xs)
  54     = case x of
  55         Heading n text
  56             | n == level
  57                 -- 同じレベルなので soFar に單獨の ListItem を追加して
  58                 -- 續行。
  59                 -> let link = PageLink {
  60                                 linkPage     = Nothing
  61                               , linkFragment = Just text
  62                               , linkText     = Just text
  63                               }
  64                        item = [Inline link]
  65                    in
  66                      mkOutline' (soFar { listItems = listItems soFar ++ [item] }) n xs
  67
  68             | n < level
  69                 -- 低いレベルなのでここで終了。
  70                 -> (soFar, x:xs)
  71
  72             | n > level
  73                 -- 高いレベルなので再帰して ListElement を作り、
  74                 -- それを soFar の最後の ListItem に追加する。
  75                 -> let (nested, ys) = mkOutline' emptyOutline (level + 1) (x:xs)
  76                        itemsSoFar   = listItems soFar
  77
  78                        nonLastItems, lastItem :: [ListItem]
  79                        (nonLastItems, lastItem) = splitAt (length itemsSoFar - 1) itemsSoFar
  80
  81                        lastItem' :: ListItem
  82                        lastItem' = case lastItem of
  83                                      []   -> [Block nested]
  84                                      i:[] -> i ++ [Block nested]
  85                                      _    -> undefined
  86
  87                        soFar' = soFar { listItems = nonLastItems ++ [lastItem'] }
  88                    in
  89                      mkOutline' soFar' level ys
  90         _ -> undefined