source and use humanized tag names

Types.hs

@@ -39,6 +39,8 @@ data SiteState =
     -- | 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)
@@ -131,6 +133,7 @@ siteOptions' = do
       , _redirects = M.empty
       , _htags = M.empty
       , _ehtags = M.empty
+      , _tagNames = M.empty
       , _installs = S.empty
       , _targets = S.empty
       , _templates = M.empty

assets/style.css

@@ -132,6 +132,11 @@ blockquote {
 	text-align: right;
 }
 
+li.sidebox-tag {
+	padding-left: 1em;
+	text-indent: -1em;
+}
+
 /* search form and related stuff */
 
 .search-form-wrap {

cards/codeCheck.md

@@ -13,8 +13,7 @@ redirects:
   - internal/internal/publication/codeCheck
 tags:
   - publication/ppc/code
-  - it/conventions
-  - it/licensing
+  - it/license
 ---
 
 # How-to: Pass a PPC code check

cards/tagnames.yml

@@ -0,0 +1,8 @@
+"": "All"
+publication: "Publication"
+code: "Code"
+about: "About"
+license: "Licensing"
+privacy: "Privacy"
+it: "IT"
+ppc: "Pre-Publication Check"

site.hs

@@ -7,6 +7,7 @@ import Control.Monad ((>=>), 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 qualified Data.ByteString.Lazy as B
 import Data.Digest.Pure.SHA (sha256, showDigest)
@@ -265,6 +266,42 @@ installAssets =
   use assetDir >>=
   (io . getRecursiveContents (pure . const False) >=> traverse_ installAsset)
 
+-- | 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 ++ ": " ++ show 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
@@ -314,10 +351,13 @@ listLink = rootUrl . ("list" </>) . tagPath
 -- | 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 <-
-    zip (Y.Null : map fromString tag) . map fromString <$>
-    traverse lf (inits tag)
-  pure . Y.array $ map (\(t, p) -> Y.object [("tag", t), ("href", p)]) links
+  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
 
 -- | Make metadata for printing out a link to a page
 makePageLinkMeta :: FilePath -> Site Y.Value
@@ -339,10 +379,11 @@ makeTagMeta tag = do
   pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages
   link <- tagLink tag
   listlink <- listLink tag
+  tags <- Y.array . map fromString <$> traverse getTagName tag
   addGlobalMeta $
     Y.object
       [ ("href", fromString link)
-      , ("tags", Y.array $ map fromString tag)
+      , ("tags", tags)
       , ("htag", htagMeta)
       , ("subtags", subtagsMeta)
       , ("pages", pagesMeta)
@@ -353,8 +394,8 @@ makeTagMeta tag = do
 makeHTagLinkMeta :: [String] -> Site Y.Value
 makeHTagLinkMeta tag = do
   link <- listLink tag
-  pure $
-    Y.object [("href", fromString link), ("tags", Y.array $ map fromString tag)]
+  tags <- Y.array . map fromString <$> traverse getTagName tag
+  pure $ Y.object [("href", fromString link), ("tags", tags)]
 
 -- | Create the structure for rendering a complete listing of one hierarchical tag.
 makeListMeta :: [String] -> Site Y.Value
@@ -448,6 +489,7 @@ main = do
   flip runStateT init $ do
     installAssets
     use sourceDirs >>= traverse sourcePages
+    use sourceDirs >>= traverse sourceTagnames
     sourceTags
     use templateDir >>= sourceTemplates
     use pages >>= traverse (uncurry installPage) . M.assocs

templates/header.html

@@ -37,7 +37,7 @@
       <div class="sidebox-values">
         <ul>
         {{#htags}}
-        <li>{{#.}}<a href="{{href}}">{{^tag}}all{{/tag}}{{?tag}} » {{tag}}{{/tag}}{{/.}}</a></li>
+        <li class="sidebox-tag">{{#.}}<a href="{{href}}">{{^tag}}all{{/tag}}{{?tag}} » {{tag}}{{/tag}}{{/.}}</a></li>
         {{/htags}}
         </ul>
       </div>