diff --git a/blog-meta/all-tags.hs b/blog-meta/all-tags.hs index a66f9f0..8cb5b36 100644 --- a/blog-meta/all-tags.hs +++ b/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" | - t <- ["all-tags", "index"] <> map slug' tags] + "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\ @@ -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, - slug :: !Text, - count :: !Int - } - deriving Show + name :: !Text, -- ^ display name + slug :: !Text, -- ^ name in urls + count :: !Int -- ^ how many posts with this tag + } 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, - yaml :: !FilePath, - make :: !FilePath + dir :: !FilePath, -- ^ first argument: dir containing posts + yaml :: !FilePath, -- ^ second argument: yaml output file + make :: !FilePath -- ^ third argument: make output file } getOptions :: IO Options diff --git a/blog-meta/blog-meta.cabal b/blog-meta/blog-meta.cabal index 210554e..05532ac 100644 --- a/blog-meta/blog-meta.cabal +++ b/blog-meta/blog-meta.cabal @@ -9,9 +9,12 @@ common deps default-language: Haskell2010 default-extensions: BlockArguments, + DuplicateRecordFields, OverloadedStrings, OverloadedLists, + NamedFieldPuns, NondecreasingIndentation, + RecordWildCards, ViewPatterns build-depends: base >= 4.14.2.0 && < 4.18, diff --git a/blog-meta/lib/Misc.hs b/blog-meta/lib/Misc.hs index b060ee3..f79b268 100644 --- a/blog-meta/lib/Misc.hs +++ b/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 Null = Just "" +blockText (Para is) = foldMap (fmap (<> "\n\n") . inlineText) is 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 diff --git a/blog-meta/lib/YAML.hs b/blog-meta/lib/YAML.hs index 725d273..4a68d43 100644 --- a/blog-meta/lib/YAML.hs +++ b/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 diff --git a/blog-meta/nice-date.hs b/blog-meta/nice-date.hs index 6ee5cd1..faad98a 100644 --- a/blog-meta/nice-date.hs +++ b/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 - -- 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 (toText -> Just txt)) = + Just . MetaString . showDate <$> parseIsoDate txt reformat (Just d) = fail $ "date is\n" <> show d <> "\nwanted a string" diff --git a/blog-meta/post-lists.hs b/blog-meta/post-lists.hs index 0da03a6..0661f5e 100644 --- a/blog-meta/post-lists.hs +++ b/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 @@ -25,21 +49,27 @@ main = do makeContent :: Text -> [PostInfo] -> LazyBS.ByteString makeContent title is' = "---\n" <> YAML.encode1 val <> "...\n" where - is = sortBy (flip $ comparing infoDate) is' + is = sortBy (flip $ comparing date) 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` infoTags i +checkTag (Just t) i = t `elem` tags i +-- | command line options data Options = Opts { - optsTitle :: !Text, - optsDir :: !FilePath, - optsTag :: !(Maybe Text), - optsOut :: !(Maybe FilePath) + -- | 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) } getOptions :: IO Options @@ -47,22 +77,35 @@ 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 {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"] + 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, title] = - Just $ Opts {optsDir = dir, optsTitle = Text.pack title, - optsTag = Nothing, optsOut = Nothing} -defOpts _ = Nothing + defOpts :: [String] -> Maybe Options + defOpts [dir, Text.pack -> title] = + Just $ Opts {dir, title, tag = Nothing, out = 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 @@ -76,42 +119,15 @@ getInfo dir file = do <*> m .: "tags" .!= [] <*> m .:? "summary" --- | the front matter info we care about -data PostInfo = - Info { - infoFile :: FilePath, - infoTitle :: Text, - infoDate :: BlogDate, - infoTags :: [Text], - infoSummary :: Maybe Text - } - 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 + toYAML (Info {..}) = YAML.obj + ["date" ##= showDate date, + "date-rss" ##= rssDate date, + "title" ##= title, + "tags" ##= tags, + "file" ##= htmlFile file, + "summary" ##= summary] -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 +-- | replace @.md@ (or whatever) extension with @.html@ +htmlFile :: FilePath -> Text +htmlFile f = Text.pack $ Path.replaceExtension f "html" diff --git a/blog-meta/slug-tags.hs b/blog-meta/slug-tags.hs index 92d4be9..6667afc 100644 --- a/blog-meta/slug-tags.hs +++ b/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)) = diff --git a/templates/head.html b/templates/head.html index fcecb7c..20428d1 100644 --- a/templates/head.html +++ b/templates/head.html @@ -1,6 +1,7 @@ + $for(css)$