From 0f97b7a64fa3733689b713a2210a4f7b64e069d7 Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <miroslav.kratochvil@uni.lu>
Date: Thu, 15 Jun 2023 15:05:51 +0200
Subject: [PATCH] add local anchors to headers

---
 Utils.hs         | 16 ++++++++++++++++
 assets/style.css | 11 +++++++++++
 site.hs          |  4 +++-
 3 files changed, 30 insertions(+), 1 deletion(-)

diff --git a/Utils.hs b/Utils.hs
index 4828335..c72e080 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Utils where
 
 import Control.Monad.IO.Class
@@ -41,6 +43,20 @@ walkURLs f = Text.Pandoc.Walk.walkM go
       pure $ Image a i (u', t)
     go x = pure x
 
+-- | A pandoc walker for adding the local links to the headings (links are
+-- appended and get a given class)
+addHeadingLinks ::
+     T.Text -> Text.Pandoc.Definition.Pandoc -> Text.Pandoc.Definition.Pandoc
+addHeadingLinks cls = Text.Pandoc.Walk.walk go
+  where
+    go h@(Header lvl attr@(id, _, _) inlines) =
+      Header
+        lvl
+        attr
+        (inlines ++
+         [Link ("", [cls], []) [Str "#"] ("#" <> id, "Link to this section")])
+    go x = x
+
 hasUriScheme :: String -> String -> Bool
 hasUriScheme x = all id . zipWith (==) x . (++ ":")
 
diff --git a/assets/style.css b/assets/style.css
index 410986d..6b89c32 100644
--- a/assets/style.css
+++ b/assets/style.css
@@ -43,6 +43,17 @@ a:hover {
 	text-decoration: underline;
 }
 
+a.header-local-anchor {
+	color: #eee;
+	font-weight: 300;
+	padding-left: 0.5em;
+}
+
+a.header-local-anchor:hover {
+	text-decoration: none;
+	color: #0ad;
+}
+
 body {
 	margin: 0;
 	background: white;
diff --git a/site.hs b/site.hs
index 8626fa3..e634f05 100644
--- a/site.hs
+++ b/site.hs
@@ -178,7 +178,9 @@ installPage mount pi = do
   fixedUrlDoc <-
     walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc
   checkTarget file
-  body <- io . runIOorExplode $ writeHtml5String htmlWriteOpts fixedUrlDoc
+  body <-
+    io . runIOorExplode $ writeHtml5String htmlWriteOpts $
+    addHeadingLinks "header-local-anchor" fixedUrlDoc
   let Y.Object meta' = pi ^. pageMeta
       meta = Y.Object $ KM.insert "body" (Y.String body) meta'
   meta <- addGlobalMeta meta >>= addPageMeta pi