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