From 4a7dcc2dbe64a59c54003802f1d7f0ae898761e4 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 18 Jun 2023 17:02:51 +0200 Subject: split tags and ehtags, separate listings from hierarchical views --- site.hs | 107 +++++++++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 86 insertions(+), 21 deletions(-) (limited to 'site.hs') diff --git a/site.hs b/site.hs index 6c6e895..21d4fd2 100644 --- a/site.hs +++ b/site.hs @@ -91,7 +91,8 @@ pageTemplates :: Site [FilePath] pageTemplates = do rt <- use redirectTemplate tt <- use tagTemplate - nub . ([rt, tt] ++) <$> + lt <- use listTemplate + nub . ([rt, tt, lt] ++) <$> (gets (^.. pages . traverse) >>= traverse pageTemplate) -- | Compile a single template in a directory @@ -166,7 +167,8 @@ addGlobalMeta (Y.Object m) = do addPageMeta :: PageInfo -> Y.Value -> Site Y.Value addPageMeta pi (Y.Object m) = do htagMeta <- - traverse makeHTagMeta . sort $ pi ^.. pageMeta . key "tags" . values . + traverse (makeHTagMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" . + values . _String . to T.unpack . to splitDirectories @@ -272,18 +274,27 @@ sourceTags = do (^.. 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. -invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])] -invTags x = +-- 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 = foldr () "" @@ -292,21 +303,22 @@ tagPath = foldr () "" tagLink :: [String] -> Site FilePath tagLink = rootUrl . ("tag" ) . tagPath +-- | Fold the hierarchical tag bits to a slashed path. +listPath :: [String] -> FilePath +listPath = foldr () "" + +-- | Make a link to the tag page +listLink :: [String] -> Site FilePath +listLink = rootUrl . ("list" ) . tagPath + -- | Make metadata for printing out a single hierarchical tag (all levels clickable) -makeHTagMeta :: [String] -> Site Y.Value -makeHTagMeta tag = do +makeHTagMeta :: ([String] -> Site FilePath) -> [String] -> Site Y.Value +makeHTagMeta lf tag = do links <- zip (Y.Null : map fromString tag) . map fromString <$> - traverse tagLink (inits tag) + traverse lf (inits tag) pure . Y.array $ map (\(t, p) -> Y.object [("tag", t), ("href", p)]) links --- | Make metadata for printing out a single tag as-is, without levels -makeHTagLinkMeta :: [String] -> Site Y.Value -makeHTagLinkMeta tag = do - link <- tagLink tag - pure $ - Y.object [("href", fromString link), ("tags", Y.array $ map fromString tag)] - -- | Make metadata for printing out a link to a page makePageLinkMeta :: FilePath -> Site Y.Value makePageLinkMeta mount = do @@ -314,20 +326,55 @@ makePageLinkMeta mount = do meta <- use $ pages . to (M.! mount) . pageMeta pure $ Y.object [("href", fromString link), ("meta", meta)] --- | Create the complete metadata structure for the template that renders a given tag page +-- | Create the complete metadata structure for the template that renders a given categorical tag pages makeTagMeta :: [String] -> Site Y.Value makeTagMeta tag = do - taggedPages <- use $ htags . to (M.! tag) + taggedPages <- use $ htags . to (M.!? tag) . to (maybe [] id) subtags <- gets - (^.. htags . to M.keys . each . filtered (not . null) . + (^.. ehtags . to M.keys . each . filtered (not . null) . filtered ((== tag) . init)) - htagMeta <- makeHTagMeta tag + htagMeta <- makeHTagMeta tagLink tag + subtagsMeta <- Y.array <$> traverse makeTagMeta subtags + pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages + link <- tagLink tag + listlink <- listLink tag + addGlobalMeta $ + Y.object + [ ("href", fromString link) + , ("tags", Y.array $ map fromString tag) + , ("htag", htagMeta) + , ("subtags", subtagsMeta) + , ("pages", pagesMeta) + , ("listhref", fromString listlink) + ] + +-- | Make metadata for printing out a single tag as-is, without levels +makeHTagLinkMeta :: [String] -> Site Y.Value +makeHTagLinkMeta tag = do + link <- listLink tag + pure $ + Y.object [("href", fromString link), ("tags", Y.array $ map fromString tag)] + +-- | Create the structure for rendering a complete listing of one hierarchical tag. +makeListMeta :: [String] -> Site Y.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)] + [ ("htag", htagMeta) + , ("subtags", subtagsMeta) + , ("pages", pagesMeta) + , ("taghref", fromString tl) + ] -- | Render a site for a given tag string. renderTag :: [String] -> Site () @@ -344,7 +391,24 @@ renderTag tag = do -- | Render all tag sites. renderTags :: Site () -renderTags = use (htags . to M.keys) >>= traverse_ renderTag +renderTags = use (ehtags . to M.keys) >>= traverse_ renderTag + +-- | 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 -- | Transform one mounted PageInfo to the base search data mkSearchData :: FilePath -> PageInfo -> Site [Y.Value] @@ -388,6 +452,7 @@ main = do use templateDir >>= sourceTemplates use pages >>= traverse (uncurry installPage) . M.assocs renderTags + renderLists renderSearchData io $ putStrLn "OK" whenM (use dumpFinalState) $ get >>= io . print -- cgit v1.2.3