From 693f1944c5e07d68b5e3007c11a64de3a0f191ed Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Sun, 21 May 2023 00:14:22 +0200
Subject: tagges

---
 site.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 55 insertions(+), 12 deletions(-)

(limited to 'site.hs')

diff --git a/site.hs b/site.hs
index 3d77430..174f229 100644
--- a/site.hs
+++ b/site.hs
@@ -2,37 +2,48 @@
 
 import Hakyll
 
-import Control.Monad ((>=>))
+import Control.Monad ((>=>), when)
 import Data.Foldable (traverse_)
+import Data.List (inits, nub)
+import Data.List.Extra (groupSort)
 import Data.Maybe (fromMaybe)
-import System.FilePath ((</>), dropTrailingPathSeparator, normalise)
+import System.FilePath
+  ( (</>)
+  , dropTrailingPathSeparator
+  , joinPath
+  , normalise
+  , splitDirectories
+  )
 
 import Debug.Trace
 
+getMount' :: a -> (String -> a) -> Metadata -> a
+getMount' a b = maybe a b . lookupString "mount"
+
 getMount :: Metadata -> Routes
-getMount = maybe idRoute constRoute . lookupString "mount"
+getMount = getMount' idRoute constRoute
 
 indexInDir :: Routes -> Routes
 indexInDir = flip composeRoutes . customRoute $ (</> "index.html") . toFilePath
 
+makePage :: Rules ()
+makePage = do
+  route $ indexInDir (metadataRoute getMount)
+  compile $
+    pandocCompiler >>= loadAndApplyTemplate "templates/page.html" pageCtx >>=
+    loadAndApplyTemplate "templates/default.html" pageCtx >>=
+    relativizeUrls
+
 extractRedirs :: Identifier -> Rules (Identifier, [Identifier])
 extractRedirs ident = do
   md <- getMetadata ident
-  let to = fromMaybe ident $ fromFilePath <$> lookupString "mount" md
+  let to = getMount' ident fromFilePath md
       froms =
         fromMaybe [] $
         map (fromFilePath . dropTrailingPathSeparator . normalise) <$>
         lookupStringList "redirects" md
   pure (to, froms)
 
-makePage :: Rules ()
-makePage = do
-  route $ indexInDir (metadataRoute getMount)
-  compile $
-    pandocCompiler >>= loadAndApplyTemplate "templates/page.html" pageCtx >>=
-    loadAndApplyTemplate "templates/default.html" pageCtx >>=
-    relativizeUrls
-
 makeRedirects :: Identifier -> [Identifier] -> Rules ()
 makeRedirects to froms =
   create froms $ do
@@ -42,6 +53,36 @@ makeRedirects to froms =
 spawnRedirects :: [Identifier] -> Rules ()
 spawnRedirects = traverse_ (extractRedirs >=> uncurry makeRedirects)
 
+extractHTagLinks :: Identifier -> Rules (Identifier, [[String]])
+extractHTagLinks ident = do
+  md <- getMetadata ident
+  let to = getMount' ident fromFilePath md
+      htags = maybe [] (map splitDirectories) $ lookupStringList "tags" md
+  when (null htags) . fail $ "Uncategorized: " ++ show ident
+  pure (to, htags)
+
+invTags :: [(Identifier, [[String]])] -> [([String], [String])]
+invTags x = map (fmap (map ('/':) . nub . map toFilePath)) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]
+
+makeTag :: [FilePath] -> [String] -> Rules ()
+makeTag htag pages =
+  create [fromFilePath $ joinPath ("tags" : htag)] $ do
+    route (indexInDir idRoute)
+    compile $ do
+      let ctx =
+            mconcat
+              [ constField "title" ("Pages tagged " ++ joinPath htag)
+              , listField "htags" (field "htag" (return . itemBody)) (traverse makeItem htag)
+              , listField "pages" (field "page" (return . itemBody)) (traverse makeItem pages)
+              , defaultContext
+              ]
+      makeItem "" >>= loadAndApplyTemplate "templates/tag.html" ctx >>=
+        loadAndApplyTemplate "templates/default.html" ctx >>=
+        relativizeUrls
+
+spawnTags =
+  traverse extractHTagLinks >=> pure . invTags >=> traverse_ (uncurry makeTag)
+
 main :: IO ()
 main =
   hakyll $
@@ -50,6 +91,8 @@ main =
     match "external/**/*.md" makePage
     {- Source and process the redirects -}
     getMatches "external/**/*.md" >>= spawnRedirects
+    {- Source and process the tags -}
+    getMatches "external/**/*.md" >>= spawnTags
     {- Compile the templates (no routing, cache-only) -}
     match "templates/*" $ compile templateBodyCompiler
 
-- 
cgit v1.2.3