102 lines
3.0 KiB
Haskell
102 lines
3.0 KiB
Haskell
{-# 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
|
||
|
||
|
||
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"),
|
||
("all-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", "index"] <> map slug' tags]
|
||
makeRule' opt title file =
|
||
"$(TMPDIR)/" <> file <> ".md : $(POSTS) $(POST_LISTS)\n\
|
||
\\t@echo \"[post-lists] " <> file <> "\"\n\
|
||
\\t$(POST_LISTS) " <> opt <> " --out $@ \\\n\
|
||
\\t $(POSTSDIR) \"" <> title <> "\""
|
||
allPosts = makeRule' "" "all posts" "index"
|
||
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 =
|
||
toList . foldl' add1 mempty . foldMap toList
|
||
where
|
||
add1 tags name = Map.alter (add1' tag) (slug tag) tags
|
||
where tag = makeTag name
|
||
|
||
add1' new Nothing = Just new
|
||
add1' new (Just old)
|
||
| name new == name old = Just (old {count = succ (count old)})
|
||
| otherwise = error $ "slug collision between " <> show (name old) <>
|
||
" and " <> show (name new)
|
||
|
||
makeTag name = Tag {name, slug = makeSlug name, count = 1}
|
||
|
||
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"
|