split tags and ehtags, separate listings from hierarchical views

1 files changed, 86 insertions, 21 deletions

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