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

29
tools/pandoc-site.hs
View File

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