diff --git a/blog-meta/all-tags.hs b/blog-meta/all-tags.hs index 8cb5b36..a66f9f0 100644 --- a/blog-meta/all-tags.hs +++ b/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 diff --git a/blog-meta/blog-meta.cabal b/blog-meta/blog-meta.cabal index 05532ac..210554e 100644 --- a/blog-meta/blog-meta.cabal +++ b/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, diff --git a/blog-meta/lib/Misc.hs b/blog-meta/lib/Misc.hs index f79b268..b060ee3 100644 --- a/blog-meta/lib/Misc.hs +++ b/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 diff --git a/blog-meta/lib/YAML.hs b/blog-meta/lib/YAML.hs index 4a68d43..725d273 100644 --- a/blog-meta/lib/YAML.hs +++ b/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) diff --git a/blog-meta/nice-date.hs b/blog-meta/nice-date.hs index faad98a..6ee5cd1 100644 --- a/blog-meta/nice-date.hs +++ b/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" diff --git a/blog-meta/post-lists.hs b/blog-meta/post-lists.hs index 0661f5e..0da03a6 100644 --- a/blog-meta/post-lists.hs +++ b/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 diff --git a/blog-meta/slug-tags.hs b/blog-meta/slug-tags.hs index 6667afc..92d4be9 100644 --- a/blog-meta/slug-tags.hs +++ b/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)) = diff --git a/templates/head.html b/templates/head.html index 20428d1..fcecb7c 100644 --- a/templates/head.html +++ b/templates/head.html @@ -1,7 +1,6 @@ - $for(css)$