well stuff

1 files changed, 108 insertions, 0 deletions

diff --git a/oldsite.hs b/oldsite.hs
new file mode 100644
index 0000000..d587e03
--- /dev/null
+++ b/oldsite.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Hakyll
+
+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
+  , joinPath
+  , normalise
+  , splitDirectories
+  )
+
+import Debug.Trace
+
+getMount' :: a -> (String -> a) -> Metadata -> a
+getMount' a b = maybe a b . lookupString "mount"
+
+getMount :: Metadata -> Routes
+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 = getMount' ident fromFilePath md
+      froms =
+        fromMaybe [] $
+        map (fromFilePath . dropTrailingPathSeparator . normalise) <$>
+        lookupStringList "redirects" md
+  pure (to, froms)
+
+makeRedirects :: Identifier -> [Identifier] -> Rules ()
+makeRedirects to froms =
+  create froms $ do
+    route $ indexInDir idRoute
+    compile . makeItem . Redirect . ('/' :) . toFilePath $ to
+
+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 $
+    {- Source the pages -}
+   do
+    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
+
+pageCtx :: Context String
+pageCtx = defaultContext