rhiannon morris
5a94aae932
- do all filters in one go - do all post lists in one run of the program - only write files if they are changed (so make repeats less work) - simplify pandoc command for meta pages (this might not actually make a difference)
142 lines
4.4 KiB
Haskell
142 lines
4.4 KiB
Haskell
import Data.ByteString.Lazy qualified as LazyBS
|
||
import Data.Function ((&))
|
||
import Data.List (sortBy)
|
||
import Data.Ord (comparing)
|
||
import Data.Text (Text)
|
||
import Data.Text qualified as Text
|
||
import Misc
|
||
import System.FilePath qualified as Path
|
||
import System.FilePath.Find qualified as Find
|
||
import YAML ((.:), (.:?), (.!=), (##=))
|
||
import YAML qualified
|
||
import System.Environment
|
||
import System.IO
|
||
import System.Exit
|
||
import Data.Set (Set)
|
||
import qualified Data.Set as Set
|
||
import System.FilePath
|
||
import Data.Foldable
|
||
|
||
-- | 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
|
||
files <- Find.findL True (pure True) (Find.extension Find.==? ".md") indir
|
||
infos <- traverse (getInfo indir) files
|
||
for_ (allTags infos) \tag -> do
|
||
let title = "pages tagged ‘" <> tag <> "’"
|
||
let basename = "tag-" <> Text.unpack (makeSlug tag) <.> "md"
|
||
let tagged = filter (checkTag $ Just tag) infos
|
||
makeTagInfo tagged title basename outdir
|
||
makeTagInfo infos "all posts" "index.md" outdir
|
||
|
||
makeTagInfo :: [PostInfo] -> Text -> String -> FilePath -> IO ()
|
||
makeTagInfo infos title basename outdir = do
|
||
let content = makeContent title infos
|
||
let filename = outdir </> basename
|
||
writeIfDifferentBS filename content
|
||
|
||
makeContent :: Text -> [PostInfo] -> LazyBS.ByteString
|
||
makeContent title is' = "---\n" <> YAML.encode1 val <> "...\n" where
|
||
is = sortBy (flip $ comparing date) is'
|
||
val = YAML.obj [("title" ##= title), ("posts" ##= is)]
|
||
|
||
allTags :: Foldable t => t PostInfo -> Set Text
|
||
allTags = foldMap (Set.fromList . tags)
|
||
|
||
|
||
-- | 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 {
|
||
-- | first argument: directory containing the .md files
|
||
indir :: !FilePath,
|
||
-- | second argument: write output to file
|
||
outdir :: !FilePath
|
||
}
|
||
|
||
getOptions :: IO Options
|
||
getOptions = do
|
||
prog <- getProgName
|
||
args <- getArgs
|
||
case args of
|
||
[indir, outdir] -> pure $ Opts {..}
|
||
_ -> do
|
||
hPutStrLn stderr $
|
||
"usage: " <> prog <> " INDIR OUTDIR\n\
|
||
\ --- collect tags in posts in INDIR into yaml files in OUTDIR"
|
||
exitFailure
|
||
|
||
|
||
-- | 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@
|
||
dateStr :: Text, -- ^ post @date@, but as text
|
||
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
|
||
let dirs = Path.splitPath dir
|
||
let file' = Path.joinPath $ drop (length dirs) $ Path.splitPath file
|
||
unwrap file $ YAML.parseEither $
|
||
yaml & YAML.withMap "title, date, tags, summary?" \m ->
|
||
Info <$> pure file'
|
||
<*> m .: "title"
|
||
<*> m .: "date"
|
||
<*> m .: "date"
|
||
<*> m .: "tags" .!= []
|
||
<*> m .:? "summary"
|
||
|
||
instance YAML.ToYAML PostInfo where
|
||
toYAML (Info {..}) = YAML.obj
|
||
["date" ##= showDate date,
|
||
"date-rss" ##= rssDate date,
|
||
"date-iso" ##= dateStr,
|
||
"title" ##= title,
|
||
"tags" ##= tags,
|
||
"file" ##= htmlFile file,
|
||
"summary" ##= summary]
|
||
|
||
-- | replace @.md@ (or whatever) extension with @.html@
|
||
htmlFile :: FilePath -> Text
|
||
htmlFile f = Text.pack $ Path.replaceExtension f "html"
|