support tag metadata, make much everything nicer

Tags.hs

@@ -0,0 +1,171 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Tags where
+
+import qualified Data.Aeson.Key as K
+import qualified Data.Aeson.KeyMap as KM
+import Data.Foldable (traverse_)
+import Data.List (inits, nub)
+import Data.List.Extra (groupSort)
+import qualified Data.Map as M
+import Data.String (fromString)
+import qualified Data.Text as T
+import qualified Data.Yaml as Y
+import Lens.Micro
+import Lens.Micro.Aeson
+import Lens.Micro.Mtl
+import System.FilePath ((</>), splitDirectories, takeFileName)
+
+import AesonUtils
+import Types
+import Utils
+
+-- | Split a tag string into a hierarchical tag elements. Corner slashes and
+-- slash groups are removed.
+splitTag :: String -> [String]
+splitTag = dropWhile (all (== '/')) . splitDirectories
+
+-- | Load all tag metadata from a directory.
+sourceTagMeta :: FilePath -> Site ()
+sourceTagMeta fp = do
+  tmf <- use tagMetaFile
+  let go p
+        | takeFileName p == tmf = sourceTagMetaFile (fp </> p)
+        | otherwise = pure ()
+  sourcePaths fp go
+
+-- | Load a given tag metadata file.
+sourceTagMetaFile :: FilePath -> Site ()
+sourceTagMetaFile fp = do
+  yml' <-
+    io $ do
+      putStrLn $ "# <- " ++ fp
+      Y.decodeFileEither fp
+  case yml' of
+    Left err ->
+      error
+        ("Failed to load tag metadata from " ++ fp ++ ": " ++
+         Y.prettyPrintParseException err)
+    Right yml -> traverse_ go (KM.toList yml)
+      where go :: (KM.Key, Y.Value) -> Site ()
+            go (k, v') =
+              let ks = K.toString k
+                  kx = splitTag ks
+                  v
+                    | Y.String t <- v' =
+                      Y.Object $ KM.fromList [("title", Y.String t)]
+                    | Y.Object _ <- v' = v'
+                    | otherwise =
+                      error ("invalid definition of tag " ++ ks ++ " in " ++ fp)
+                  ins (Just ov)
+                    | v == ov = Just ov
+                    | otherwise =
+                      error
+                        ("conflicting tag metadata for tag " ++ ks ++ " in " ++
+                         fp)
+                  ins Nothing = Just v
+               in tagMeta %= M.alter ins kx
+
+-- | Find a good display name for the _last_ hierarchical part of the htag.
+getTagGroupName :: [String] -> Site String
+getTagGroupName htag =
+  handleEmpty . maybe backup id . (>>= title) . (M.!? htag) <$> use tagMeta
+  where
+    title :: Y.Value -> Maybe String
+    title obj = obj ^? key "title" . _String . to T.unpack
+    backup
+      | null htag = ""
+      | null (last htag) = "(unnamed)"
+      | otherwise = last htag
+    handleEmpty x
+      | null x = "(root)"
+      | otherwise = x
+
+-- | Get all tags from the pages of the site and fill in the `htags` and
+-- `ehtags` data.
+sourceTags :: Site ()
+sourceTags = do
+  sgat <-
+    map
+      (second $ map splitTag .
+       (^.. pageMeta . key "tags" . values . _String . to T.unpack)) .
+    M.assocs <$>
+    use pages
+  ehtags .= M.fromList (invExpandTags sgat)
+  htags .= M.fromList (invTags sgat)
+
+-- | Organize a list of pages with hierarchical tags to a list with
+-- hierarchical tags with pages attached; with tags implying parents.
+invExpandTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
+invExpandTags x =
+  map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]
+
+-- | Like `invExpandTags` but without the expansion.
+invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
+invTags x = map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, t <- htl]
+
+-- | Extract the known metadata about a given tag, or give null if there's none.
+htagMeta :: [String] -> Site Y.Value
+htagMeta htag = maybe Y.Null id . (M.!? htag) <$> use tagMeta
+
+-- | Make metadata for printing out a single hierarchical tag
+htagRenderMeta :: ([String] -> Site FilePath) -> [String] -> Site Y.Value
+htagRenderMeta makeLink htag = do
+  let htags = inits htag
+  links <- map fromString <$> traverse makeLink htags
+  names <- map fromString <$> traverse getTagGroupName htags
+  metas <- traverse htagMeta htags
+  pure $
+    Y.object
+      [ ("href", last links)
+      , ("name", last names)
+      , ("meta", last metas)
+      , ( "htag"
+        , Y.array $
+          zipWith3
+            (\l n m -> Y.object [("href", l), ("name", n), ("meta", m)])
+            links
+            names
+            metas)
+      ]
+
+-- | A generic helper for rendering metadata for tagged pages.
+genericTaggedPagesRenderMeta ::
+     (FilePath -> Site Y.Value)
+  -> [String]
+  -> M.Map [String] [FilePath]
+  -> Site Y.Value
+genericTaggedPagesRenderMeta makePageMeta htag tagmap =
+  Y.array <$> traverse makePageMeta (maybe [] id $ tagmap M.!? htag) -- TODO sort page listings here
+
+-- | Render metadata for all precisely tagged pages (not considering the
+-- inheritance of tags following the hierarchy).
+exactlyTaggedPagesRenderMeta ::
+     (FilePath -> Site Y.Value) -> [String] -> Site Y.Value
+exactlyTaggedPagesRenderMeta makePageLinkMeta t =
+  use htags >>= genericTaggedPagesRenderMeta makePageLinkMeta t
+
+-- | Render metadata for all pages tagged by a given hierarchical tags (subtags
+-- included).
+allTaggedPagesRenderMeta ::
+     (FilePath -> Site Y.Value) -> [String] -> Site Y.Value
+allTaggedPagesRenderMeta makePageLinkMeta t =
+  use ehtags >>= genericTaggedPagesRenderMeta makePageLinkMeta t
+
+-- | Like `htagRenderMeta`, but has hooks for extra metadata (e.g., listing of
+-- pages) and for sub-tag rendering. That can be used for recursively building
+-- metadata for whole tag hierarchies.
+htagRenderMetaWithSubtags ::
+     ([String] -> Site FilePath)
+  -> ([String] -> Site Y.Value)
+  -> ([String] -> Site Y.Value)
+  -> [String]
+  -> Site Y.Value
+htagRenderMetaWithSubtags makeLink extraMeta subtagMeta htag = do
+  meta <- htagRenderMeta makeLink htag
+  subtags <-
+    filter ((== htag) . init) . filter (not . null) . M.keys <$> use ehtags
+  {- TODO sort tag listings here -}
+  em <- extraMeta htag
+  subtagMetas <- Y.array . filter (/= Y.Null) <$> traverse subtagMeta subtags
+  pure $ meta `objMerge` Y.object [("subtags", subtagMetas)] `objMerge` em

