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", "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"
|