diff --git a/Makefile b/Makefile index c91feba..265d206 100644 --- a/Makefile +++ b/Makefile @@ -29,9 +29,10 @@ LAANTAS_SCRIPT = $(TMPDIR)/laantas-script ALL_TAGS = $(TMPDIR)/all-tags POST_LISTS = $(TMPDIR)/post-lists NICE_DATE = $(TMPDIR)/nice-date +SLUG_TAGS = $(TMPDIR)/slug-tags EXECS = \ $(LANGFILTER) $(LAANTAS_SCRIPT) \ - $(ALL_TAGS) $(POST_LISTS) $(NICE_DATE) + $(ALL_TAGS) $(POST_LISTS) $(NICE_DATE) $(SLUG_TAGS) CABAL_FLAGS ?= -O -v0 @@ -67,7 +68,8 @@ define pandoc pandoc -s --toc --template $(TEMPLATEDIR)/$(1).html -o $@ $< \ -f markdown+emoji \ $(SYNTAXFLAGS) \ - --filter $(LANGFILTER) --filter $(NICE_DATE) --mathjax + --filter $(LANGFILTER) --filter $(NICE_DATE) --filter $(SLUG_TAGS) \ + --mathjax endef @@ -89,6 +91,7 @@ $(LAANTAS_SCRIPT): lang/laantas-script/* ; $(call cabal-exe) $(ALL_TAGS): $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:) $(POST_LISTS): $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:) $(NICE_DATE): $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:) +$(SLUG_TAGS): $(BLOG_META_DEPS) ; $(call cabal-exe,blog-meta:) define cabal-exe @echo "[build] $(notdir $@)" diff --git a/blog-meta/all-tags.hs b/blog-meta/all-tags.hs index 1b94b22..a66f9f0 100644 --- a/blog-meta/all-tags.hs +++ b/blog-meta/all-tags.hs @@ -15,7 +15,6 @@ import qualified YAML import System.Environment import qualified Data.Text.IO as Text import qualified Data.Text as Text -import Data.Char main :: IO () @@ -36,8 +35,8 @@ getTags file = do 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)] + [("title" ##= YAML.str "all tags"), + ("all-tags" ##= collate tags)] makeMake :: [Set Text] -> Text makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where @@ -46,7 +45,7 @@ makeMake tags' = Text.unlines $ build : allPosts : map makeRule tags where t <- ["all-tags", "index"] <> map slug' tags] makeRule' opt title file = "$(TMPDIR)/" <> file <> ".md : $(POSTS) $(POST_LISTS)\n\ - \\t@echo \"[post-lists] $<\"\n\ + \\t@echo \"[post-lists] " <> file <> "\"\n\ \\t$(POST_LISTS) " <> opt <> " --out $@ \\\n\ \\t $(POSTSDIR) \"" <> title <> "\"" allPosts = makeRule' "" "all posts" "index" @@ -70,25 +69,19 @@ instance YAML.ToYAML Tag where [("name" ##= name), ("slug" ##= slug), ("count" ##= count)] collate :: [Set Text] -> [Tag] -collate tags₀ = - toList $ fst $ foldl' add1 (mempty, mempty) $ foldMap toList tags₀ +collate = + toList . foldl' add1 mempty . foldMap toList 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} + 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 { diff --git a/blog-meta/blog-meta.cabal b/blog-meta/blog-meta.cabal index 6e5895f..01655b1 100644 --- a/blog-meta/blog-meta.cabal +++ b/blog-meta/blog-meta.cabal @@ -50,3 +50,8 @@ executable nice-date import: deps, exe hs-source-dirs: . main-is: nice-date.hs + +executable slug-tags + import: deps, exe + hs-source-dirs: . + main-is: slug-tags.hs diff --git a/blog-meta/lib/Misc.hs b/blog-meta/lib/Misc.hs index ed47514..026d8bf 100644 --- a/blog-meta/lib/Misc.hs +++ b/blog-meta/lib/Misc.hs @@ -3,6 +3,10 @@ module Misc where import qualified System.Console.GetOpt as GetOpt import System.Environment import System.Exit +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Char (isAlphaNum, isAscii, toLower) +import Text.Pandoc.Definition -- | exception on 'Left' unwrap :: Show a => FilePath -> Either a b -> IO b @@ -20,3 +24,34 @@ getOptionsWith hdr mkDef descrs = do putStrLn $ GetOpt.usageInfo (hdr prog) descrs exitFailure +makeSlug :: Text -> Text +makeSlug name = Text.map toSlugChar name where + toSlugChar c + | isAlphaNum c && isAscii c || c == '-' = toLower c + | otherwise = '_' + + +toTextList :: MetaValue -> Maybe [Text] +toTextList (MetaList vs) = traverse toText vs +toTextList _ = Nothing + +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 diff --git a/blog-meta/nice-date.hs b/blog-meta/nice-date.hs index d9e5955..6ee5cd1 100644 --- a/blog-meta/nice-date.hs +++ b/blog-meta/nice-date.hs @@ -1,19 +1,16 @@ 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.Text (unpack, pack) import Data.Char (toLower) +import Misc main :: IO () main = toJSONFilter \(Pandoc (Meta m) body) -> do - m' <- niceDate m + m' <- Map.alterF reformat "date" 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 @@ -22,24 +19,3 @@ reformat (Just (toText -> Just txt)) = do 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 diff --git a/blog-meta/slug-tags.hs b/blog-meta/slug-tags.hs new file mode 100644 index 0000000..92d4be9 --- /dev/null +++ b/blog-meta/slug-tags.hs @@ -0,0 +1,21 @@ +import Text.Pandoc.Definition +import qualified Data.Map.Strict as Map +import Text.Pandoc.JSON +import Data.Text (Text) +import Misc + +main :: IO () +main = toJSONFilter \(Pandoc (Meta m) body) -> do + m' <- Map.alterF addSlugs "tags" m + pure $ Pandoc (Meta m') body + +addSlugs :: Maybe MetaValue -> IO (Maybe MetaValue) +addSlugs Nothing = pure Nothing +addSlugs (Just (toTextList -> Just tags)) = + pure $ Just $ MetaList $ map addSlug1 tags +addSlugs (Just t) = fail $ + "'tags' is\n" <> show t <> "\nwanted a list of strings" + +addSlug1 :: Text -> MetaValue +addSlug1 tag = MetaMap $ Map.fromList + [("name", MetaString tag), ("slug", MetaString $ makeSlug tag)] diff --git a/templates/meta.html b/templates/meta.html index 4369efe..cf9f9ba 100644 --- a/templates/meta.html +++ b/templates/meta.html @@ -8,7 +8,7 @@ $endif$ $if(posts)$ $postlist()$ -$elseif(tags)$ +$elseif(all-tags)$ $taglist()$ $endif$ diff --git a/templates/post.html b/templates/post.html index dd267d2..4023132 100644 --- a/templates/post.html +++ b/templates/post.html @@ -13,7 +13,7 @@ $head()$ tags: diff --git a/templates/taglist.html b/templates/taglist.html index 93cd239..4882947 100644 --- a/templates/taglist.html +++ b/templates/taglist.html @@ -1,6 +1,6 @@