slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

tools/pandoc-site: switch to using Pandoc builtin function hierarchicalize

Browse Source
This commit is contained in:
Everett Hildenbrandt 2018-05-19 18:35:34 -06:00 committed by Simon Michael
parent 78e10f7663
commit 1c561c2270
1 changed files with 11 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
tools/pandoc-site.hs
View File

@ -7,18 +7,12 @@ import Text.Pandoc.Class (runPure)
import Text.Pandoc.Builder (text, toList)
import Text.Pandoc.Options (def)
import Text.Pandoc.JSON (toJSONFilter)
import Text.Pandoc.Shared (hierarchicalize, Element(..))
import Data.Either (fromRight)
import Data.List (groupBy)
import Data.Tree (Forest, Tree(Node))
import Data.Function (on)
import Data.Maybe (fromMaybe)
import Data.Text (unpack)
headerLevel :: Block -> Int
headerLevel (Header level _ _) = level
headerLevel _ = error "not a header"
collectHeaders :: Block -> [Block]
collectHeaders header@(Header _ (_, classes, _) _) =
if "notoc" `elem` classes
@ -26,31 +20,28 @@ collectHeaders header@(Header _ (_, classes, _) _) =
else [header]
collectHeaders _ = []
groupByHierarchy :: [Block] -> Forest Block
groupByHierarchy = map (\(x:xs) -> Node x (groupByHierarchy xs)) . groupBy ((<) `on` headerLevel)
markupLink :: Attr -> [Inline] -> Inline
markupLink (headerId, _, headerProperties) headerText
= let linkText = fromMaybe headerText (fmap (toList . text) $ lookup "toc" headerProperties)
in Link nullAttr linkText (("#" ++ headerId), headerId)
markupHeader :: Tree Block -> [Block]
markupHeader n@(Node (Header _ hAttr hText) headers)
markupElement :: Element -> [Block]
markupElement (Sec _ _ hAttr hText headers)
| headers == [] = [link]
| otherwise = [link, markupHeaders headers]
| otherwise = [link, markupElements headers]
where link = Plain [markupLink hAttr hText]
markupHeader n = error $ "'markupHeader' should only be passed a 'Node $ Header'\n"
++ " saw: " ++ show n
markupElement n = error $ "'markupElement' should only be passed a 'Sec'\n"
++ " saw: " ++ show n
markupHeaders :: Forest Block -> Block
markupHeaders = OrderedList (1, Decimal, Period) . map markupHeader
markupElements :: [Element] -> Block
markupElements = OrderedList (1, Decimal, Period) . map markupElement
createTable :: Forest Block -> Block
createTable :: [Element] -> Block
createTable [] = Null
createTable headers
= let navBegin = "<nav id=\"toc\" class=\"right-toc\">"
navEnd = "</nav>"
tocDoc = Pandoc nullMeta [Para [Str "Contents"], markupHeaders headers]
tocDoc = Pandoc nullMeta [Para [Str "Contents"], markupElements headers]
tocString = unpack . fromRight mempty . runPure . writeHtml5String def $ tocDoc
in RawBlock "html" (navBegin ++ "\n" ++ tocString ++ "\n" ++ navEnd)
@ -61,7 +52,7 @@ generateTOC _ x = x
tableOfContents :: Pandoc -> Pandoc
tableOfContents ast
= let headers = query collectHeaders ast
toc = createTable . groupByHierarchy $ headers
toc = createTable . hierarchicalize $ headers
in walk (generateTOC toc) ast
main :: IO ()