Types.hs

@@ -20,6 +20,7 @@
 -- | Separated-out main types of the deployment scriptage.
 module Types where
 
+import AesonUtils
 import Control.Monad.Trans.State.Lazy
 import qualified Data.ByteString.UTF8
 import qualified Data.Map as M
@@ -29,7 +30,6 @@ import Lens.Micro.TH
 import Options.Applicative
 import qualified Text.Mustache as Mu
 import qualified Text.Pandoc.Definition
-import AesonUtils
 
 -- | Information about a single deployed page (with metadata etc).
 data PageInfo =
@@ -45,30 +45,20 @@ makeLenses ''PageInfo
 -- | Complete internal state of the deployment process that holds all data
 data SiteState =
   SiteState
-    -- | Map of page mounts to `PageInfo`
-    { _pages :: M.Map FilePath PageInfo
-    -- | Map of redirects (from -> to)
-    , _redirects :: M.Map FilePath FilePath
-    -- | Map of tags, assigning to each tag sequence a list of
-    -- tagged page mounts
-    , _htags :: M.Map [String] [FilePath]
-    -- | Map of tags, assigning to each tag sequence a list of tagged page
-    -- mounts. This one is expanded (tags imply parent categories).
-    , _ehtags :: M.Map [String] [FilePath]
-    -- | Map of "short" tags to expanded human-friendly names
-    , _tagNames :: M.Map String String
-    -- | List of installed files (enables sharing)
-    , _installs :: S.Set (String, FilePath)
-    -- | List of installed files (prevents overwriting)
-    , _targets :: S.Set FilePath
-    -- | Map of Mustache templates organized by template search path (within
-    -- the template directory)
-    , _templates :: M.Map FilePath Mu.Template
+    { _pages :: M.Map FilePath PageInfo -- ^ Map of page mounts to `PageInfo`
+    , _redirects :: M.Map FilePath FilePath -- ^ Map of redirects (from -> to)
+    , _htags :: M.Map [String] [FilePath] -- ^ Map of tags, assigning to each tag sequence a list of tagged page mounts
+    , _ehtags :: M.Map [String] [FilePath] -- ^ Map of tags, assigning to each tag sequence a list of tagged page mounts. This one is expanded (tags imply parent categories).
+    , _tagMeta :: M.Map [String] Y.Value -- ^ Map of tags to expanded human-friendly names
+    , _installs :: S.Set (String, FilePath) -- ^ List of copy-installed files (among other, this enables sharing)
+    , _targets :: S.Set FilePath -- ^ List of files installed to the target site (this allows us to throw an error in case anything would write to the same target twice)
+    , _templates :: M.Map FilePath Mu.Template -- ^ Map of Mustache templates organized by template search path (within the template directory)
     , _outputDir :: FilePath -- ^ Directory for output
     , _searchDataOut :: Maybe FilePath -- ^ File to write the searchable versions of pages to (as JSON)
     , _assetDirs :: [FilePath] -- ^ Directory for output
     , _sourceDirs :: [FilePath] -- ^ Path to page source data
     , _notSourceDirs :: [FilePath] -- ^ Subdirectories of source dirs where pages should not be sourced
+    , _tagMetaFile :: FilePath -- ^ Name of the "tag metadata" files to find in the source directories.
     , _templateDir :: FilePath -- ^ Path to template directory
     , _defaultTemplate :: FilePath -- ^ Name of the default template
     , _redirectTemplate :: FilePath -- ^ Name of the template for redirect pages
@@ -76,8 +66,9 @@ data SiteState =
     , _listTemplate :: FilePath -- ^ Name of the template for listing pages
     , _extraMeta :: Y.Value -- ^ Extra metadata added to rendering of all templates
     , _metadataSuffix :: FilePath -- ^ File suffix to search for a extra metadata (e.g., if the suffix is ".extra", the extra metadata for file "page.md" will be looked for in "page.md.extra"). These are best autogenerated with a script that sources the data from git or so.
+    , _indexFile :: FilePath -- ^ Name of the "index" files to be generated.
     , _urlBase :: FilePath -- ^ "Root route" to prepend to all absolute links.
-    , _appendUrlIndex :: Bool -- ^ Append full @index.html@ to all page URLs
+    , _appendUrlIndex :: Bool -- ^ Append full index filenames to all page URLs
     , _dumpFinalState :: Bool -- ^ Triggers printing out the structure when the processing finishes.
     }
   deriving (Show)
@@ -116,6 +107,11 @@ siteOptions' = do
     long "exclude-source-directory" <>
     help
       "Names of subdirectories of the sources that should never be used for sourcing pages (possibly multiple directory names)"
+  _tagMetaFile <-
+    strOption $
+    long "tag-metadata-file" <>
+    help "Name of files with tag metadata" <>
+    value "tag-metadata.yml" <> showDefault
   _templateDir <-
     strOption $
     long "template-directory" <>
@@ -144,7 +140,8 @@ siteOptions' = do
   _metadataSuffix <-
     strOption $
     long "metadata-suffix" <>
-    help "Suffix for YAML files with base metadata for each markdown page. Metadata from files override the extra metadata specified on commandline, but are overriden by metadata specified directly in the markdown header." <>
+    help
+      "Suffix for YAML files with base metadata for each markdown page. Metadata from files override the extra metadata specified on commandline, but are overridden by metadata specified directly in the markdown header of the pages." <>
     value ".metadata.yml" <> showDefault
   _extraMeta <-
     let processKeyVal :: String -> Y.Value
@@ -153,7 +150,8 @@ siteOptions' = do
             Right v -> v
             Left err ->
               error $
-              "cannot parse YAML in --extra-metadata: " ++ Y.prettyPrintParseException err
+              "cannot parse YAML in --extra-metadata: " ++
+              Y.prettyPrintParseException err
      in fmap (foldl objMerge Y.Null . map processKeyVal) . many . strOption $
         long "extra-metadata" <>
         help
@@ -162,6 +160,10 @@ siteOptions' = do
     strOption $
     long "url-base" <>
     short 'u' <> help "Base absolute URL" <> value "/" <> showDefault
+  _indexFile <-
+    strOption $
+    long "index-filename" <>
+    help "Base absolute URL" <> value "index.html" <> showDefault
   _appendUrlIndex <-
     switch $
     long "append-url-index" <>
@@ -178,7 +180,7 @@ siteOptions' = do
       , _redirects = M.empty
       , _htags = M.empty
       , _ehtags = M.empty
-      , _tagNames = M.empty
+      , _tagMeta = M.empty
       , _installs = S.empty
       , _targets = S.empty
       , _templates = M.empty

Utils.hs

@@ -22,12 +22,13 @@ import Control.Monad.IO.Class
 import Data.List.Extra (stripSuffix)
 import Data.Maybe (isJust)
 import qualified Data.Text as T
+import Lens.Micro.Mtl
 import System.Directory
   ( createDirectoryIfMissing
   , doesDirectoryExist
   , getDirectoryContents
   )
-import System.FilePath ((</>), takeDirectory)
+import System.FilePath ((</>), takeDirectory, splitDirectories)
 import Text.Pandoc.Definition
 import qualified Text.Pandoc.Walk
 import Types
@@ -116,6 +117,23 @@ getRecursiveContents ignore top = go ""
                 else return [rel]
           return $ concat paths
 
+-- | A nice tool interned from Relude.
+foldMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
+foldMapM f xs = foldr step return xs mempty
+  where
+    step x r z = f x >>= \y -> r $! z `mappend` y
+
+-- | Source paths from a source-y directory. The paths that have to be ignored
+-- by config `notSourceDirs` are omitted.
+sourcePaths :: Monoid a => FilePath -> (FilePath -> Site a) -> Site a
+sourcePaths fp process = do
+  notSource <- use notSourceDirs
+  let ignoreDir ds
+        | null ds = False
+        | last ds `elem` notSource = True
+        | otherwise = False
+  io (getRecursiveContents (pure . ignoreDir . splitDirectories) fp) >>= foldMapM process
+
 -- | Given a path to a file, try to make the path writable by making all
 -- directories on the path. (Interned from Hakyll.)
 makeDirectories :: FilePath -> IO ()

reploy.cabal

@@ -10,7 +10,7 @@ license-file:       LICENSE
 
 executable reploy
   main-is:          reploy.hs
-  other-modules:    Types, AesonUtils, Utils, FormatOpts
+  other-modules:    Types, AesonUtils, Utils, Tags, FormatOpts
   build-depends:    base == 4.*
                   , aeson ^>= 2.1
                   , bytestring

reploy.hs

@@ -14,22 +14,21 @@
  - under the License.
  -}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
