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

hakyll-std/TableOfContents: pandoc is monadified, must use runPure and fix error messages/imports

Browse Source
This commit is contained in:
Everett Hildenbrandt 2018-04-21 11:29:39 -06:00 committed by Simon Michael
parent 5fc59811a0
commit aedca6dab1
1 changed files with 11 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
site/hakyll-std/TableOfContents.hs
View File

@ -12,6 +12,7 @@ module TableOfContents (
import Text.Pandoc import Text.Pandoc
import Text.Pandoc.Walk (walk, query) import Text.Pandoc.Walk (walk, query)
import Text.Pandoc.Class (runPure)
import Data.List (groupBy) import Data.List (groupBy)
import Data.Text (unpack) import Data.Text (unpack)
@ -21,6 +22,7 @@ import Data.Monoid ((<>), mconcat)
#endif #endif
import Data.Function (on) import Data.Function (on)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (unpack)
import Text.Blaze.Html (preEscapedToHtml, (!)) import Text.Blaze.Html (preEscapedToHtml, (!))
import Text.Blaze.Html.Renderer.String (renderHtml) import Text.Blaze.Html.Renderer.String (renderHtml)
@ -51,13 +53,17 @@ groupByHierarchy :: [Block] -> Forest Block
groupByHierarchy = map (\(x:xs) -> Node x (groupByHierarchy xs)) . groupBy ((<) `on` headerLevel) groupByHierarchy = map (\(x:xs) -> Node x (groupByHierarchy xs)) . groupBy ((<) `on` headerLevel)
markupHeader :: Tree Block -> H.Html markupHeader :: Tree Block -> H.Html
markupHeader (Node (Header _ (ident, _, keyvals) inline) headers) markupHeader n@(Node (Header _ (ident, _, keyvals) inline) headers)
| headers == [] = H.li $ link | headers == [] = H.li $ link
| otherwise = H.li $ link <> (H.ol $ markupHeaders headers) | otherwise = H.li $ link <> (H.ol $ markupHeaders headers)
where render x = writeHtml5String def (Pandoc nullMeta [(Plain x)]) where render x = case runPure $ writeHtml5String def (Pandoc nullMeta [(Plain x)]) of
section = fromMaybe (render inline) (lookup "toc" keyvals) Left _ -> error $ "Error building header.\n"
link = H.a ! A.href (H.toValue $ "#" ++ ident) $ preEscapedToHtml $ unpack section ++ " saw: " ++ show n
markupHeader _ = error "what" Right txt -> txt
section = fromMaybe (unpack $ render inline) (lookup "toc" keyvals)
link = H.a ! A.href (H.toValue $ "#" ++ ident) $ preEscapedToHtml section
markupHeader n = error $ "'markupHeader' should only be passed a 'Node $ Header'\n"
++ " saw: " ++ show n
markupHeaders :: Forest Block -> H.Html markupHeaders :: Forest Block -> H.Html
markupHeaders = mconcat . map markupHeader markupHeaders = mconcat . map markupHeader