comments and a little simplification

blog-meta/all-tags.hs

@@ -17,6 +17,17 @@ import qualified Data.Text.IO as Text
 import qualified Data.Text as Text
 
 
+-- |
+-- @all-tags dir yaml make@:
+--
+-- * reads all posts in @dir@
+-- * collects all tags, and assigns them slugs ('getTags')
+-- * writes a list of {tag, slug, count} to @yaml@ ('makeYAML')
+-- * writes recipes to build the tag pages to @make@ ('makeMake')
+--
+-- the program fails on slug collision, because the alternative is for the page
+-- generation to consult the global list for slugs, and i haven't done that
+-- currently
 main :: IO ()
 main = do
   Opts {dir, yaml, make} <- getOptions
@@ -25,6 +36,7 @@ main = do
   LazyBS.writeFile yaml $ makeYAML tags
   Text.writeFile make $ makeMake tags
 
+-- | reads tags from a single file
 getTags :: FilePath -> IO (Set Text)
 getTags file = do
   yaml <- YAML.readHeader file
@@ -32,17 +44,55 @@ getTags file = do
     yaml & YAML.withMap "yaml header" \m -> m .: "tags" .!= []
   pure $ Set.fromList list
 
+-- | generates a yaml document from a set of tags from each file.
+-- example:
+--
+-- @
+-- ---
+-- title: all tags
+-- all-tags:
+--   - name: tag1
+--     slug: tag1
+--     count: 2
+--   - name: tag2
+--     slug: tag2
+--     count: 7
+-- ...
+-- @
 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)]
 
