+module Rakka.Wiki.Interpreter.Base.Outline
+ ( outlineInterp
+ )
+ where
+
+import Data.Generics
+import Rakka.Wiki
+import Rakka.Wiki.Interpreter
+
+
+outlineInterp :: Interpreter
+outlineInterp = BlockCommandInterpreter {
+ bciName = "outline"
+ , bciInterpret
+ = \ ctx _ ->
+ case ctxMainTree ctx of
+ Just tree -> return $ Div [("class", "outline")] [List $ mkOutline tree]
+ Nothing -> return EmptyBlock
+ }
+
+
+mkOutline :: WikiPage -> ListElement
+mkOutline tree
+ = let headings = listify query tree
+ in
+ fst (mkOutline' emptyOutline 1 headings)
+
+
+query :: Typeable a => a -> Bool
+query = mkQ False $ \ x -> case x of
+ Heading _ _ -> True
+ _ -> False
+
+
+emptyOutline :: ListElement
+emptyOutline = ListElement Bullet []
+
+
+mkOutline' :: ListElement -> Int -> [BlockElement] -> (ListElement, [BlockElement])
+mkOutline' soFar _ [] = (soFar, [])
+mkOutline' soFar level (x:xs)
+ = case x of
+ Heading n text
+ | n == level
+ -- 同じレベルなので soFar に單獨の ListItem を追加して
+ -- 續行。
+ -> let link = PageLink {
+ linkPage = Nothing
+ , linkFragment = Just text
+ , linkText = Just text
+ }
+ item = [Right link]
+ in
+ mkOutline' (soFar { listItems = listItems soFar ++ [item] }) n xs
+
+ | n < level
+ -- 低いレベルなのでここで終了。
+ -> (soFar, x:xs)
+
+ | n > level
+ -- 高いレベルなので再帰して ListElement を作り、
+ -- それを soFar の最後の ListItem に追加する。
+ -> let (nested, ys) = mkOutline' emptyOutline (level + 1) (x:xs)
+ itemsSoFar = listItems soFar
+
+ nonLastItems, lastItem :: [ListItem]
+ (nonLastItems, lastItem) = splitAt (length itemsSoFar - 1) itemsSoFar
+
+ lastItem' :: ListItem
+ lastItem' = case lastItem of
+ [] -> [Left nested]
+ i:[] -> i ++ [Left nested]
+
+ soFar' = soFar { listItems = nonLastItems ++ [lastItem'] }
+ in
+ mkOutline' soFar' level ys