make less inefficient

- do all filters in one go
- do all post lists in one run of the program
- only write files if they are changed
  (so make repeats less work)
- simplify pandoc command for meta pages
  (this might not actually make a difference)

Makefile

@@ -25,12 +25,10 @@ OUTPUT = $(OUTPUTPOSTS) $(OUTPUTSTYLE)
 
 ALL_TAGS = $(TMPDIR)/all-tags
 POST_LISTS = $(TMPDIR)/post-lists
-NICE_DATE = $(TMPDIR)/nice-date
-SLUG_TAGS = $(TMPDIR)/slug-tags
-FIXFIGS = $(TMPDIR)/fix-figures
+COMBO_FILTER = $(TMPDIR)/combo-filter
 EXECS = \
   $(LAANTAS_SCRIPT) \
-  $(ALL_TAGS) $(POST_LISTS) $(NICE_DATE) $(SLUG_TAGS) $(FIXFIGS)
+  $(ALL_TAGS) $(POST_LISTS) $(COMBO_FILTER)
 
 CABAL_FLAGS ?= -O
 
@@ -44,10 +42,6 @@ all: build
 .PHONY: build
 build: $(EXECS) $(OUTPUT)
 
-
-LANGFILTER != cabal list-bin langfilter
-LAANTAS_SCRIPT != cabal list-bin laantas-script
-
 POSTDEPS = \
   $(TEMPLATEDIR)/* \
   $(SYNTAXFILES) acm.csl quox.bib
@@ -59,7 +53,7 @@ build: $(BUILDDIR)/all-tags.html
 include $(TMPDIR)/tags.mk
 
 $(BUILDDIR)/%.html: $(POSTSDIR)/%.md $(POSTDEPS) ; $(call pandoc,post.html)
-$(BUILDDIR)/%.html: $(TMPDIR)/%.md   $(POSTDEPS) ; $(call pandoc,meta.html)
+$(BUILDDIR)/%.html: $(TMPDIR)/%.md   $(POSTDEPS) ; $(call pandoc-simple,meta.html)
 
 $(BUILDDIR)/rss.xml: $(TMPDIR)/index.md $(POSTDEPS)
 	$(call pandoc,rss.xml,--metadata-file rss.yaml --write html)
@@ -73,18 +67,23 @@ define pandoc
   @echo "[pandoc] $(subst $(TMPDIR)/,,$(subst $(BUILDDIR)/,,$@))"
   mkdir -p $(dir $@)
   mkdir -p $(basename $@)
-  LAANTAS_SCRIPT="$(LAANTAS_SCRIPT)" LANG_COLOR="currentcolor" \
-    DIRNAME="$(basename $@)" \
-    FILENAME="$@" \
+  LANG_COLOR="currentcolor" \
     pandoc -s --toc --toc-depth=2 --template $(TEMPLATEDIR)/$(1) -o $@ $< \
       -f markdown+emoji $(2) \
       -M filename=$(subst $(BUILDDIR)/,,$@) --metadata-file=rss.yaml \
-      $(SYNTAXFLAGS) \
-      --filter $(LANGFILTER) --filter $(NICE_DATE) --filter $(SLUG_TAGS) \
-      --filter $(FIXFIGS) \
+      $(SYNTAXFLAGS) --filter $(COMBO_FILTER) \
       --mathml --citeproc --csl=apa-eu.csl
 endef
 
+# $(1): template file
+define pandoc-simple
+  @echo "[pandoc] $(subst $(TMPDIR)/,,$(subst $(BUILDDIR)/,,$@))"
+  mkdir -p $(dir $@)
+  mkdir -p $(basename $@)
+  pandoc -s --template $(TEMPLATEDIR)/$(1) -o $@ $< \
+    -M filename=$(subst $(BUILDDIR)/,,$@) --metadata-file=rss.yaml
+endef
+
 
 $(BUILDDIR)/%: $(POSTSDIR)/% ; $(call copy)
 $(BUILDDIR)/%: $(TMPDIR)/%   ; $(call copy)
@@ -99,11 +98,9 @@ endef
 
 BLOG_META_DEPS != find blog-meta -type f
 
-$(ALL_TAGS):   $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:)
-$(POST_LISTS): $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:)
-$(NICE_DATE):  $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:)
-$(SLUG_TAGS):  $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:)
-$(FIXFIGS):    $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:)
+$(ALL_TAGS):     $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:)
+$(POST_LISTS):   $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:)
+$(COMBO_FILTER): $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:)
 
 define cabal-exe
   @echo "[build] $(notdir $@)"

blog-meta/all-tags.hs

@@ -1,20 +1,19 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Main (main) where
 
-import qualified Data.ByteString.Lazy as LazyBS
+import Data.ByteString.Lazy qualified as LazyBS
 import Data.Foldable
 import Data.Function ((&))
-import qualified Data.Map.Strict as Map
+import Data.Map.Strict qualified as Map
 import Data.Set (Set)
-import qualified Data.Set as Set
+import Data.Set qualified as Set
 import Data.Text (Text)
+import Data.Text qualified as 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
+import System.FilePath.Find qualified as Find
+import YAML ((##=), (.!=), (.:))
+import YAML qualified
 
 
 -- |
@@ -33,8 +32,8 @@ 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
+  writeIfDifferentBS yaml $ makeYAML tags
+  writeIfDifferentT  make $ makeMake tags
 
 -- | reads tags from a single file
 getTags :: FilePath -> IO (Set Text)
@@ -90,21 +89,18 @@ makeYAML tags = "---\n" <> yaml <> "\n...\n" where
 --   @find@ returns)
 -- * @POST_LISTS@ (path to the @post-lists@ executable)
 makeMake :: [Set Text] -> Text
-makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where
+makeMake tags' = Text.unlines $ [build, postLists] where
   build = Text.unwords $
     "build:" : ["$(BUILDDIR)/" <> t <> ".html" | t <- 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)
+  postLists =
+    Text.unwords (target' "index" : map target tags)
+        <> " &: $(POSTS) $(POST_LISTS)\n\
+    \\t@echo \"[post-lists] <tag files>\"\n\
+    \\t$(POST_LISTS) $(POSTSDIR) $(TMPDIR)"
   slug' (Tag {slug}) = "tag-" <> slug
   tags = collate tags'
+  target' name = "$(TMPDIR)/" <> name <> ".md"
+  target = target' . slug'
 
 -- | info about a tag
 data Tag =

blog-meta/blog-meta.cabal

@@ -18,11 +18,13 @@ common deps
   build-depends:
     base >= 4.14.2.0 && < 4.21,
     mtl,
+    transformers,
     HsYAML ^>= 0.2.1.0,
     bytestring ^>= 0.11.4.0,
     containers ^>= 0.6.4.1,
     filemanip,
     filepath ^>= 1.4.2.1,
+    directory ^>= 1.3.8.3,
     pandoc-types ^>= 1.23,
     text >= 2 && < 2.2,
     time ^>= 1.9.3
@@ -31,7 +33,7 @@ common deps
   ghc-options: -Wall
 
 common exe
-  build-depends: blog-meta
+  build-depends: blog-meta, langfilter
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
 
 library
@@ -39,7 +41,10 @@ library
   hs-source-dirs: lib
   exposed-modules:
     YAML,
-    Misc
+    Misc,
+    SlugTags,
+    FixFigures,
+    NiceDate
 
 executable post-lists
   import: deps, exe
@@ -51,17 +56,7 @@ executable all-tags
   hs-source-dirs: .
   main-is: all-tags.hs
 
-executable nice-date
+executable combo-filter
   import: deps, exe
   hs-source-dirs: .
-  main-is: nice-date.hs
-
-executable slug-tags
-  import: deps, exe
-  hs-source-dirs: .
-  main-is: slug-tags.hs
-
-executable fix-figures
-  import: deps, exe
-  hs-source-dirs: .
-  main-is: fix-figures.hs
+  main-is: combo-filter.hs

blog-meta/combo-filter.hs

@@ -0,0 +1,12 @@
+import FixFigures
+import LangFilter
+import NiceDate
+import SlugTags
+import Text.Pandoc.JSON
+import Text.Pandoc.Walk
+
+main :: IO ()
+main = toJSONFilter $
+  langFilter "currentcolor" .
+  walk (niceDate . slugTags) .
+  walk fixFigures

blog-meta/fix-figures.hs

@@ -1,15 +0,0 @@
-import Text.Pandoc.JSON
-
-main :: IO ()
-main = toJSONFilter $ expandable . shaped where
-  expandable (Figure attr@(_, cs, _) cap [Plain img@[Image _ _ t]])
-    | "expandable" `elem` cs = Figure attr cap $ [Plain [Link blank img t]]
-  expandable b = b
-
-  blank = ("", [], [("target", "_blank")])
-
-  shaped (Figure (i, cs, as) cap [Plain img@[Image _ _ (url, _)]])
-    | "shaped" `elem` cs =
-        let shape = "shape-outside: url(" <> url <> ")" in
-        Figure (i, cs, ("style", shape) : as) cap [Plain img]
-  shaped b = b

blog-meta/lib/FixFigures.hs

@@ -0,0 +1,21 @@
+module FixFigures (fixFigures, expandable, shaped) where
+
+import Text.Pandoc.Definition
+
+fixFigures :: Block -> Block
+fixFigures = expandable . shaped
+
+expandable :: Block -> Block
+expandable (Figure attr@(_, cs, _) cap [Plain img@[Image _ _ t]])
+  | "expandable" `elem` cs = Figure attr cap $ [Plain [Link blank img t]]
+expandable b = b
+
+shaped :: Block -> Block
+shaped (Figure (i, cs, as) cap [Plain img@[Image _ _ (url, _)]])
+  | "shaped" `elem` cs =
+      let shape = "shape-outside: url(" <> url <> ")" in
+      Figure (i, cs, ("style", shape) : as) cap [Plain img]
+shaped b = b
+
+blank :: Attr
+blank = ("", [], [("target", "_blank")])

blog-meta/lib/Misc.hs

@@ -1,12 +1,16 @@
 module Misc where
 
-import qualified System.Console.GetOpt as GetOpt
+import Control.Monad
+import Data.ByteString.Lazy qualified as LazyBS
+import Data.Char (isAlphaNum, isAscii, toLower)
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Text.IO qualified as Text
+import Data.Time
+import System.Console.GetOpt qualified as GetOpt
+import System.Directory qualified as Dir
 import System.Environment
 import System.Exit
-import Data.Text (Text)
-import Data.Time
-import qualified Data.Text as Text
-import Data.Char (isAlphaNum, isAscii, toLower)
 import Text.Pandoc.Definition
 
 -- | exception on 'Left'
@@ -97,3 +101,15 @@ rssDate (ID d) =
 showDate :: IsoDate -> Text
 showDate (ID d) =
   Text.pack $ toLower <$> formatTime defaultTimeLocale "%a %-d %B %Y" d
+
+writeIfDifferentBS :: FilePath -> LazyBS.ByteString -> IO ()
+writeIfDifferentBS fn content = do
+  exists <- Dir.doesFileExist fn
+  old <- if exists then Just <$> LazyBS.readFile fn else pure Nothing
+  unless (old == Just content) $ LazyBS.writeFile fn content
+
+writeIfDifferentT :: FilePath -> Text -> IO ()
+writeIfDifferentT fn content = do
+  exists <- Dir.doesFileExist fn
+  old <- if exists then Just <$> Text.readFile fn else pure Nothing
+  unless (old == Just content) $ Text.writeFile fn content

blog-meta/lib/NiceDate.hs

@@ -0,0 +1,27 @@
+module NiceDate (niceDate) where
+
+import Text.Pandoc.Definition
+import qualified Data.Map.Strict as Map
+import Misc
+import Control.Monad.Writer
+import Data.Monoid
+
+niceDate :: Meta -> Meta
+niceDate (Meta m) =
+  let (res', mdate) = run $ Map.alterF reformat' "date" m
+      res           = maybe m (\d -> Map.insert "date-iso" d res') mdate in
+  Meta res
+
+type T = Writer (Alt Maybe MetaValue)
+
+run :: T a -> (a, Maybe MetaValue)
+run = fmap getAlt . runWriter
+
+reformat' :: Maybe MetaValue -> T (Maybe MetaValue)
+reformat' Nothing = pure Nothing
+reformat' (Just d) = do tell $ pure d; pure $ reformat d
+
+reformat :: MetaValue -> Maybe MetaValue
+reformat (toText -> Just txt) =
+  MetaString . showDate <$> parseIsoDate txt
+reformat _ = Nothing

blog-meta/lib/SlugTags.hs

@@ -0,0 +1,20 @@
+module SlugTags (slugTags) where
+
+import Text.Pandoc.Definition
+import qualified Data.Map.Strict as Map
+-- import Text.Pandoc.JSON
+import Data.Text (Text)
+import Misc
+
+slugTags :: Meta -> Meta
+slugTags (Meta m) = Meta $ Map.adjust addSlugs "tags" m
+
+-- | if @tags@ exists and is a list of strings, add the slugs. if it exists and
+-- is something else, explode
+addSlugs :: MetaValue -> MetaValue
+addSlugs (toTextList -> Just tags) = MetaList $ map addSlug1 tags
+addSlugs t = error $ "'tags' is\n" <> show t <> "\nwanted a list of strings"
+
+addSlug1 :: Text -> MetaValue
+addSlug1 tag = MetaMap $ Map.fromList
+  [("name", MetaString tag), ("slug", MetaString $ makeSlug tag)]

blog-meta/nice-date.hs

@@ -1,27 +0,0 @@
-import Text.Pandoc.Definition
-import qualified Data.Map.Strict as Map
-import Text.Pandoc.JSON
-import Misc
-import Control.Monad.Writer
-import Data.Monoid
-
--- | replaces the @date@ field, which starts in YYYY-MM-DD format, with
--- something prettier
-main :: IO ()
-main = toJSONFilter \(Meta m) -> do
-  (res', mdate) <- run $ Map.alterF reformat' "date" m
-  let res = maybe m (\d -> Map.insert "date-iso" d res') mdate
-  pure $ Meta res
-
-type T = WriterT (Alt Maybe MetaValue) IO
-
-run :: T a -> IO (a, Maybe MetaValue)
-run = fmap (fmap getAlt) . runWriterT
-
-reformat' :: Maybe MetaValue -> T (Maybe MetaValue)
-reformat' Nothing = pure Nothing
-reformat' (Just d) = do tell $ pure d; Just <$> reformat d
-
-reformat :: MetaValue -> T MetaValue
-reformat (toText -> Just txt) = MetaString . showDate <$> parseIsoDate txt
-reformat d = fail $ "date is\n" <> show d <> "\nwanted a string"

blog-meta/post-lists.hs

@@ -1,15 +1,21 @@
-import qualified Data.ByteString.Lazy as LazyBS
+import Data.ByteString.Lazy qualified as LazyBS
 import Data.Function ((&))
 import Data.List (sortBy)
 import Data.Ord (comparing)
 import Data.Text (Text)
-import qualified Data.Text as Text
+import Data.Text qualified as Text
 import Misc
-import qualified YAML
+import System.FilePath qualified as Path
+import System.FilePath.Find qualified as Find
 import YAML ((.:), (.:?), (.!=), (##=))
-import qualified System.Console.GetOpt as GetOpt
-import qualified System.FilePath.Find as Find
-import qualified System.FilePath as Path
+import YAML qualified
+import System.Environment
+import System.IO
+import System.Exit
+import Data.Set (Set)
+import qualified Data.Set as Set
+import System.FilePath
+import Data.Foldable
 
 -- | generates a yaml list for a list of posts; either for a given tag, or all
 -- posts. the posts are in chronological order, newest first.
@@ -40,18 +46,29 @@ import qualified System.FilePath as Path
 main :: IO ()
 main = do
   Opts {..} <- getOptions
-  files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir
-  infos <- filter (checkTag tag) <$> traverse (getInfo dir) files
+  files <- Find.findL True (pure True) (Find.extension Find.==? ".md") indir
+  infos <- traverse (getInfo indir) files
+  for_ (allTags infos) \tag -> do
+    let title    = "pages tagged ‘" <> tag <> "’"
+    let basename = "tag-" <> Text.unpack (makeSlug tag) <.> "md"
+    let tagged   = filter (checkTag $ Just tag) infos
+    makeTagInfo tagged title basename outdir
+  makeTagInfo infos "all posts" "index.md" outdir
+
+makeTagInfo :: [PostInfo] -> Text -> String -> FilePath -> IO ()
+makeTagInfo infos title basename outdir = do
   let content = makeContent title infos
-  case out of
-    Nothing -> LazyBS.putStr content
-    Just fn -> LazyBS.writeFile fn content
+  let filename = outdir </> basename
+  writeIfDifferentBS filename content
 
 makeContent :: Text -> [PostInfo] -> LazyBS.ByteString
 makeContent title is' = "---\n" <> YAML.encode1 val <> "...\n" where
   is = sortBy (flip $ comparing date) is'
   val = YAML.obj [("title" ##= title), ("posts" ##= is)]
 
+allTags :: Foldable t => t PostInfo -> Set Text
+allTags = foldMap (Set.fromList . tags)
+
 
 -- | whether a post has the given tag
 checkTag :: Maybe Text -> PostInfo -> Bool
@@ -63,33 +80,22 @@ checkTag (Just t) i = t `elem` tags i
 data Options =
   Opts {
     -- | first argument: directory containing the .md files
-    dir :: !FilePath,
-    -- | second argument: title for the output page
-    title :: !Text,
-    -- | @-t, --tag@: filter by tag
-    tag :: !(Maybe Text),
-    -- | @-o, --out@: write output to file (otherwise stdout)
-    out :: !(Maybe FilePath)
+    indir :: !FilePath,
+    -- | second argument: write output to file
+    outdir :: !FilePath
   }
 
 getOptions :: IO Options
-getOptions = getOptionsWith hdr defOpts optDescrs where
-  hdr prog = "usage: " <> prog <> " [OPTION...] DIR TITLE\n\
-             \  --- get info about posts in DIR and use given title"
-
-  optDescrs :: [GetOpt.OptDescr (Options -> Options)]
-  optDescrs =
-    [GetOpt.Option "t" ["tag"]
-      (GetOpt.ReqArg (\t o -> o {tag = Just $ Text.pack t}) "TAG")
-      "list only posts with the given tag",
-     GetOpt.Option "o" ["out"]
-      (GetOpt.ReqArg (\f o -> o {out = Just f}) "FILE")
-      "write output to FILE"]
-
-  defOpts :: [String] -> Maybe Options
-  defOpts [dir, Text.pack -> title] =
-    Just $ Opts {dir, title, tag = Nothing, out = Nothing}
-  defOpts _ = Nothing
+getOptions = do
+  prog <- getProgName
+  args <- getArgs
+  case args of
+    [indir, outdir] -> pure $ Opts {..}
+    _ -> do
+      hPutStrLn stderr $
+        "usage: " <> prog <> " INDIR OUTDIR\n\
+        \  --- collect tags in posts in INDIR into yaml files in OUTDIR"
+      exitFailure
 
 
 -- | the front matter info we care about

blog-meta/slug-tags.hs

@@ -1,28 +0,0 @@
-import Text.Pandoc.Definition
-import qualified Data.Map.Strict as Map
-import Text.Pandoc.JSON
-import Data.Text (Text)
-import Misc
-
--- | adds the slugs to the tags in a post
---
--- the fact this program doesn't look at @all-tags.md@ is the reason clashing
--- slugs blow up instead of doing something better. i'll just rename one tag,
--- it's fine.
-main :: IO ()
-main = toJSONFilter \(Pandoc (Meta m) body) -> do
-  m' <- Map.alterF addSlugs "tags" m
-  pure $ Pandoc (Meta m') body
-
--- | if @tags@ exists and is a list of strings, add the slugs. if it exists and
--- is something else, explode
-addSlugs :: Maybe MetaValue -> IO (Maybe MetaValue)
-addSlugs Nothing = pure Nothing
-addSlugs (Just (toTextList -> Just tags)) =
-  pure $ Just $ MetaList $ map addSlug1 tags
-addSlugs (Just t) = fail $
-  "'tags' is\n" <> show t <> "\nwanted a list of strings"
-
-addSlug1 :: Text -> MetaValue
-addSlug1 tag = MetaMap $ Map.fromList
-  [("name", MetaString tag), ("slug", MetaString $ makeSlug tag)]

cabal.project

@@ -4,13 +4,13 @@ packages:
 source-repository-package
   type: git
   location: https://git.rhiannon.website/rhi/lang.git
-  tag: e8d46973fac634d8ee589697e19cf0cc2c39ce00
+  tag: ed54ec4c5af5b2b8ea25f0274e11c2f8c87714c3
   subdir: langfilter
 
 source-repository-package
   type: git
   location: https://git.rhiannon.website/rhi/lang.git
-  tag: e8d46973fac634d8ee589697e19cf0cc2c39ce00
+  tag: ed54ec4c5af5b2b8ea25f0274e11c2f8c87714c3
   subdir: laantas-script
 
 source-repository-package