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