add list-tags command

Makefile

@@ -68,9 +68,11 @@ $(TMPDIR)/index.mk: $(DATADIR)/index.yaml $(YAMLS) $(MAKEPAGES)
 
 ifneq ($(MAKECMDGOALS),clean)
 ifneq ($(MAKECMDGOALS),distclean)
+ifneq ($(MAKECMDGOALS),list-tags)
 -include $(TMPDIR)/index.mk
 endif
 endif
+endif
 
 
 .PHONY: clean distclean
@@ -82,6 +84,11 @@ distclean: clean
 	rm -rf dist-newstyle
 
 
+.PHONY: list-tags
+list-tags: $(MAKEPAGES)
+	$(MAKEPAGES) list-tags -Un
+
+
 HOST        ?= gallery.niss.website
 REMOTE_USER ?= www-data
 IDFILE      ?= ~/.ssh/xyz

make-pages/BuilderQQ.hs

@@ -114,7 +114,7 @@ chunks = reverse . go "" [] . trimEnd where
     = (var, s')
   splitVar _ = error "invalid variable name"
 
-  isIdChar c = isAlphaNum c || c `elem` ['_', '\'']
+  isIdChar c = isAlphaNum c || c `elem` ("_'" :: String)
 
   lit s = (Lit, toStrictText s)
 

make-pages/ListTags.hs

@@ -0,0 +1,54 @@
+module ListTags where
+
+import Info
+
+import Control.Monad
+import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HashSet
+import Data.List (sort)
+import Data.Tuple (swap)
+import Text.Printf (printf)
+
+
+type TagStats = HashMap Text Int
+type PathSet  = HashSet FilePath
+
+data Stats =
+  Stats {
+    tags     :: TagStats,
+    untagged :: PathSet
+  }
+
+instance Semigroup Stats where
+  Stats {tags = t1, untagged = u1} <> Stats {tags = t2, untagged = u2} =
+    Stats {tags = HashMap.unionWith (+) t1 t2, untagged = u1 <> u2}
+
+instance Monoid Stats where
+  mempty = Stats {tags = [], untagged = []}
+
+
+stats1 :: Bool -> FilePath -> Info -> Stats
+stats1 nsfw path (Info {tags, nsfwTags}) =
+  let tags' = if nsfw then tags <> nsfwTags else tags in
+  if null tags' then
+    Stats {tags = [], untagged = [path]}
+  else
+    Stats {tags = HashMap.fromList $ map (, 1) tags', untagged = []}
+
+stats :: Bool -> [(FilePath, Info)] -> Stats
+stats nsfw = foldMap $ uncurry $ stats1 nsfw
+
+run :: Bool -> Bool -> [(FilePath, Info)] -> IO ()
+run nsfw listUntagged infos = do
+  let Stats {tags, untagged} = stats nsfw infos
+  let sortedTags = reverse $ sort $ map swap $ HashMap.toList tags
+  putStrLn "TAGS\n----"
+  for_ sortedTags \(count, path) ->
+    printf "%4d: %s\n" count path
+  when (listUntagged && not (null untagged)) $ do
+    let sortedUntagged = sort $ HashSet.toList untagged
+    putStrLn "\nUNTAGGED FILES\n--------------"
+    for_ sortedUntagged $ printf " - %s\n"

make-pages/Main.hs

@@ -20,6 +20,7 @@ import qualified SinglePage
 import qualified GalleryPage
 import qualified IndexPage
 import qualified RSS
+import qualified ListTags
 
 #ifdef PRETTY_VERBOSE
 import qualified Text.PrettyPrint as PP
@@ -81,14 +82,18 @@ main2 (DependSingle {file, nsfw, output, prefix, buildDir, dataDir}) = do
 main2 (DependGallery {file, output, buildDir, dataDir, tmpDir, infoName}) = do
   IndexInfo {galleries} <- readYAML file
   printV $ "galleries" := galleries
-  infos <- mapM (infoYAML dataDir) =<<
+  infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
-           find always (fileName ==? infoName) dataDir
   printV $ "info files" := infos
   let dependGallery0 g = dependGallery' g infos buildDir dataDir tmpDir
   let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $
         map dependGallery0 galleries
   writeOutput output deps
 
+main2 (ListTags {nsfw, listUntagged, dataDir, infoName}) = do
+  infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
+  ListTags.run nsfw listUntagged infos
+
+
 infoYAML :: FilePath -- ^ data dir
          -> FilePath -- ^ yaml file
          -> IO (FilePath, Info) -- relative filename, contents
@@ -97,6 +102,8 @@ infoYAML dataDir f = do
   info <- readYAML f
   pure (f', info)
 
+findInfos :: FilePath -> FilePath -> IO [FilePath]
+findInfos dataDir infoName = find always (fileName ==? infoName) dataDir
 
 readYAML :: YAML.FromYAML a => FilePath -> IO a
 readYAML file = ByteString.readFile file >>= decode1Must file

make-pages/Options.hs

@@ -54,6 +54,12 @@ data ModeOptions =
       tmpDir   :: FilePath,
       infoName :: FilePath
     }
+  | ListTags {
+      dataDir      :: FilePath,
+      infoName     :: FilePath,
+      nsfw         :: Bool,
+      listUntagged :: Bool
+    }
   deriving Show
 
 
@@ -64,7 +70,8 @@ optionsParser = globalOpts `info` mainInfo where
     short 'v' <> long "verbose" <>
     help "print extra stuff to stderr"
   subcommands = hsubparser $
-    single <> gallery <> index <> rss <> dependSingle <> dependGallery
+    single <> gallery <> index <> rss <> dependSingle <> dependGallery <>
+    listTags
 
   single = command "single" $ singleOpts `info` singleInfo
   singleOpts = SinglePage <$> file <*> dataDir <*> nsfwS <*> output
@@ -136,6 +143,16 @@ optionsParser = globalOpts `info` mainInfo where
     help "temporary directory (default: _tmp)"
   dgInfo = progDesc "generate makefile dependencies for a gallery"
 
+  listTags = command "list-tags" $ ltOpts `info` ltInfo
+  ltOpts = ListTags <$> dataDir <*> infoName <*> nsfwT <*> listUntagged_
+  nsfwT = switch $
+    short 'n' <> long "nsfw" <>
+    help "include nsfw tags"
+  listUntagged_ = switch $
+    short 'U' <> long "untagged" <>
+    help "list files with no tags"
+  ltInfo = progDesc "list all tags used by frequency"
+
   mainInfo = progDesc "static gallery site generator" <> fullDesc
 
 

make-pages/make-pages.cabal

@@ -19,7 +19,8 @@ executable make-pages
     GalleryPage,
     Info,
     IndexPage,
-    Options
+    ListTags,
+    Options,
     Records,
     SinglePage,
     RSS
@@ -35,6 +36,7 @@ executable make-pages
     LambdaCase,
     NamedFieldPuns,
     OverloadedLabels,
+    OverloadedLists,
     OverloadedStrings,
     PatternSynonyms,
     QuasiQuotes,