fix tags with spaces

add a filter that replaces tags e.g.
"tag name" → {name: "tag name", slug: "tag_name"}

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 $@)"

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 {

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

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

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

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)]

templates/meta.html

@@ -8,7 +8,7 @@ $endif$
 
 $if(posts)$
 $postlist()$
-$elseif(tags)$
+$elseif(all-tags)$
 $taglist()$
 $endif$
 

templates/post.html

@@ -13,7 +13,7 @@ $head()$
       tags:
       <ul>
         $for(tags)$
-        <li><a href=/tag-$it$.html>$it$</a>
+        <li><a href=/tag-$it.slug$.html>$it.name$</a>
         $endfor$
       </ul>
     </nav>

templates/taglist.html

@@ -1,6 +1,6 @@
 <main>
   <ul class=tag-list>
-    $for(tags)$
+    $for(all-tags)$
     <li>
       <a href=tag-$it.slug$.html>$it.name$</a>
       <span class=count>($it.count$)</span>