--- | The main site deployment executable.
+-- | The main site deployment executable module.
 module Main where
 
-import Control.Monad (filterM, join, unless, when)
+import Control.Monad ((>=>), join, unless, when)
 import Control.Monad.Extra (whenM)
 import Control.Monad.Trans.State.Lazy
 import qualified Data.Aeson as AE
 import qualified Data.Aeson.Key as K
 import qualified Data.Aeson.KeyMap as KM
-import Data.Bool (bool)
 import qualified Data.ByteString.Lazy as B
 import Data.Digest.Pure.SHA (sha256, showDigest)
 import Data.Foldable (traverse_)
 import Data.List (inits, nub, sort)
-import Data.List.Extra (groupSort)
 import qualified Data.Map as M
 import qualified Data.Scientific
 import qualified Data.Set as S
@@ -47,9 +46,7 @@ import System.FilePath
   ( (</>)
   , isAbsolute
   , joinPath
-  , splitDirectories
   , splitFileName
-  , splitPath
   , takeDirectory
   , takeFileName
   )
@@ -63,24 +60,19 @@ import Text.Pandoc.Writers.HTML (writeHtml5String)
 import Text.Pandoc.Writers.Shared (toTableOfContents)
 import qualified Text.Parsec.Error
 
+import AesonUtils
 import FormatOpts
