109 lines
3.3 KiB
Haskell
109 lines
3.3 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
|
||
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", "index"] <> 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" "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 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"
|