Rakka/Wiki/Interpreter/Outline.hs

   1 module Rakka.Wiki.Interpreter.Outline
   2     ( interpreters
   3     )
   4     where
   5
   6 import           Data.Generics
   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 ctxMainTree ctx of
  21                         Just tree -> return $ Div [("class", "outline")] [List $ mkOutline tree]
  22                         Nothing   -> return EmptyBlock
  23                 }
  24
  25
  26 mkOutline :: WikiPage -> ListElement
  27 mkOutline tree
  28     = let headings = listify query tree
  29       in
  30         fst (mkOutline' emptyOutline 1 headings)
  31
  32
  33 query :: Typeable a => a -> Bool
  34 query = mkQ False $ \ x -> case x of
  35                              Heading _ _ -> True
  36                              _           -> False
  37
  38
  39 emptyOutline :: ListElement
  40 emptyOutline = ListElement Bullet []
  41
  42
  43 mkOutline' :: ListElement -> Int -> [BlockElement] -> (ListElement, [BlockElement])
  44 mkOutline' soFar _     []     = (soFar, [])
  45 mkOutline' soFar level (x:xs)
  46     = case x of
  47         Heading n text
  48             | n == level
  49                 -- 同じレベルなので soFar に單獨の ListItem を追加して
  50                 -- 續行。
  51                 -> let link = PageLink {
  52                                 linkPage     = Nothing
  53                               , linkFragment = Just text
  54                               , linkText     = Just text
  55                               }
  56                        item = [Right link]
  57                    in
  58                      mkOutline' (soFar { listItems = listItems soFar ++ [item] }) n xs
  59
  60             | n < level
  61                 -- 低いレベルなのでここで終了。
  62                 -> (soFar, x:xs)
  63
  64             | n > level
  65                 -- 高いレベルなので再帰して ListElement を作り、
  66                 -- それを soFar の最後の ListItem に追加する。
  67                 -> let (nested, ys) = mkOutline' emptyOutline (level + 1) (x:xs)
  68                        itemsSoFar   = listItems soFar
  69
  70                        nonLastItems, lastItem :: [ListItem]
  71                        (nonLastItems, lastItem) = splitAt (length itemsSoFar - 1) itemsSoFar
  72
  73                        lastItem' :: ListItem
  74                        lastItem' = case lastItem of
  75                                      []   -> [Left nested]
  76                                      i:[] -> i ++ [Left nested]
  77
  78                        soFar' = soFar { listItems = nonLastItems ++ [lastItem'] }
  79                    in
  80                      mkOutline' soFar' level ys