+-- | generates a makefile to include that generates the index and individual
+-- tag pages. example:
+--
+-- @
+-- build: $(BUILDDIR)/tag1.html $(BUILDDIR)/tag2.html
+-- $(TMPDIR)/index.md : $(POSTS) $(POST_LISTS)
+-- 	@echo "[post-lists] index"
+-- 	$(POST_LISTS) --out $@ $(POSTSDIR) "all posts"
+-- $(TMPDIR)/tag-ats.md : $(POSTS) $(POST_LISTS)
+-- 	@echo "[post-lists] tag-tag1"
+-- 	$(POST_LISTS) --tag "tag1" --out $@ $(POSTSDIR) "posts tagged ‘tag1’"
+-- $(TMPDIR)/tag-ats.md : $(POSTS) $(POST_LISTS)
+-- 	@echo "[post-lists] tag-tag2"
+-- 	$(POST_LISTS) --tag "tag2" --out $@ $(POSTSDIR) "posts tagged ‘tag2’"
+-- @
+--
+-- the generated rules depend on these make variables:
+--
+-- * @BUILDDIR@ (output of the final site)
+-- * @TMPDIR@ (intermediate file hole)
+-- * @POSTSDIR@ (directory containing the post @.md@ files)
+-- * @POSTS@ (list of posts (**including** @POSTSDIR@, because that is what
+--   @find@ returns)
+-- * @POST_LISTS@ (path to the @post-lists@ executable)
 makeMake :: [Set Text] -> Text
 makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where
   build = Text.unwords $
-    "build:" : ["$(BUILDDIR)/" <> t <> ".html" |
+    "build:" : ["$(BUILDDIR)/" <> t <> ".html" | t <- map slug' tags]
-                  t <- ["all-tags", "index"] <> map slug' tags]
   makeRule' opt title file =
     "$(TMPDIR)/" <> file <> ".md : $(POSTS) $(POST_LISTS)\n\
     \\t@echo \"[post-lists] " <> file <> "\"\n\
@@ -56,18 +106,19 @@ makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where
   slug' (Tag {slug}) = "tag-" <> slug
   tags = collate tags'
 
+-- | info about a tag
 data Tag =
   Tag {
-    name :: !Text,
+    name :: !Text, -- ^ display name
-    slug :: !Text,
+    slug :: !Text, -- ^ name in urls
-    count :: !Int
+    count :: !Int  -- ^ how many posts with this tag
-  }
+  } deriving Show
-  deriving Show
 
 instance YAML.ToYAML Tag where
   toYAML (Tag {name, slug, count}) = YAML.obj $
     [("name" ##= name), ("slug" ##= slug), ("count" ##= count)]
 
+-- | counts occurrences of each tag, and checks they all have distinct slugs
 collate :: [Set Text] -> [Tag]
 collate =
   toList . foldl' add1 mempty . foldMap toList
@@ -83,11 +134,12 @@ collate =
 
   makeTag name = Tag {name, slug = makeSlug name, count = 1}
 
+-- | command line options
 data Options =
   Opts {
-    dir :: !FilePath,
+    dir :: !FilePath,  -- ^ first argument: dir containing posts
-    yaml :: !FilePath,
+    yaml :: !FilePath, -- ^ second argument: yaml output file
-    make :: !FilePath
+    make :: !FilePath  -- ^ third argument: make output file
   }
 
 getOptions :: IO Options

blog-meta/blog-meta.cabal

@@ -9,8 +9,10 @@ common deps
   default-language: Haskell2010
   default-extensions:
     BlockArguments,
+    DuplicateRecordFields,
     OverloadedStrings,
     OverloadedLists,
+    NamedFieldPuns,
     NondecreasingIndentation,
     RecordWildCards,
     ViewPatterns

blog-meta/lib/Misc.hs

@@ -4,6 +4,7 @@ import qualified System.Console.GetOpt as GetOpt
 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
@@ -12,6 +13,14 @@ import Text.Pandoc.Definition
 unwrap :: Show a => FilePath -> Either a b -> IO b
 unwrap file = either (\x -> fail $ file <> ":" <> show x) return
 
+-- | @getOptionsWith hdr start opts@:
+--
+-- * calls 'getOpt' on the command line arguments
+-- * if there are no unrecognised flags, calls 'start' on the non-option
+--   arguments, and then applies the functions from the options to the result of
+--   that
+-- * otherwise it shows a usage message where the header is 'hdr' applied to the
+--   executable name
 getOptionsWith :: (String -> String) -> ([String] -> Maybe a)
                -> [GetOpt.OptDescr (a -> a)] -> IO a
 getOptionsWith hdr mkDef descrs = do
@@ -24,6 +33,11 @@ getOptionsWith hdr mkDef descrs = do
       putStrLn $ GetOpt.usageInfo (hdr prog) descrs
       exitFailure
 
+-- | makes a url slug by:
+--
+-- * replacing all sequences of non-ascii or non-alphanumeric characters with
+--   @"-"@
+-- * lowercasing all (ascii) letters
 makeSlug :: Text -> Text
 makeSlug = Text.intercalate "-" . filter (not . Text.null) . chunks where
   chunks txt =
@@ -35,16 +49,19 @@ makeSlug = Text.intercalate "-" . filter (not . Text.null) . chunks where
   isOK c = (isAlphaNum c && isAscii c) || c == '-'
 
 
+-- | tries to convert a meta value to a list of strings
 toTextList :: MetaValue -> Maybe [Text]
 toTextList (MetaList vs) =  traverse toText vs
 toTextList _ = Nothing
 
+-- | tries to convert a meta value to a single string
 toText :: MetaValue -> Maybe Text
 toText (MetaString str) = Just str
 toText (MetaInlines is) = foldMap inlineText is
 toText (MetaBlocks bs) = foldMap blockText bs
 toText _ = Nothing
 
+-- | converts a pandoc inline into a string, if it contains only text.
 inlineText :: Inline -> Maybe Text
 inlineText (Str txt)         = Just txt
 inlineText Space             = Just " "
@@ -53,9 +70,30 @@ inlineText LineBreak         = Just " "
 inlineText (RawInline _ txt) = Just txt
 inlineText _                 = Nothing
 
+-- | converts a pandoc inline into a string, if it contains only paragraphs of
+-- text.
 blockText :: Block -> Maybe Text
 blockText (Plain is)       = foldMap inlineText is
-blockText (Para  is)       = foldMap inlineText is
+blockText (Para  is)       = foldMap (fmap (<> "\n\n") . inlineText) is
---blockText Null             = Just ""
 blockText (RawBlock _ txt) = Just txt
 blockText _                = Nothing
+
+
+-- | date in YYYY-MM-DD format
+newtype IsoDate = ID Day deriving (Eq, Ord)
+
+-- | actually allows one-digit months and days
+parseIsoDate :: MonadFail f => Text -> f IsoDate
+parseIsoDate =
+  fmap ID . parseTimeM True defaultTimeLocale "%Y-%-m-%-d" . Text.unpack
+
+
+-- | formats a date in the RSS format, e.g. @Mon, 09 Sep 2024 00:00:01 UT@
+rssDate :: IsoDate -> Text
+rssDate (ID d) =
+  Text.pack $ formatTime defaultTimeLocale "%a, %d %b %Y 00:00:01 UT" d
+
+-- | formats a date in a format i like, e.g. @mon 9 sep 2024@
+showDate :: IsoDate -> Text
+showDate (ID d) =
+  Text.pack $ toLower <$> formatTime defaultTimeLocale "%a %-d %B %Y" d

blog-meta/lib/YAML.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
 module YAML (module YAML, module Data.YAML, untagged) where
 
 import Data.YAML
@@ -49,4 +50,6 @@ linesUntil end h = go [] where
     if l == end then
       return $ LazyBS.fromChunks $ reverse acc
     else
-      go (l <> "\n" : acc)
+      go ("\n" : l : acc)
+
+instance FromYAML IsoDate where parseYAML = withStr "iso date" parseIsoDate

blog-meta/nice-date.hs

@@ -1,11 +1,10 @@
 import Text.Pandoc.Definition
 import qualified Data.Map.Strict as Map
-import Data.Time
 import Text.Pandoc.JSON
-import Data.Text (unpack, pack)
-import Data.Char (toLower)
 import Misc
 
+-- | replaces the @date@ field, which starts in YYYY-MM-DD format, with
+-- something prettier
 main :: IO ()
 main = toJSONFilter \(Pandoc (Meta m) body) -> do
   m' <- Map.alterF reformat "date" m
@@ -13,9 +12,6 @@ main = toJSONFilter \(Pandoc (Meta m) body) -> do
 
 reformat :: Maybe MetaValue -> IO (Maybe MetaValue)
 reformat Nothing = pure Nothing
-reformat (Just (toText -> Just txt)) = do
+reformat (Just (toText -> Just txt)) =
-  -- extra '-'s in %-m and %-d to allow leading zeroes to be skipped
+  Just . MetaString . showDate <$> parseIsoDate txt
-  date <- parseTimeM True defaultTimeLocale "%Y-%-m-%-d" $ unpack txt
-  let str = formatTime defaultTimeLocale "%A %-e %B %Y" (date :: Day)
-  pure $ Just $ MetaString $ pack $ map toLower str
 reformat (Just d) = fail $ "date is\n" <> show d <> "\nwanted a string"

blog-meta/post-lists.hs

@@ -1,11 +1,9 @@
 import qualified Data.ByteString.Lazy as LazyBS
-import Data.Char (toLower)
 import Data.Function ((&))
 import Data.List (sortBy)
 import Data.Ord (comparing)
 import Data.Text (Text)
 import qualified Data.Text as Text
-import Data.Time
 import Misc
 import qualified YAML
 import YAML ((.:), (.:?), (.!=), (##=))
@@ -13,9 +11,35 @@ import qualified System.Console.GetOpt as GetOpt
 import qualified System.FilePath.Find as Find
 import qualified System.FilePath as Path
 
+-- | 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.
+--
+-- example (exact yaml layout not guaranteed; whatever @HsYAML@ feels
+-- like doing):
+--
+-- @
+-- ---
+-- title: "posts tagged ‘ATS’"
+-- posts:
+--   - file: fib.html
+--     title: fibonacci in maude and ats
+--     date: mon 24 october 2022
+--     date-rss: Mon, 24 Oct 2022 00:00:01 UT
+--     tags: [computer, maude, ATS]
+--     summary: fibonacci numbers in the languages maude and ATS.
+--   - file: ats.html
+--     title: a little ats program
+--     date: fri 16 september 2022
+--     date-rss: Fri, 16 Sep 2022 00:00:01 UT
+--     tags: [computer, ATS, cool languages]
+--     summary: >
+--       a little program in a little-known, little-documented language
+--       called ATS.
+-- ...
+-- @
 main :: IO ()
 main = do
-  Opts title dir tag out <- getOptions
+  Opts {..} <- getOptions
   files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir
   infos <- filter (checkTag tag) <$> traverse (getInfo dir) files
   let content = makeContent title infos
@@ -29,17 +53,23 @@ makeContent title is' = "---\n" <> YAML.encode1 val <> "...\n" where
   val = YAML.obj [("title" ##= title), ("posts" ##= is)]
 
 
+-- | whether a post has the given tag
 checkTag :: Maybe Text -> PostInfo -> Bool
 checkTag Nothing  _ = True
 checkTag (Just t) i = t `elem` tags i
 
 
+-- | command line options
 data Options =
   Opts {
-    optsTitle :: !Text,
+    -- | first argument: directory containing the .md files
-    optsDir   :: !FilePath,
+    dir :: !FilePath,
-    optsTag   :: !(Maybe Text),
+    -- | second argument: title for the output page
-    optsOut   :: !(Maybe FilePath)
+    title :: !Text,
+    -- | @-t, --tag@: filter by tag
+    tag :: !(Maybe Text),
+    -- | @-o, --out@: write output to file (otherwise stdout)
+    out :: !(Maybe FilePath)
   }
 
 getOptions :: IO Options
@@ -50,36 +80,32 @@ getOptions = getOptionsWith hdr defOpts optDescrs where
   optDescrs :: [GetOpt.OptDescr (Options -> Options)]
   optDescrs =
     [GetOpt.Option "t" ["tag"]
-    (GetOpt.ReqArg (\t o -> o {optsTag = Just $ Text.pack 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 {optsOut = Just f}) "FILE")
+      (GetOpt.ReqArg (\f o -> o {out = Just f}) "FILE")
       "write output to FILE"]
 
   defOpts :: [String] -> Maybe Options
-defOpts [dir, title] =
+  defOpts [dir, Text.pack -> title] =
-  Just $ Opts {optsDir = dir, optsTitle = Text.pack title,
+    Just $ Opts {dir, title, tag = Nothing, out = Nothing}
-               optsTag = Nothing, optsOut = Nothing}
   defOpts _ = Nothing
 
 
-
-newtype IsoDate = ID Day deriving (Eq, Ord)
-
-instance YAML.FromYAML IsoDate where
-  parseYAML = YAML.withStr "YYYY-MM-DD" $
-    fmap ID . parseTimeM True defaultTimeLocale "%F" . Text.unpack
-
 -- | the front matter info we care about
 data PostInfo =
   Info {
+    -- | the (input) file name, relative to 'dir' in options
     file    :: FilePath,
-    title   :: Text,
+    title   :: Text,      -- ^ post @title@
-    date    :: IsoDate,
+    date    :: IsoDate,   -- ^ post @date@
-    tags    :: [Text],
+    tags    :: [Text],    -- ^ post @tags@
-    summary :: Maybe Text
+    summary :: Maybe Text -- ^ post @summary@ (optional)
   }
 
+-- | @getInfo dir file@: read the front matter of @dir/file@
+--
+-- the 'file' field is just the filename, with @dir@ removed
 getInfo :: FilePath -> FilePath -> IO PostInfo
 getInfo dir file = do
   yaml <- YAML.readHeader file
@@ -102,13 +128,6 @@ instance YAML.ToYAML PostInfo where
      "file"     ##= htmlFile file,
      "summary"  ##= summary]
 
+-- | replace @.md@ (or whatever) extension with @.html@
 htmlFile :: FilePath -> Text
 htmlFile f = Text.pack $ Path.replaceExtension f "html"
-
-rssDate :: IsoDate -> Text
-rssDate (ID d) =
-  Text.pack $ formatTime defaultTimeLocale "%a, %d %b %Y 00:00:01 UT" d
-
-showDate :: IsoDate -> Text
-showDate (ID d) =
-  Text.pack $ toLower <$> formatTime defaultTimeLocale "%a %-d %B %Y" d

blog-meta/slug-tags.hs

@@ -4,11 +4,18 @@ 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)) =