+import Tags
 import Types
 import Utils
-import AesonUtils
-
--- | Check if a given path should be sourced or not
-isSourceablePath :: FilePath -> Site Bool
-isSourceablePath fp = do
-  notSource <- use notSourceDirs
-  pure $ (&&) <$> hasSuffix ".md" . last <*> not . any (`elem` notSource) . init $
-    splitDirectories fp
 
 -- | Load the pages from a directory and add them to `pages`.
 sourcePages :: FilePath -> Site ()
-sourcePages fp =
-  (io $ getRecursiveContents (pure . const False) fp) >>=
-  filterM isSourceablePath >>=
-  traverse_ (loadPage . (fp </>))
+sourcePages fp = sourcePaths fp go
+  where
+    go p
+      | hasSuffix ".md" (takeFileName p) = loadPage (fp </> p)
+      | otherwise = pure ()
 
 {- | Extract `PageInfo` about a single page and save it into `pages` in
  - `SiteState`. -}
@@ -148,7 +140,8 @@ sourceTemplates templdir = do
 indexFilename :: FilePath -> Site FilePath
 indexFilename mount = do
   od <- use outputDir
-  pure (od </> mount </> "index.html")
+  idxf <- use indexFile
+  pure (od </> mount </> idxf)
 
 -- | Check that the page was not rendered before, and add it to the rendered set
 checkTarget :: FilePath -> Site ()
@@ -158,22 +151,31 @@ checkTarget fp = do
     then error $ "colliding renders for page: " ++ fp
     else targets %= S.insert fp
 
--- | Prepend the root path to the given link
-rootUrl' :: FilePath -> FilePath -> FilePath
-rootUrl' root = (root </>) . unAbsolute
+-- | Conjure a function that transforms absolute links to pages to full rooted
+-- URLs.
+rootedPageLink' :: Site (FilePath -> FilePath)
+rootedPageLink' = do
+  ub <- use urlBase
+  app <- use appendUrlIndex
+  if app
+    then pure (ub </>)
+    else do
+      idxf <- use indexFile
+      pure $ \x -> ub </> x </> idxf
 
--- | Same as `rootUrl'` but conveniently in the monad
-rootUrl :: FilePath -> Site FilePath
-rootUrl fp = flip rootUrl' fp <$> use urlBase
+-- | Transform a link to page to a full rooted URL
+rootedPageLink :: FilePath -> Site FilePath
+rootedPageLink = (<*>) rootedPageLink' . pure
 
--- | Like `rootUrl'` but also appends @index.html@ for systems that don't have
--- working directory indexes.
-rootPageUrl' :: FilePath -> Bool -> FilePath -> FilePath
-rootPageUrl' root index fp = bool id (</> "index.html") index $ rootUrl' root fp
+-- | Conjure a function that transforms absolute links to files to rooted URLs.
+rootedLink' :: Site (FilePath -> FilePath)
+rootedLink' = do
+  ub <- use urlBase
+  pure (ub </>)
 
