blog/blog-meta/all-tags.hs

{-# LANGUAGE NamedFieldPuns #-}
module Main (main) where

import qualified Data.ByteString.Lazy as LazyBS
import Data.Foldable
import Data.Function ((&))
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Misc
import qualified System.FilePath.Find as Find
import YAML ((##=), (.!=), (.:))
import qualified YAML
import System.Environment
import qualified Data.Text.IO as Text
import qualified Data.Text as Text


main :: IO ()
main = do
  Opts {dir, yaml, make} <- getOptions
  files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir
  tags  <- traverse getTags files
  LazyBS.writeFile yaml $ makeYAML tags
  Text.writeFile make $ makeMake tags

getTags :: FilePath -> IO (Set Text)
getTags file = do
  yaml <- YAML.readHeader file
  list <- unwrap file $ YAML.parseEither $
    yaml & YAML.withMap "yaml header" \m -> m .: "tags" .!= []
  pure $ Set.fromList list

makeYAML :: [Set Text] -> LazyBS.ByteString
makeYAML tags = "---\n" <> yaml <> "\n...\n" where
  yaml = YAML.encode1 $ YAML.obj
    [("title"    ##= YAML.str "all tags"),
     ("all-tags" ##= collate tags)]

makeMake :: [Set Text] -> Text
makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where
  build = Text.unwords $
    "build:" : ["$(BUILDDIR)/" <> t <> ".html" |
                  t <- ["all-tags", "index"] <> map slug' tags]
  makeRule' opt title file =
    "$(TMPDIR)/" <> file <> ".md : $(POSTS) $(POST_LISTS)\n\
    \\t@echo \"[post-lists] " <> file <> "\"\n\
    \\t$(POST_LISTS) " <> opt <> " --out $@ \\\n\
    \\t  $(POSTSDIR) \"" <> title <> "\""
  allPosts = makeRule' "" "all posts" "index"
  makeRule t =
    makeRule' ("--tag \"" <> name t <> "\"")
              ("posts tagged ‘" <> name t <> "’")
              (slug' t)
  slug' (Tag {slug}) = "tag-" <> slug
  tags = collate tags'

data Tag =
  Tag {
    name :: !Text,
    slug :: !Text,
    count :: !Int
  }
  deriving Show

instance YAML.ToYAML Tag where
  toYAML (Tag {name, slug, count}) = YAML.obj $
    [("name" ##= name), ("slug" ##= slug), ("count" ##= count)]

collate :: [Set Text] -> [Tag]
collate =
  toList . foldl' add1 mempty . foldMap toList
 where
  add1 tags name = Map.alter (add1' tag) (slug tag) tags
    where tag = makeTag name

  add1' new Nothing = Just new
  add1' new (Just old)
    | name new == name old = Just (old {count = succ (count old)})
    | otherwise = error $ "slug collision between " <> show (name old) <>
                          " and " <> show (name new)

  makeTag name = Tag {name, slug = makeSlug name, count = 1}

data Options =
  Opts {
    dir :: !FilePath,
    yaml :: !FilePath,
    make :: !FilePath
  }

getOptions :: IO Options
getOptions = do
    args <- getArgs
    prog <- getProgName
    case args of
      [dir, yaml, make] -> pure $ Opts {dir, yaml, make}
      _ -> fail $
        "usage: " <> prog <> " DIR YAML MAKE ---\n\
        \  get all tags from posts in DIR and put the results in the given files"