first

blog-meta/all-tags.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Main (main) where
+
+import qualified Data.ByteString.Lazy as LazyBS
+import Data.Foldable
+import Data.Function ((&))
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import Misc
+import qualified System.FilePath.Find as Find
+import YAML ((##=), (.!=), (.:))
+import qualified YAML
+import System.Environment
+import qualified Data.Text.IO as Text
+import qualified Data.Text as Text
+import Data.Char
+
+
+main :: IO ()
+main = do
+  Opts {dir, yaml, make} <- getOptions
+  files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir
+  tags  <- traverse getTags files
+  LazyBS.writeFile yaml $ makeYAML tags
+  Text.writeFile make $ makeMake tags
+
+getTags :: FilePath -> IO (Set Text)
+getTags file = do
+  yaml <- YAML.readHeader file
+  list <- unwrap file $ YAML.parseEither $
+    yaml & YAML.withMap "yaml header" \m -> m .: "tags" .!= []
+  pure $ Set.fromList list
+
+makeYAML :: [Set Text] -> LazyBS.ByteString
+makeYAML tags = "---\n" <> yaml <> "\n...\n" where
+  yaml = YAML.encode1 $ YAML.obj
+    [("title" ##= YAML.str "all tags"),
+     ("tags"  ##= collate tags)]
+
+makeMake :: [Set Text] -> Text
+makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where
+  build = Text.unwords $
+    "build:" : ["$(BUILDDIR)/" <> t <> ".html" |
+                  t <- ["all-tags", "all-posts"] <> map slug' tags]
+  makeRule' opt title file =
+    "$(TMPDIR)/" <> file <> ".md : $(POSTS) $(POST_LISTS)\n\
+    \\t@echo \"[post-lists] $<\"\n\
+    \\t$(POST_LISTS) " <> opt <> " --out $@ \\\n\
+    \\t  $(POSTSDIR) \"" <> title <> "\""
+  allPosts = makeRule' "" "all posts" "all-posts"
+  makeRule t =
+    makeRule' ("--tag \"" <> name t <> "\"")
+              ("posts tagged ‘" <> name t <> "’")
+              (slug' t)
+  slug' (Tag {slug}) = "tag-" <> slug
+  tags = collate tags'
+
+data Tag =
+  Tag {
+    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)]
+
+collate :: [Set Text] -> [Tag]
+collate tags₀ =
+  toList $ fst $ foldl' add1 (mempty, mempty) $ foldMap toList tags₀
+ where
+  add1 (tags, slugs) name
+    | Map.member name tags =
+        (Map.adjust incrCount name tags, slugs)
+    | otherwise            =
+        let tag = makeTag slugs name in
+        (Map.insert name tag tags,
+         Set.insert (slug tag) slugs)
+  makeTag slugs name =
+    Tag {name, slug = makeSlug slugs name, count = 1}
+  makeSlug slugs name = head $ filter (`notElem` slugs) candidates where
+    slug₀ = Text.map toSlugChar name
+    toSlugChar c
+      | isAlphaNum c && isAscii c || c == '-' = toLower c
+      | otherwise                             = '_'
+    candidates = slug₀ : [slug₀ <> Text.pack (show i) | i <- [(0 :: Int) ..]]
+  incrCount t@(Tag {count}) = t {count = succ count}
+
+data Options =
+  Opts {
+    dir :: !FilePath,
+    yaml :: !FilePath,
+    make :: !FilePath
+  }
+
+getOptions :: IO Options
+getOptions = do
+    args <- getArgs
+    prog <- getProgName
+    case args of
+      [dir, yaml, make] -> pure $ Opts {dir, yaml, make}
+      _ -> fail $
+        "usage: " <> prog <> " DIR YAML MAKE ---\n\
+        \  get all tags from posts in DIR and put the results in the given files"

blog-meta/blog-meta.cabal

@@ -0,0 +1,51 @@
+cabal-version: 2.2
+name: blog-meta
+version: 0.1
+
+author: rhiannon morris <rhi@rhiannon.website>
+maintainer: rhiannon morris <rhi@rhiannon.website>
+
+common deps
+  default-language: Haskell2010
+  default-extensions:
+    BlockArguments,
+    OverloadedStrings,
+    OverloadedLists,
+    NondecreasingIndentation,
+    ViewPatterns
+  build-depends:
+    base ^>= 4.14.2.0,
+    HsYAML ^>= 0.2.1.0,
+    bytestring ^>= 0.10.12.0,
+    containers ^>= 0.6.4.1,
+    filemanip,
+    pandoc-types ^>= 1.22,
+    text ^>= 1.2.4.1,
+    time ^>= 1.9.3
+  ghc-options: -Wall
+
+common exe
+  build-depends: blog-meta
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+
+library
+  import: deps
+  hs-source-dirs: lib
+  exposed-modules:
+    YAML,
+    Misc
+
+executable post-lists
+  import: deps, exe
+  hs-source-dirs: .
+  main-is: post-lists.hs
+
+executable all-tags
+  import: deps, exe
+  hs-source-dirs: .
+  main-is: all-tags.hs
+
+executable nice-date
+  import: deps, exe
+  hs-source-dirs: .
+  main-is: nice-date.hs

blog-meta/lib/Misc.hs

@@ -0,0 +1,22 @@
+module Misc where
+
+import qualified System.Console.GetOpt as GetOpt
+import System.Environment
+import System.Exit
+
+-- | exception on 'Left'
+unwrap :: Show a => FilePath -> Either a b -> IO b
+unwrap file = either (\x -> fail $ file <> ":" <> show x) return
+
+getOptionsWith :: (String -> String) -> ([String] -> Maybe a)
+               -> [GetOpt.OptDescr (a -> a)] -> IO a
+getOptionsWith hdr mkDef descrs = do
+  res <- GetOpt.getOpt GetOpt.Permute descrs <$> getArgs
+  case res of
+    (fs, rest, []) | Just def <- mkDef rest ->
+      return $ foldl (flip ($)) def fs
+    _ -> do
+      prog <- getProgName
+      putStrLn $ GetOpt.usageInfo (hdr prog) descrs
+      exitFailure
+

blog-meta/lib/YAML.hs

@@ -0,0 +1,52 @@
+module YAML (module YAML) where
+
+import Data.YAML as YAML
+import Data.YAML.Event as YAML (untagged)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Misc
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LazyBS
+import qualified System.IO as IO
+
+
+str' :: String -> Node ()
+str' = str . Text.pack
+
+str :: Text -> Node ()
+str = Scalar () . SStr
+
+obj :: Mapping () -> Node ()
+obj = Mapping () untagged
+
+(##=) :: (ToYAML b) => Text -> b -> (Node (), Node ())
+(##=) = (#=)
+
+(#=) :: (ToYAML a, ToYAML b) => a -> b -> (Node (), Node ())
+k #= v = (toYAML k, toYAML v)
+
+list :: ToYAML a => [a] -> Node ()
+list = Sequence () untagged . map toYAML
+
+
+-- | read a chunk from the beginning of the file between a
+-- @---@ and a @...@. throw an exception if there isn't one
+readHeader :: FilePath -> IO (YAML.Node YAML.Pos)
+readHeader file = IO.withFile file IO.ReadMode \h -> do
+  ln <- BS.hGetLine h
+  if (ln /= "---") then
+    fail $ file <> ": no header"
+  else
+    unwrap file . YAML.decode1 =<< linesUntil "..." h
+
+-- | read all the lines from a handle until the given terminator. return the
+-- lines read, excluding the terminator
+linesUntil :: ByteString -> IO.Handle -> IO LazyBS.ByteString
+linesUntil end h = go [] where
+  go acc = do
+    l <- BS.hGetLine h
+    if l == end then
+      return $ LazyBS.fromChunks $ reverse acc
+    else
+      go (l <> "\n" : acc)

blog-meta/nice-date.hs

@@ -0,0 +1,45 @@
+import Text.Pandoc.Definition
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Time
+import Text.Pandoc.JSON
+import Data.Text (Text, unpack, pack)
+import Data.Char (toLower)
+
+main :: IO ()
+main = toJSONFilter \(Pandoc (Meta m) body) -> do
+  m' <- niceDate m
+  pure $ Pandoc (Meta m') body
+
+niceDate :: Map Text MetaValue -> IO (Map Text MetaValue)
+niceDate = Map.alterF reformat "date"
+
+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 d) = fail $ "date is\n" <> show d <> "\nwanted a string"
+
+toText :: MetaValue -> Maybe Text
+toText (MetaString str) = Just str
+toText (MetaInlines is) = foldMap inlineText is
+toText (MetaBlocks bs) = foldMap blockText bs
+toText _ = Nothing
+
+inlineText :: Inline -> Maybe Text
+inlineText (Str txt)         = Just txt
+inlineText Space             = Just " "
+inlineText SoftBreak         = Just " "
+inlineText LineBreak         = Just " "
+inlineText (RawInline _ txt) = Just txt
+inlineText _                 = Nothing
+
+blockText :: Block -> Maybe Text
+blockText (Plain is)       = foldMap inlineText is
+blockText (Para  is)       = foldMap inlineText is
+blockText Null             = Just ""
+blockText (RawBlock _ txt) = Just txt
+blockText _                = Nothing

blog-meta/post-lists.hs

@@ -0,0 +1,100 @@
+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 qualified YAML
+import YAML ((.:), (.!=), (##=))
+import qualified System.Console.GetOpt as GetOpt
+import qualified System.FilePath.Find as Find
+import Misc
+import Data.Char (toLower)
+
+main :: IO ()
+main = do
+  Opts title dir tag out <- getOptions
+  files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir
+  infos <- filter (checkTag tag) <$> traverse getInfo 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 infoDate) is'
+  val = YAML.obj [("title" ##= title), ("posts" ##= is)]
+
+
+checkTag :: Maybe Text -> PostInfo -> Bool
+checkTag Nothing  _ = True
+checkTag (Just t) i = t `elem` infoTags i
+
+
+data Options =
+  Opts {
+    optsTitle :: !Text,
+    optsDir   :: !FilePath,
+    optsTag   :: !(Maybe Text),
+    optsOut   :: !(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 {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, title] =
+  Just $ Opts {optsDir = dir, optsTitle = Text.pack title,
+               optsTag = Nothing, optsOut = Nothing}
+defOpts _ = Nothing
+
+
+getInfo :: FilePath -> IO PostInfo
+getInfo file = do
+  yaml <- YAML.readHeader file
+  unwrap file $ YAML.parseEither $
+    yaml & YAML.withMap "title, date, tags" \m ->
+      Info <$> return (Text.pack file)
+           <*> m .: "title"
+           <*> m .: "date"
+           <*> m .: "tags" .!= []
+
+-- | the front matter info we care about
+data PostInfo =
+  Info {
+    _nfoFile  :: Text,
+    _nfoTitle :: Text,
+    infoDate  :: BlogDate,
+    infoTags  :: [Text]
+  }
+
+instance YAML.ToYAML PostInfo where
+  toYAML (Info file title date tags) = YAML.obj
+    [("date"  ##= date),
+     ("title" ##= title),
+     ("tags"  ##= tags),
+     ("file"  ##= file)]
+
+newtype BlogDate = D Day deriving (Eq, Ord)
+
+instance YAML.FromYAML BlogDate where
+  parseYAML = YAML.withStr "YYYY-MM-DD" $
+    fmap D . parseTimeM True defaultTimeLocale "%F" . Text.unpack
+
+instance YAML.ToYAML BlogDate where
+  toYAML (D d) = YAML.str $ Text.pack $ map toLower $
+    formatTime defaultTimeLocale "%a %-d %B %Y" d