tagges

6 files changed, 108 insertions, 12 deletions

diff --git a/external/mypage/text.md b/external/mypage/text.md
new file mode 100644
index 0000000..14b321c
--- /dev/null
+++ b/external/mypage/text.md
@@ -0,0 +1,23 @@
+---
+title: My Page
+mount: ext/mypage
+redirects:
+  - mypage
+  - old:mypage
+tags:
+  - yyy
+  - topic1/xxx
+---
+
+# My Page
+
+something something
+
+```
+this that
+```
+
+## Something else
+
+more nonsense
+haha
diff --git a/pagedeploy.cabal b/pagedeploy.cabal
index 50b861f..3417a34 100644
--- a/pagedeploy.cabal
+++ b/pagedeploy.cabal
@@ -8,5 +8,6 @@ executable site
   build-depends:    base == 4.*
                   , hakyll == 4.16.*
                   , filepath
+                  , extra
   ghc-options:      -threaded -rtsopts -with-rtsopts=-N
   default-language: Haskell2010
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
 
diff --git a/templates/default.html b/templates/default.html
new file mode 100644
index 0000000..52c4b44
--- /dev/null
+++ b/templates/default.html
@@ -0,0 +1,12 @@
+<!doctype html>
+<html lang="en">
+    <head>
+        <meta charset="utf-8">
+        <meta name="viewport" content="width=device-width, initial-scale=1">
+        <title>My Stuffs - $title$</title>
+    </head>
+    <body>
+        <h1>$title$</h1>
+        $body$
+    </body>
+</html>
diff --git a/templates/page.html b/templates/page.html
new file mode 100644
index 0000000..38b50ce
--- /dev/null
+++ b/templates/page.html
@@ -0,0 +1,3 @@
+<section>
+  $body$
+</section>
diff --git a/templates/tag.html b/templates/tag.html
new file mode 100644
index 0000000..6f329cd
--- /dev/null
+++ b/templates/tag.html
@@ -0,0 +1,14 @@
+<section>
+  <h2>Tag</h2>
+  <ul>
+  $for(htags)$
+    <li>$htag$</li>
+  $endfor$
+  </ul>
+  <h2>Pages</h2>
+  <ul>
+  $for(pages)$
+    <li><a href="$page$">$page$</a></li>
+  $endfor$
+  </ul>
+</section>