comments and a little simplification

This commit is contained in:
rhiannon morris 2024-09-16 19:45:50 +02:00
parent 645aa00aa4
commit b1d96ac567
7 changed files with 177 additions and 60 deletions

View file

@ -17,6 +17,17 @@ import qualified Data.Text.IO as Text
import qualified Data.Text 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 :: IO ()
main = do main = do
Opts {dir, yaml, make} <- getOptions Opts {dir, yaml, make} <- getOptions
@ -25,6 +36,7 @@ main = do
LazyBS.writeFile yaml $ makeYAML tags LazyBS.writeFile yaml $ makeYAML tags
Text.writeFile make $ makeMake tags Text.writeFile make $ makeMake tags
-- | reads tags from a single file
getTags :: FilePath -> IO (Set Text) getTags :: FilePath -> IO (Set Text)
getTags file = do getTags file = do
yaml <- YAML.readHeader file yaml <- YAML.readHeader file
@ -32,17 +44,55 @@ getTags file = do
yaml & YAML.withMap "yaml header" \m -> m .: "tags" .!= [] yaml & YAML.withMap "yaml header" \m -> m .: "tags" .!= []
pure $ Set.fromList list 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 :: [Set Text] -> LazyBS.ByteString
makeYAML tags = "---\n" <> yaml <> "\n...\n" where makeYAML tags = "---\n" <> yaml <> "\n...\n" where
yaml = YAML.encode1 $ YAML.obj yaml = YAML.encode1 $ YAML.obj
[("title" ##= YAML.str "all tags"), [("title" ##= YAML.str "all tags"),
("all-tags" ##= collate 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 :: [Set Text] -> Text
makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where
build = Text.unwords $ 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 = makeRule' opt title file =
"$(TMPDIR)/" <> file <> ".md : $(POSTS) $(POST_LISTS)\n\ "$(TMPDIR)/" <> file <> ".md : $(POSTS) $(POST_LISTS)\n\
\\t@echo \"[post-lists] " <> file <> "\"\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 slug' (Tag {slug}) = "tag-" <> slug
tags = collate tags' tags = collate tags'
-- | info about a tag
data Tag = data Tag =
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 instance YAML.ToYAML Tag where
toYAML (Tag {name, slug, count}) = YAML.obj $ toYAML (Tag {name, slug, count}) = YAML.obj $
[("name" ##= name), ("slug" ##= slug), ("count" ##= count)] [("name" ##= name), ("slug" ##= slug), ("count" ##= count)]
-- | counts occurrences of each tag, and checks they all have distinct slugs
collate :: [Set Text] -> [Tag] collate :: [Set Text] -> [Tag]
collate = collate =
toList . foldl' add1 mempty . foldMap toList toList . foldl' add1 mempty . foldMap toList
@ -83,11 +134,12 @@ collate =
makeTag name = Tag {name, slug = makeSlug name, count = 1} makeTag name = Tag {name, slug = makeSlug name, count = 1}
-- | command line options
data Options = data Options =
Opts { 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 getOptions :: IO Options

View file

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

View file

@ -4,6 +4,7 @@ import qualified System.Console.GetOpt as GetOpt
import System.Environment import System.Environment
import System.Exit import System.Exit
import Data.Text (Text) import Data.Text (Text)
import Data.Time
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Char (isAlphaNum, isAscii, toLower) import Data.Char (isAlphaNum, isAscii, toLower)
import Text.Pandoc.Definition import Text.Pandoc.Definition
@ -12,6 +13,14 @@ import Text.Pandoc.Definition
unwrap :: Show a => FilePath -> Either a b -> IO b unwrap :: Show a => FilePath -> Either a b -> IO b
unwrap file = either (\x -> fail $ file <> ":" <> show x) return 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) getOptionsWith :: (String -> String) -> ([String] -> Maybe a)
-> [GetOpt.OptDescr (a -> a)] -> IO a -> [GetOpt.OptDescr (a -> a)] -> IO a
getOptionsWith hdr mkDef descrs = do getOptionsWith hdr mkDef descrs = do
@ -24,6 +33,11 @@ getOptionsWith hdr mkDef descrs = do
putStrLn $ GetOpt.usageInfo (hdr prog) descrs putStrLn $ GetOpt.usageInfo (hdr prog) descrs
exitFailure 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 -> Text
makeSlug = Text.intercalate "-" . filter (not . Text.null) . chunks where makeSlug = Text.intercalate "-" . filter (not . Text.null) . chunks where
chunks txt = chunks txt =
@ -35,16 +49,19 @@ makeSlug = Text.intercalate "-" . filter (not . Text.null) . chunks where
isOK c = (isAlphaNum c && isAscii c) || c == '-' isOK c = (isAlphaNum c && isAscii c) || c == '-'
-- | tries to convert a meta value to a list of strings
toTextList :: MetaValue -> Maybe [Text] toTextList :: MetaValue -> Maybe [Text]
toTextList (MetaList vs) = traverse toText vs toTextList (MetaList vs) = traverse toText vs
toTextList _ = Nothing toTextList _ = Nothing
-- | tries to convert a meta value to a single string
toText :: MetaValue -> Maybe Text toText :: MetaValue -> Maybe Text
toText (MetaString str) = Just str toText (MetaString str) = Just str
toText (MetaInlines is) = foldMap inlineText is toText (MetaInlines is) = foldMap inlineText is
toText (MetaBlocks bs) = foldMap blockText bs toText (MetaBlocks bs) = foldMap blockText bs
toText _ = Nothing toText _ = Nothing
-- | converts a pandoc inline into a string, if it contains only text.
inlineText :: Inline -> Maybe Text inlineText :: Inline -> Maybe Text
inlineText (Str txt) = Just txt inlineText (Str txt) = Just txt
inlineText Space = Just " " inlineText Space = Just " "
@ -53,9 +70,30 @@ inlineText LineBreak = Just " "
inlineText (RawInline _ txt) = Just txt inlineText (RawInline _ txt) = Just txt
inlineText _ = Nothing inlineText _ = Nothing
-- | converts a pandoc inline into a string, if it contains only paragraphs of
-- text.
blockText :: Block -> Maybe Text blockText :: Block -> Maybe Text
blockText (Plain is) = foldMap inlineText is 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 (RawBlock _ txt) = Just txt
blockText _ = Nothing 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

View file

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

View file

@ -1,11 +1,10 @@
import Text.Pandoc.Definition import Text.Pandoc.Definition
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Time
import Text.Pandoc.JSON import Text.Pandoc.JSON
import Data.Text (unpack, pack)
import Data.Char (toLower)
import Misc import Misc
-- | replaces the @date@ field, which starts in YYYY-MM-DD format, with
-- something prettier
main :: IO () main :: IO ()
main = toJSONFilter \(Pandoc (Meta m) body) -> do main = toJSONFilter \(Pandoc (Meta m) body) -> do
m' <- Map.alterF reformat "date" m m' <- Map.alterF reformat "date" m
@ -13,9 +12,6 @@ main = toJSONFilter \(Pandoc (Meta m) body) -> do
reformat :: Maybe MetaValue -> IO (Maybe MetaValue) reformat :: Maybe MetaValue -> IO (Maybe MetaValue)
reformat Nothing = pure Nothing 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" reformat (Just d) = fail $ "date is\n" <> show d <> "\nwanted a string"

View file

@ -1,11 +1,9 @@
import qualified Data.ByteString.Lazy as LazyBS import qualified Data.ByteString.Lazy as LazyBS
import Data.Char (toLower)
import Data.Function ((&)) import Data.Function ((&))
import Data.List (sortBy) import Data.List (sortBy)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Time
import Misc import Misc
import qualified YAML import qualified YAML
import 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.Find as Find
import qualified System.FilePath as Path 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 :: IO ()
main = do main = do
Opts title dir tag out <- getOptions Opts {..} <- getOptions
files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir
infos <- filter (checkTag tag) <$> traverse (getInfo dir) files infos <- filter (checkTag tag) <$> traverse (getInfo dir) files
let content = makeContent title infos 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)] val = YAML.obj [("title" ##= title), ("posts" ##= is)]
-- | whether a post has the given tag
checkTag :: Maybe Text -> PostInfo -> Bool checkTag :: Maybe Text -> PostInfo -> Bool
checkTag Nothing _ = True checkTag Nothing _ = True
checkTag (Just t) i = t `elem` tags i checkTag (Just t) i = t `elem` tags i
-- | command line options
data Options = data Options =
Opts { 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 getOptions :: IO Options
@ -47,39 +77,35 @@ getOptions = getOptionsWith hdr defOpts optDescrs where
hdr prog = "usage: " <> prog <> " [OPTION...] DIR TITLE\n\ hdr prog = "usage: " <> prog <> " [OPTION...] DIR TITLE\n\
\ --- get info about posts in DIR and use given title" \ --- get info about posts in DIR and use given title"
optDescrs :: [GetOpt.OptDescr (Options -> Options)] optDescrs :: [GetOpt.OptDescr (Options -> Options)]
optDescrs = optDescrs =
[GetOpt.Option "t" ["tag"] [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", "list only posts with the given tag",
GetOpt.Option "o" ["out"] 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"] "write output to FILE"]
defOpts :: [String] -> Maybe Options 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
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 -- | the front matter info we care about
data PostInfo = data PostInfo =
Info { Info {
-- | the (input) file name, relative to 'dir' in options
file :: FilePath, 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 :: FilePath -> FilePath -> IO PostInfo
getInfo dir file = do getInfo dir file = do
yaml <- YAML.readHeader file yaml <- YAML.readHeader file
@ -102,13 +128,6 @@ instance YAML.ToYAML PostInfo where
"file" ##= htmlFile file, "file" ##= htmlFile file,
"summary" ##= summary] "summary" ##= summary]
-- | replace @.md@ (or whatever) extension with @.html@
htmlFile :: FilePath -> Text htmlFile :: FilePath -> Text
htmlFile f = Text.pack $ Path.replaceExtension f "html" 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

View file

@ -4,11 +4,18 @@ import Text.Pandoc.JSON
import Data.Text (Text) import Data.Text (Text)
import Misc 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 :: IO ()
main = toJSONFilter \(Pandoc (Meta m) body) -> do main = toJSONFilter \(Pandoc (Meta m) body) -> do
m' <- Map.alterF addSlugs "tags" m m' <- Map.alterF addSlugs "tags" m
pure $ Pandoc (Meta m') body 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 :: Maybe MetaValue -> IO (Maybe MetaValue)
addSlugs Nothing = pure Nothing addSlugs Nothing = pure Nothing
addSlugs (Just (toTextList -> Just tags)) = addSlugs (Just (toTextList -> Just tags)) =