simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-12-26 03:42:25 +03:00
Code Issues Projects Releases Wiki Activity

hakyll-std/TableOfContents: add markupLink to do link rendering using Pandoc

Browse Source
This commit is contained in:
Everett Hildenbrandt 2018-04-27 09:42:52 -06:00 committed by Simon Michael
parent f1a43465b3
commit 00d1944a27
1 changed files with 10 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -13,7 +13,10 @@ 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 Text.Pandoc.Class (runPure)
import Text.Pandoc.Builder (text, toList)
import Text.Pandoc.Options (def)
import Data.Either (fromRight)
import Data.List (groupBy) import Data.List (groupBy)
import Data.Text (unpack) import Data.Text (unpack)
import Data.Tree (Forest, Tree(Node)) import Data.Tree (Forest, Tree(Node))
@ -50,16 +53,16 @@ collectHeaders _ = []
groupByHierarchy :: [Block] -> Forest Block 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)
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 -> H.Html markupHeader :: Tree Block -> H.Html
markupHeader n@(Node (Header _ (ident, _, keyvals) inlines) headers) markupHeader n@(Node (Header _ hAttr hText) 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 = case runPure $ writeHtml5String def (Pandoc nullMeta [(Plain x)]) of where link = fromRight mempty . runPure . writeHtml5 def $ Pandoc nullMeta [Plain [markupLink hAttr hText]]
Left _ -> error $ "Error building header.\n"
++ " saw: " ++ show n
Right txt -> txt
section = fromMaybe (unpack $ render inlines) (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" markupHeader n = error $ "'markupHeader' should only be passed a 'Node $ Header'\n"
++ " saw: " ++ show n ++ " saw: " ++ show n