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

tools/pandoc-site: avoid calling HTML writer directly

Browse Source
This commit is contained in:
Everett Hildenbrandt 2018-05-19 21:13:01 -06:00 committed by Simon Michael
parent 1c561c2270
commit f3d81631e9
1 changed files with 11 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
tools/pandoc-site.hs
View File

@ -2,16 +2,12 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
import Text.Pandoc import Text.Pandoc
import Text.Pandoc.Walk (walk, query) import Text.Pandoc.Walk (query)
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.JSON (toJSONFilter) import Text.Pandoc.JSON (toJSONFilter)
import Text.Pandoc.Shared (hierarchicalize, Element(..)) import Text.Pandoc.Shared (hierarchicalize, Element(..))
import Data.Either (fromRight)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (unpack)
collectHeaders :: Block -> [Block] collectHeaders :: Block -> [Block]
collectHeaders header@(Header _ (_, classes, _) _) = collectHeaders header@(Header _ (_, classes, _) _) =
@ -36,24 +32,22 @@ markupElement n = error $ "'markupElement' should only be passed a 'Sec'\n"
markupElements :: [Element] -> Block markupElements :: [Element] -> Block
markupElements = OrderedList (1, Decimal, Period) . map markupElement markupElements = OrderedList (1, Decimal, Period) . map markupElement
createTable :: [Element] -> Block createTable :: [Element] -> [Block]
createTable [] = Null createTable [] = []
createTable headers createTable headers
= let navBegin = "<nav id=\"toc\" class=\"right-toc\">" = let navBegin = RawBlock "html" "<nav id=\"toc\" class=\"right-toc\">"
navEnd = "</nav>" navEnd = RawBlock "html" "</nav>"
tocDoc = Pandoc nullMeta [Para [Str "Contents"], markupElements headers] in [navBegin, Para [Str "Contents"], markupElements headers, navEnd]
tocString = unpack . fromRight mempty . runPure . writeHtml5String def $ tocDoc
in RawBlock "html" (navBegin ++ "\n" ++ tocString ++ "\n" ++ navEnd)
generateTOC :: Block -> Block -> Block generateTOC :: [Block] -> Block -> [Block]
generateTOC toc (Para [Str "$toc$"]) = toc generateTOC toc (Para [Str "$toc$"]) = toc
generateTOC _ x = x generateTOC _ x = [x]
tableOfContents :: Pandoc -> Pandoc tableOfContents :: Pandoc -> Pandoc
tableOfContents ast tableOfContents (Pandoc meta blks)
= let headers = query collectHeaders ast = let headers = query collectHeaders blks
toc = createTable . hierarchicalize $ headers toc = createTable . hierarchicalize $ headers
in walk (generateTOC toc) ast in Pandoc meta (concatMap (generateTOC toc) blks)
main :: IO () main :: IO ()
main = toJSONFilter tableOfContents main = toJSONFilter tableOfContents