134 lines
4.2 KiB
Haskell
134 lines
4.2 KiB
Haskell
import qualified Data.ByteString.Lazy as LazyBS
|
||
import Data.Function ((&))
|
||
import Data.List (sortBy)
|
||
import Data.Ord (comparing)
|
||
import Data.Text (Text)
|
||
import qualified Data.Text as Text
|
||
import Misc
|
||
import qualified YAML
|
||
import YAML ((.:), (.:?), (.!=), (##=))
|
||
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
|
||
files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir
|
||
infos <- filter (checkTag tag) <$> traverse (getInfo dir) files
|
||
let content = makeContent title infos
|
||
case out of
|
||
Nothing -> LazyBS.putStr content
|
||
Just fn -> LazyBS.writeFile fn 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)]
|
||
|
||
|
||
-- | 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
|
||
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
|
||
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"]
|
||
|
||
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
|
||
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 .: "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]
|
||
|
||
-- | replace @.md@ (or whatever) extension with @.html@
|
||
htmlFile :: FilePath -> Text
|
||
htmlFile f = Text.pack $ Path.replaceExtension f "html"
|