--- | Convenient version of `rootPageUrl'`
-rootPageUrl :: FilePath -> Site FilePath
-rootPageUrl fp = rootPageUrl' <$> use urlBase <*> use appendUrlIndex <*> pure fp
+-- | Transform a link to file to a rooted URL.
+rootedLink :: FilePath -> Site FilePath
+rootedLink = (<*>) rootedLink' . pure
 
 -- | Process a single link pointing out from a page.
 processLink :: FilePath -> FilePath -> Site String
@@ -182,32 +184,28 @@ processLink base l =
      "#"
     then pure l
     else if isAbsolute l
-           then rootPageUrl l
-           else installFile (base </> l) >>= rootUrl
-
--- | Get a mount point of the page into the correct location.
--- (Pages are currently mounted just to the root.)
-pageFilename :: FilePath -> Site FilePath
-pageFilename = indexFilename
+           then rootedPageLink l
+           else installFile (base </> l) >>= rootedLink
 
 -- | Like `Mu.substitute` but writes (and eventually should throw) stuff on errors
 checkedSubstitute :: Mu.Template -> MT.Value -> IO T.Text
 checkedSubstitute t v = do
   let (es, txt) = Mu.checkedSubstitute t v
   traverse_ (putStrLn . ("Error: " ++) . show) es
-  --null es `unless` error "template substitution problems"
+  --null es `unless` error "template substitution problems!"
   pure txt
 
 -- | Add global information to page metadata for rendering (at this point just the url base)
 addGlobalMeta :: Y.Value -> Site MT.Value
 addGlobalMeta (Y.Object m) = do
   r <- use urlBase
