comments and a little simplification
This commit is contained in:
parent
645aa00aa4
commit
b1d96ac567
7 changed files with 177 additions and 60 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -9,8 +9,10 @@ common deps
|
|||
default-language: Haskell2010
|
||||
default-extensions:
|
||||
BlockArguments,
|
||||
DuplicateRecordFields,
|
||||
OverloadedStrings,
|
||||
OverloadedLists,
|
||||
NamedFieldPuns,
|
||||
NondecreasingIndentation,
|
||||
RecordWildCards,
|
||||
ViewPatterns
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
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,39 +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
|
||||
|
||||
|
||||
|
||||
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,
|
||||
date :: IsoDate,
|
||||
tags :: [Text],
|
||||
summary :: Maybe Text
|
||||
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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)) =
|
||||
|
|
|
|||
Loading…
Reference in a new issue