blog-meta/all-tags.hs

@@ -17,17 +17,6 @@ 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
@@ -36,7 +25,6 @@ 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
@@ -44,55 +32,17 @@ 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" | t <- map slug' tags]
+    "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\
@@ -106,19 +56,18 @@ 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, -- ^ display name
-    slug :: !Text, -- ^ name in urls
-    count :: !Int  -- ^ how many posts with this tag
-  } deriving Show
+    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)]
 
--- | counts occurrences of each tag, and checks they all have distinct slugs
 collate :: [Set Text] -> [Tag]
 collate =
   toList . foldl' add1 mempty . foldMap toList
@@ -134,12 +83,11 @@ collate =
 
   makeTag name = Tag {name, slug = makeSlug name, count = 1}
 
--- | command line options
 data Options =
   Opts {
-    dir :: !FilePath,  -- ^ first argument: dir containing posts
-    yaml :: !FilePath, -- ^ second argument: yaml output file
-    make :: !FilePath  -- ^ third argument: make output file
+    dir :: !FilePath,
+    yaml :: !FilePath,
+    make :: !FilePath
   }
 
 getOptions :: IO Options

blog-meta/blog-meta.cabal

@@ -9,12 +9,9 @@ common deps
   default-language: Haskell2010
   default-extensions:
     BlockArguments,
-    DuplicateRecordFields,
     OverloadedStrings,
     OverloadedLists,
-    NamedFieldPuns,
     NondecreasingIndentation,
-    RecordWildCards,
     ViewPatterns
   build-depends:
     base >= 4.14.2.0 && < 4.18,

blog-meta/lib/Misc.hs

@@ -4,7 +4,6 @@ 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
@@ -13,14 +12,6 @@ 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
@@ -33,11 +24,6 @@ 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 =
@@ -49,19 +35,16 @@ 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 " "
@@ -70,30 +53,9 @@ 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 (fmap (<> "\n\n") . inlineText) is
+blockText (Para  is)       = foldMap 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,4 +1,3 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
 module YAML (module YAML, module Data.YAML, untagged) where
 
 import Data.YAML
@@ -50,6 +49,4 @@ linesUntil end h = go [] where
     if l == end then
       return $ LazyBS.fromChunks $ reverse acc
     else
-      go ("\n" : l : acc)
-
-instance FromYAML IsoDate where parseYAML = withStr "iso date" parseIsoDate
+      go (l <> "\n" : acc)

blog-meta/nice-date.hs

@@ -1,10 +1,11 @@
 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
@@ -12,6 +13,9 @@ main = toJSONFilter \(Pandoc (Meta m) body) -> do
 
 reformat :: Maybe MetaValue -> IO (Maybe MetaValue)
 reformat Nothing = pure Nothing
-reformat (Just (toText -> Just txt)) =
-  Just . MetaString . showDate <$> parseIsoDate txt
+reformat (Just (toText -> Just txt)) = do
+  -- extra '-'s in %-m and %-d to allow leading zeroes to be skipped
+  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,9 +1,11 @@
 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 ((.:), (.:?), (.!=), (##=))
@@ -11,35 +13,9 @@ 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 {..} <- getOptions
+  Opts title dir tag out <- 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
@@ -49,27 +25,21 @@ main = do
 
 makeContent :: Text -> [PostInfo] -> LazyBS.ByteString
 makeContent title is' = "---\n" <> YAML.encode1 val <> "...\n" where
-  is = sortBy (flip $ comparing date) is'
+  is = sortBy (flip $ comparing infoDate) is'
   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
+checkTag (Just t) i = t `elem` infoTags i
 
 
--- | command line options
 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)
+    optsTitle :: !Text,
+    optsDir   :: !FilePath,
+    optsTag   :: !(Maybe Text),
+    optsOut   :: !(Maybe FilePath)
   }
 
 getOptions :: IO Options
@@ -77,35 +47,22 @@ 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"]
+optDescrs :: [GetOpt.OptDescr (Options -> Options)]
+optDescrs =
+  [GetOpt.Option "t" ["tag"]
+    (GetOpt.ReqArg (\t o -> o {optsTag = 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")
+    "write output to FILE"]
 
-  defOpts :: [String] -> Maybe Options
-  defOpts [dir, Text.pack -> title] =
-    Just $ Opts {dir, title, tag = Nothing, out = Nothing}
-  defOpts _ = Nothing
+defOpts :: [String] -> Maybe Options
+defOpts [dir, title] =
+  Just $ Opts {optsDir = dir, optsTitle = Text.pack title,
+               optsTag = Nothing, optsOut = Nothing}
+defOpts _ = Nothing
 
 
--- | the front matter info we care about
-data PostInfo =
-  Info {
-    -- | the (input) file name, relative to 'dir' in options
-    file    :: FilePath,
-    title   :: Text,      -- ^ post @title@
-    date    :: IsoDate,   -- ^ post @date@
-    tags    :: [Text],    -- ^ post @tags@
-    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
@@ -119,15 +76,42 @@ getInfo dir file = do
            <*> m .:  "tags" .!= []
            <*> m .:? "summary"
 
-instance YAML.ToYAML PostInfo where
-  toYAML (Info {..}) = YAML.obj
-    ["date"     ##= showDate date,
-     "date-rss" ##= rssDate date,
-     "title"    ##= title,
-     "tags"     ##= tags,
-     "file"     ##= htmlFile file,
-     "summary"  ##= summary]
+-- | the front matter info we care about
+data PostInfo =
+  Info {
+    infoFile  :: FilePath,
+    infoTitle :: Text,
+    infoDate  :: BlogDate,
+    infoTags  :: [Text],
+    infoSummary :: Maybe Text
+  }
 
--- | replace @.md@ (or whatever) extension with @.html@
-htmlFile :: FilePath -> Text
-htmlFile f = Text.pack $ Path.replaceExtension f "html"
+instance YAML.ToYAML PostInfo where
+  toYAML (Info file title date tags summary) = YAML.obj
+    [("date"     ##= date),
+     ("date-rss" ##= toRss date),
+     ("title"    ##= title),
+     ("tags"     ##= tags),
+     ("file"     ##= Text.pack (fixup file)),
+     ("summary"  ##= summary)]
+    where
+      fixup f = Path.replaceExtension f "html"
+      toRss (BD d) = RD d
+
+newtype BlogDate = BD Day deriving (Eq, Ord)
+newtype RssDate = RD Day deriving (Eq, Ord)
+
+instance YAML.FromYAML RssDate where
+  parseYAML = YAML.withStr "YYYY-MM-DD" $
+    fmap RD . parseTimeM True defaultTimeLocale "%F" . Text.unpack
+
+instance YAML.ToYAML RssDate where
+  toYAML (RD d) = YAML.str $ Text.pack $
+    formatTime defaultTimeLocale "%a, %d %b %Y 00:00:01 UT" d
+
+instance YAML.FromYAML BlogDate where
+  parseYAML = fmap (\(RD d) -> BD d) . YAML.parseYAML
+
+instance YAML.ToYAML BlogDate where
+  toYAML (BD d) = YAML.str $ Text.pack $ map toLower $
+    formatTime defaultTimeLocale "%a %-d %B %Y" d

blog-meta/slug-tags.hs

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

templates/head.html

@@ -1,7 +1,6 @@
 <!DOCTYPE html>
 <html$if(lang)$ lang=$lang$$endif$$if(dir)$ dir=$dir$$endif$>
 <meta charset=utf-8>
-<meta name=viewport content="width=device-width, initial-scale=1">
 
 <link rel=stylesheet href=/style/page.css>
 $for(css)$