-  i <- use appendUrlIndex
+  rt <- rootedLink'
+  rtp <- rootedPageLink'
   let l = map (\(k, v) -> (K.toText k, Mu.toMustache v)) $ KM.toList m
   pure . Mu.object $ l ++
     [ ("root", Mu.toMustache $ T.pack r)
-    , ("rawRootUrl", Mu.overText $ T.pack . rootUrl' r . T.unpack)
-    , ("pageLink", Mu.overText $ T.pack . rootPageUrl' r i . T.unpack)
+    , ("rawRootUrl", Mu.overText $ T.pack . rt . T.unpack)
+    , ("pageLink", Mu.overText $ T.pack . rtp . T.unpack)
     ]
 
 -- | Get the expected timestamp file for a given filepath
@@ -222,11 +220,14 @@ addExtraMeta pi m = do
   metaPath <- metadataFile $ pi ^. pagePath
   metaExists <- io $ doesFileExist metaPath
   gem <- use extraMeta
-  objMerge gem <$> if metaExists
+  objMerge gem <$>
+    if metaExists
       then do
         em' <- io $ Y.decodeFileEither metaPath
         case em' of
-        Left pe -> error $ "decoding " ++ metaPath ++ " failed: " ++ Y.prettyPrintParseException pe
+          Left pe ->
+            error $ "decoding " ++ metaPath ++ " failed: " ++
+            Y.prettyPrintParseException pe
           Right em -> pure $ objMerge em m
       else pure m
 
@@ -236,11 +237,11 @@ addExtraMeta pi m = do
 addPageMeta :: PageInfo -> Y.Value -> Site Y.Value
 addPageMeta pi (Y.Object m) = do
   htagMeta <-
-    traverse (makeHTagMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
+    traverse (htagRenderMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
     values .
     _String .
     to T.unpack .
-    to splitDirectories
+    to splitTag
   addExtraMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m
 
 -- | If viable for a page (by config), add the TOC field
@@ -263,7 +264,7 @@ installPage :: FilePath -> PageInfo -> Site ()
 installPage mount pi = do
   tname <- pageTemplate pi
   templ <- use $ templates . to (M.! fromString tname)
-  file <- pageFilename mount
+  file <- indexFilename mount
   fixedUrlDoc <-
     walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc
   checkTarget file
@@ -282,7 +283,7 @@ installPage mount pi = do
 {- | Install a simple redirect handler page. -}
 installRedirect :: FilePath -> FilePath -> Site ()
 installRedirect target' from = do
-  target <- rootPageUrl target'
+  target <- rootedPageLink target'
   tname <- use redirectTemplate
   templ <- use $ templates . to (M.! fromString tname)
   file <- indexFilename from
@@ -340,7 +341,7 @@ installAsset ad fp = do
   let [src, dst] = map (</> fp) [ad, od]
   checkTarget dst
   io $ do
-    putStrLn $ "A -> " ++ src ++ " -> " ++ dst
+    putStrLn $ "A " ++ src ++ " -> " ++ dst
     copy src dst
 
 -- | Copy all files from a given asset directory.
@@ -353,207 +354,96 @@ installAssetDir ad =
 installAssets :: Site ()
 installAssets = use assetDirs >>= traverse_ installAssetDir
 
--- | Load tag names from a directory and add them to `tagNames`.
-sourceTagnames :: FilePath -> Site ()
-sourceTagnames fp =
-  io
-    (map (fp </>) . filter ((== "tagnames.yml") . last . splitPath) <$>
-     getRecursiveContents (pure . const False) fp) >>=
-  traverse_ sourceTagnameFile
-
--- | Single item for `sourceTagnames`
-sourceTagnameFile :: FilePath -> Site ()
-sourceTagnameFile fp = do
-  yml' <-
-    io $ do
-      putStrLn $ "# <- " ++ fp
-      Y.decodeFileEither fp
-  case yml' of
-    Left err ->
-      error $ "Failed to load tagnames from " ++ fp ++ ": " ++ Y.prettyPrintParseException err
-    Right yml -> traverse_ add $ KM.toList (yml :: KM.KeyMap String)
-      where add :: (KM.Key, String) -> Site ()
-            add (k, v) =
-              let go (Just ov) =
-                    if v == ov
-                      then Just ov
-                      else error
-                             ("conflicting tag names for tag " ++ K.toString k)
-                  go Nothing = Just v
-               in tagNames %= M.alter go (K.toString k)
-
--- | Find the humanized name for a tag piece
-getTagName :: String -> Site String
-getTagName t = handleEmpty . maybe t id <$> use (tagNames . to (M.!? t))
-  where
-    handleEmpty "" = "all"
-    handleEmpty x = x
-
--- | Get all tags from the pages of the site.
-sourceTags :: Site ()
-sourceTags = do
-  sgat <-
-    map
-      (second $ map splitDirectories .
-       (^.. pageMeta . key "tags" . values . _String . to T.unpack)) .
-    M.assocs <$>
-    use pages
-  ehtags .= M.fromList (invExpandTags sgat)
-  htags .= M.fromList (invTags sgat)
-
--- | Organize a list of pages with hierarchical tags to a list with
--- hierarchical tags with pages attached; with tags implying parents.
-invExpandTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
-invExpandTags x =
-  map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]
-
--- | Like `invExpandTags` but without the expansion.
-invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
-invTags x = map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, t <- htl]
-
 -- | Get the destination for the tag page.
-tagFilename :: FilePath -> Site FilePath
-tagFilename tag = indexFilename $ "tag" </> tag
-
--- | Get the destination for the tag page.
-listFilename :: FilePath -> Site FilePath
-listFilename tag = indexFilename $ "list" </> tag
-
--- | Fold the hierarchical tag bits to a slashed path.
-tagPath :: [String] -> FilePath
-tagPath = joinPath
+tagFilename :: [String] -> Site FilePath
+tagFilename = indexFilename . joinPath . ("tag" :)
 
 -- | Make a link to the tag page
 tagLink :: [String] -> Site FilePath
-tagLink = rootPageUrl . ("tag" </>) . tagPath
+tagLink = rootedPageLink . joinPath . ("tag" :)
 
--- | Fold the hierarchical tag bits to a slashed path.
-listPath :: [String] -> FilePath
-listPath = joinPath
+-- | Get the destination for the tag page.
+listFilename :: [String] -> Site FilePath
+listFilename = indexFilename . joinPath . ("list" :)
 
 -- | Make a link to the tag page
 listLink :: [String] -> Site FilePath
-listLink = rootPageUrl . ("list" </>) . listPath
-
--- | Make metadata for printing out a single hierarchical tag (all levels clickable)
-makeHTagMeta :: ([String] -> Site FilePath) -> [String] -> Site Y.Value
-makeHTagMeta lf tag = do
-  links <- traverse lf (inits tag)
-  tags <- traverse getTagName ("" : tag)
-  pure . Y.array $
-    zipWith
-      (\t l -> Y.object [("tag", fromString t), ("href", fromString l)])
-      tags
-      links
+listLink = rootedPageLink . joinPath . ("list" :)
 
 -- | Make metadata for printing out a link to a page
-makePageLinkMeta :: FilePath -> Site Y.Value
-makePageLinkMeta mount = do
-  link <- rootPageUrl mount
+makePageLinkRenderMeta :: FilePath -> Site Y.Value
+makePageLinkRenderMeta mount = do
+  link <- rootedPageLink mount
   meta <- use $ pages . to (M.! mount) . pageMeta
-  pure $ Y.object [("href", fromString link), ("meta", meta)]
-
--- | Like `makeTagMeta`, but returns only plain YAML without the functions (in
--- outcome the result is easier to work with using the YAML machinery,
--- allowing this to recurse to itself).
-makeTagMeta' :: [String] -> Site Y.Value
-makeTagMeta' tag = do
-  taggedPages <- use $ htags . to (M.!? tag) . to (maybe [] id)
-  subtags <-
-    gets
-      (^.. ehtags . to M.keys . each . filtered (not . null) .
-           filtered ((== tag) . init))
-  htagMeta <- makeHTagMeta tagLink tag
-  subtagsMeta <- Y.array <$> traverse makeTagMeta' subtags
-  pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages
-  link <- tagLink tag
-  listlink <- listLink tag
-  tags <- Y.array . map fromString <$> traverse getTagName tag
   pure $
     Y.object
-      [ ("href", fromString link)
-      , ("tags", tags)
-      , ("htag", htagMeta)
-      , ("subtags", subtagsMeta)
-      , ("pages", pagesMeta)
-      , ("listhref", fromString listlink)
-      ]
+      [("mount", fromString mount), ("href", fromString link), ("meta", meta)]
 
--- | Create the complete metadata structure for the template that renders a given categorical tag pages
-makeTagMeta :: [String] -> Site MT.Value
-makeTagMeta tag = makeTagMeta' tag >>= addGlobalMeta
+wrapPagesMeta :: Y.Value -> String -> FilePath -> Y.Value
+wrapPagesMeta x linkname link =
+  Y.object [("pages", x), (fromString linkname, fromString link)]
 
--- | Make metadata for printing out a single tag as-is, without levels
-makeHTagLinkMeta :: [String] -> Site Y.Value
-makeHTagLinkMeta tag = do
-  link <- listLink tag
-  tags <- Y.array . map fromString <$> traverse getTagName tag
-  pure $ Y.object [("href", fromString link), ("tags", tags)]
+makeTagRenderMeta :: [String] -> Site Y.Value
+makeTagRenderMeta = htagRenderMetaWithSubtags tagLink extra makeTagRenderMeta
+  where
+    extra htag = do
+      meta <- exactlyTaggedPagesRenderMeta makePageLinkRenderMeta htag
+      wrapPagesMeta meta "listhref" <$> listLink htag
 
--- | Create the structure for rendering a complete listing of one hierarchical tag.
-makeListMeta :: [String] -> Site MT.Value
-makeListMeta tag = do
-  taggedPages <- use $ ehtags . to (M.! tag)
-  subtags <-
-    gets
-      (^.. ehtags . to M.keys . each . filtered (not . null) .
-           filtered ((== tag) . init))
-  htagMeta <- makeHTagMeta listLink tag
-  subtagsMeta <- Y.array <$> traverse makeHTagLinkMeta subtags
-  pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages
-  tl <- tagLink tag
-  addGlobalMeta $
-    Y.object
-      [ ("htag", htagMeta)
-      , ("subtags", subtagsMeta)
-      , ("pages", pagesMeta)
-      , ("taghref", fromString tl)
-      ]
+makeListRenderMeta :: [String] -> Site Y.Value
+makeListRenderMeta =
+  htagRenderMetaWithSubtags
+    listLink
+    pr
+    (htagRenderMetaWithSubtags
+       listLink
+       (const $ pure (Y.object []))
+       (const $ pure Y.Null))
+  where
+    pr htag = do
+      meta <- allTaggedPagesRenderMeta makePageLinkRenderMeta htag
+      wrapPagesMeta meta "taghref" <$> tagLink htag
 
--- | Render a site for a given tag string.
-renderTag :: [String] -> Site ()
-renderTag tag = do
-  tname <- use tagTemplate
-  templ <- use $ templates . to (M.! fromString tname)
-  file <- tagFilename (tagPath tag)
+-- | Parametrized render of a listing-style site.
+renderListing ::
+     String
+  -> ([String] -> Site FilePath)
+  -> ([String] -> Site MT.Value)
+  -> String
+  -> [String]
+  -> Site ()
+renderListing templName fileName makeMeta mark htag = do
+  templ <- (M.! fromString templName) <$> use templates
+  file <- fileName htag
   checkTarget file
-  meta <- makeTagMeta tag
+  meta <- makeMeta htag
   io $ do
-    putStrLn $ "# -> " ++ file
+    putStrLn $ (mark ++ " -> " ++ file)
     makeDirectories file
     checkedSubstitute templ meta >>= TIO.writeFile file
 
--- | Render all tag sites.
-renderTags :: Site ()
-renderTags = use (ehtags . to M.keys) >>= traverse_ renderTag
+renderTags = do
+  lt <- use tagTemplate
+  M.keys <$> use ehtags >>=
+    traverse_
+      (renderListing lt tagFilename (makeTagRenderMeta >=> addGlobalMeta) "#")
 
--- | Render a site for a given tag string.
-renderList :: [String] -> Site ()
-renderList tag = do
-  tname <- use listTemplate
-  templ <- use $ templates . to (M.! fromString tname)
-  file <- listFilename (listPath tag)
-  checkTarget file
-  meta <- makeListMeta tag
-  io $ do
-    putStrLn $ "* -> " ++ file
-    makeDirectories file
-    checkedSubstitute templ meta >>= TIO.writeFile file
-
--- | Render all tag sites.
-renderLists :: Site ()
-renderLists = use (ehtags . to M.keys) >>= traverse_ renderList
+renderLists = do
+  lt <- use listTemplate
+  M.keys <$> use ehtags >>=
+    traverse_
+      (renderListing lt listFilename (makeListRenderMeta >=> addGlobalMeta) "*")
 
 -- | Transform one mounted PageInfo to the base search data
-mkSearchData :: FilePath -> PageInfo -> Site [Y.Value]
-mkSearchData mount pi = do
-  link <- rootPageUrl mount
+makeSearchData :: FilePath -> PageInfo -> Site [Y.Value]
+makeSearchData mount pi = do
+  link <- rootedPageLink mount
   text <- io . runIOorExplode $ writePlain plainWriteOpts (pi ^. pageDoc)
   let title = pi ^? pageMeta . key "title" . _String
   -- TODO: unify retrieval of tags
   let tags =
         sort $ pi ^.. pageMeta . key "tags" . values . _String . to T.unpack
-  tagnames <- traverse (traverse getTagName . splitDirectories) tags
+  tagnames <- traverse (traverse getTagGroupName . inits . splitTag) tags
   let tagarray = Y.array . map (Y.array . map fromString) $ tagnames
   if pi ^? pageMeta . key "search" . _Bool == Just False -- `off` gets parsed as bool
     then pure []
@@ -571,7 +461,7 @@ renderSearchData :: Site ()
 renderSearchData = use searchDataOut >>= traverse_ go
   where
     go out = do
-      ps <- use (pages . to M.assocs) >>= traverse (uncurry mkSearchData)
+      ps <- use (pages . to M.assocs) >>= traverse (uncurry makeSearchData)
       io $ do
         putStrLn $ "S -> " ++ out
         AE.encodeFile out $ Y.array (concat ps)
@@ -582,7 +472,7 @@ main = do
   flip runStateT init $ do
     installAssets
     use sourceDirs >>= traverse sourcePages
-    use sourceDirs >>= traverse sourceTagnames
+    use sourceDirs >>= traverse sourceTagMeta
     sourceTags
     use templateDir >>= sourceTemplates
     use pages >>= traverse (uncurry installPage) . M.assocs

templates/list.html

@@ -4,26 +4,23 @@
 <body>
 {{> header.html}}
 <h1>
-{{?htag}}
   Category listing:
   {{#htag}}
   <a href="{{href}}">
-    {{^tag}}all{{/tag}}
-    {{?tag}}» {{tag}}{{/tag}}
+    {{?name}}» {{name}}{{/name}}
   </a>
   {{/htag}}
-{{/htag}}
 </h1>
 <p>See the <a href="{{taghref}}">hierarchical view of this category</a>.</p>
 {{?subtags}}<h3>Sub-categories</h3>
   <ul>
   {{#subtags}}
-  <li><a href="{{href}}">{{#tags}} » {{.}} {{/tags}}</a></li>
+  <li>{{name}} (<a href="{{href}}">{{#htag}} » {{name}} {{/htag}}</a>)</li>
   {{/subtags}}
   </ul>
 {{/subtags}}
 {{?pages}}
-  <h3>Cards</h3>
+  <h3>Pages</h3>
   <ul>
   {{#pages}}
   <li><a href="{{href}}">{{meta.title}}</a></li>

templates/tag.html

@@ -4,13 +4,12 @@
 <body>
 {{> header.html}}
 <h1>
-Pages in category:
-{{#htag}}
-<a href="{{href}}">
-  {{^tag}}all{{/tag}}
-  {{?tag}}» {{tag}}{{/tag}}
-</a>
-{{/htag}}
+  Pages in category:
+  {{#htag}}
+  <a href="{{href}}">
+    {{?name}}» {{name}}{{/name}}
+  </a>
+  {{/htag}}
 </h1>
 <p>See the <a href="{{listhref}}">complete listing of all pages in this category</a>.</p>
 <ul>
@@ -22,7 +21,8 @@ Pages in category:
 {{?subtags}}
   {{#subtags}}
   <li>
-    <a href="{{href}}">{{#tags}} » {{.}} {{/tags}}</a>
+    {{name}}
+    (<a href="{{href}}">{{#htag}} » {{name}} {{/htag}}</a>)
     <ul>
     {{?pages}}
       {{#pages}}
@@ -32,7 +32,8 @@ Pages in category:
     {{?subtags}}
       {{#subtags}}
       <li>
-        <a href="{{href}}">{{#tags}} » {{.}} {{/tags}}</a>
+        {{name}}
+        (<a href="{{href}}">{{#htag}} » {{name}} {{/htag}}</a>)
         <ul>
         {{?pages}}
           {{#pages}}
@@ -41,7 +42,11 @@ Pages in category:
         {{/pages}}
         {{?subtags}}
           {{#subtags}}
-          <li><a href="{{href}}">{{#tags}} » {{.}} {{/tags}}</a> (click to expand)</li>
+          <li>
+            {{name}}
+            (<a href="{{href}}">{{#htag}} » {{name}} {{/htag}}</a>,
+            click to expand)
+          </li>
           {{/subtags}}
         {{/subtags}}
         </ul>