Rakka/Wiki/Interpreter/Base/Outline.hs

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