From 8fd47d38bb4c3dead49600f93f5345c0b06a6fec Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 18 Jun 2023 19:44:07 +0200 Subject: [PATCH] source and use humanized tag names --- Types.hs | 3 +++ assets/style.css | 5 ++++ cards/codeCheck.md | 3 +-- cards/tagnames.yml | 8 +++++++ site.hs | 56 +++++++++++++++++++++++++++++++++++++------ templates/header.html | 2 +- 6 files changed, 67 insertions(+), 10 deletions(-) create mode 100644 cards/tagnames.yml diff --git a/Types.hs b/Types.hs index beb008d..f4212d8 100644 --- a/Types.hs +++ b/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 diff --git a/assets/style.css b/assets/style.css index c602c6c..a68c227 100644 --- a/assets/style.css +++ b/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 { diff --git a/cards/codeCheck.md b/cards/codeCheck.md index 9dd8352..f7ea680 100644 --- a/cards/codeCheck.md +++ b/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 diff --git a/cards/tagnames.yml b/cards/tagnames.yml new file mode 100644 index 0000000..80a5e7d --- /dev/null +++ b/cards/tagnames.yml @@ -0,0 +1,8 @@ +"": "All" +publication: "Publication" +code: "Code" +about: "About" +license: "Licensing" +privacy: "Privacy" +it: "IT" +ppc: "Pre-Publication Check" diff --git a/site.hs b/site.hs index 21d4fd2..35cb2a2 100644 --- a/site.hs +++ b/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 diff --git a/templates/header.html b/templates/header.html index e535540..d523261 100644 --- a/templates/header.html +++ b/templates/header.html @@ -37,7 +37,7 @@