From bac12543dfe8ceefb3da6ff44fdfa2efa703b548 Mon Sep 17 00:00:00 2001
From: Everett Hildenbrandt <hildenb2@illinois.edu>
Date: Sat, 5 May 2018 23:18:22 -0600
Subject: [PATCH] tools/pandoc-site.hs, Shake.hs: pandoc filter version of
 hakyll-std website builder

---
 Shake.hs             |  6 ++++
 tools/.gitignore     |  1 +
 tools/pandoc-site.hs | 83 ++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 90 insertions(+)
 create mode 100644 tools/pandoc-site.hs

diff --git a/Shake.hs b/Shake.hs
index 41ab2e6d6..a306f710f 100755
--- a/Shake.hs
+++ b/Shake.hs
@@ -69,6 +69,7 @@ usage = unlines
   ]
 
 pandoc = "stack exec -- pandoc" -- pandoc from project's stackage snapshot
+pandocSiteFilter = "tools/pandoc-site"
 hakyllstd = "site/hakyll-std/hakyll-std"
 makeinfo = "makeinfo"
 -- nroff = "nroff"
@@ -305,6 +306,11 @@ main = do
           ,"and try again."
           ])
 
+    pandocSiteFilter %> \out -> do
+        let source = out <.> "hs"
+        need [source]
+        cmd "stack --stack-yaml=stack-ghc8.2.yaml ghc --package pandoc -- -o" out source
+
     -- cleanup
 
     phony "clean" $ do
diff --git a/tools/.gitignore b/tools/.gitignore
index 961a63b6a..e31cb78da 100644
--- a/tools/.gitignore
+++ b/tools/.gitignore
@@ -1 +1,2 @@
 generatetimeclock
+pandoc-site
diff --git a/tools/pandoc-site.hs b/tools/pandoc-site.hs
new file mode 100644
index 000000000..e089a32d6
--- /dev/null
+++ b/tools/pandoc-site.hs
@@ -0,0 +1,83 @@
+-- from https://github.com/blaenk/blaenk.github.io
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+
+import Text.Pandoc
+import Text.Pandoc.Walk (walk, query)
+import Text.Pandoc.Class (runPure)
+import Text.Pandoc.Builder (text, toList)
+import Text.Pandoc.Options (def)
+import Text.Pandoc.JSON (toJSONFilter)
+
+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)
+
+data TOCAlignment = TOCOff | TOCLeft | TOCRight
+
+headerLevel :: Block -> Int
+headerLevel (Header level _ _) = level
+headerLevel _ = error "not a header"
+
+ignoreTOC :: Block -> Block
+ignoreTOC (Header level (ident, classes, params) inlines) =
+  Header level (ident, "notoc" : classes, params) inlines
+ignoreTOC x = x
+
+collectHeaders :: Block -> [Block]
+collectHeaders header@(Header _ (_, classes, _) _) =
+  if "notoc" `elem` classes
+    then []
+    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)
+  | headers == [] = [link]
+  | otherwise     = [link, markupHeaders headers]
+  where link = Plain [markupLink hAttr hText]
+markupHeader n = error $    "'markupHeader' should only be passed a 'Node $ Header'\n"
+                         ++ "    saw: " ++ show n
+
+markupHeaders :: Forest Block -> Block
+markupHeaders = OrderedList (1, Decimal, Period) . map markupHeader
+
+createTable :: TOCAlignment -> Forest Block -> Block
+createTable _ [] = Null
+createTable alignment headers
+    = let alignAttr = case alignment of
+                        TOCRight -> " class=\"right-toc\""
+                        _        -> ""
+          navBegin  = "<nav id=\"toc\"" ++ alignAttr ++ ">"
+          navEnd    = "</nav>"
+          tocDoc    = Pandoc nullMeta [Para [Str "Contents"], markupHeaders headers]
+          tocString = unpack . fromRight mempty . runPure . writeHtml5String def $ tocDoc
+       in RawBlock "html" (navBegin ++ "\n" ++ tocString ++ "\n" ++ navEnd)
+
+generateTOC :: [Block] -> TOCAlignment -> Block -> Block
+generateTOC headers alignment x@(BulletList (( (( Plain ((Str "toc"):_)):_)):_))
+    = createTable alignment . groupByHierarchy $ headers
+generateTOC _ _ x = x
+
+tableOfContents :: TOCAlignment -> Pandoc -> Pandoc
+tableOfContents alignment ast
+    = let headers  = query collectHeaders ast
+          tocGen   = case alignment of
+                        TOCOff -> walk ignoreTOC
+                        _      -> walk (generateTOC headers alignment)
+       in tocGen $ ast
+
+main :: IO ()
+main = toJSONFilter (tableOfContents TOCRight)