diff options
Diffstat (limited to 'site.hs')
| -rw-r--r-- | site.hs | 67 |
1 files changed, 55 insertions, 12 deletions
@@ -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 |