add tag transforms to index.yaml (unused yet)

make-pages/Info.hs

@@ -28,29 +28,33 @@ module Info
 where
 
 import Date
-import GHC.Records
-
 import Control.Applicative
-import Control.Monad
 import Control.Exception
+import Control.Monad
+import Data.Bitraversable (bitraverse)
 import Data.Foldable (find)
-import Data.Hashable (Hashable)
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
 import Data.HashSet (HashSet)
-import qualified Data.HashSet as HashSet
+import Data.HashSet qualified as HashSet
-import qualified Data.Map.Strict as Map
+import Data.Hashable (Hashable (..))
-import Data.Set (Set, (\\))
-import qualified Data.Set as Set
-import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe, catMaybes)
 import Data.List (sortBy)
 import Data.List.NonEmpty (NonEmpty (..), toList, nonEmpty)
+import Data.Map.Strict qualified as Map
+import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe, catMaybes)
 import Data.Ord (comparing)
+import Data.Semigroup
+import Data.Set (Set, (\\))
+import Data.Set qualified as Set
 import Data.String (IsString)
 import Data.Text (Text)
-import qualified Data.Text as Text
+import Data.Text qualified as Text
 import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
-import qualified Data.YAML as YAML
+import Data.YAML qualified as YAML
+import GHC.Records
 import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
-import Data.Semigroup
+import Text.Regex.TDFA (Regex)
+import Text.Regex.TDFA qualified as Regex
 
 
 data Info =
@@ -519,18 +523,68 @@ data IndexInfo =
     desc      :: !Text,
     galleries :: ![GalleryInfo],
     links     :: ![Link],
-    footer    :: !(Maybe Text)
+    footer    :: !(Maybe Text),
+    tags      :: !TagTransforms
   }
   deriving Show
 
 instance FromYAML IndexInfo where
   parseYAML = YAML.withMap "index info" \m -> do
-    checkKeys m ["title", "desc", "galleries", "links", "footer"]
+    checkKeys m ["title", "desc", "galleries", "links", "footer", "tags"]
     IndexInfo <$> m .:  "title"
               <*> m .:  "desc"
               <*> m .:? "galleries" .!= []
               <*> m .:? "links"     .!= []
               <*> m .:? "footer"
+              <*> m .:? "tags"      .!= emptyTransforms
+
+data TagTransforms =
+  TagTransforms {
+    implies     :: !(HashMap ImpliesKey [Text]),
+    replace     :: !(HashMap Text Text),
+    replaceWarn :: !(HashMap Text Text),
+    warn        :: !(HashSet Text)
+  }
+  deriving Show
+
+data ImpliesKey = RegexIK Text Regex | LiteralIK Text
+
+instance Eq ImpliesKey where
+  RegexIK s _ == RegexIK t _ = s == t
+  LiteralIK s == LiteralIK t = s == t
+  _           == _           = False
+
+instance Show ImpliesKey where
+  showsPrec d (RegexIK s _) =
+    showParen (d > 10) $
+      showString "RegexIK " . showsPrec 11 s . showString " _"
+  showsPrec d (LiteralIK s) =
+    showParen (d > 10) $ showString "LiteralIK " . showsPrec 11 s
+
+instance Hashable ImpliesKey where
+  hashWithSalt s (RegexIK   str _) = hashWithSalt s ('R', str)
+  hashWithSalt s (LiteralIK str)   = hashWithSalt s ('L', str)
+
+emptyTransforms :: TagTransforms
+emptyTransforms = TagTransforms [] [] [] []
+
+instance FromYAML TagTransforms where
+  parseYAML = YAML.withMap "tag transforms" \m -> do
+    checkKeys m ["implies", "replace", "replace-warn", "warn"]
+    TagTransforms <$> m .:? "implies"      .!= []
+                  <*> m .:? "replace"      .!= []
+                  <*> m .:? "replace-warn" .!= []
+                  <*> m .:? "warn"         .!= []
+
+instance FromYAML ImpliesKey where
+  parseYAML = YAML.withStr "string or regex" \str -> pure
+    if Text.length str > 2  &&
+       Text.head str == '/' &&
+       Text.last str == '/'
+    then
+      let body = Text.drop 1 $ Text.dropEnd 1 str in
+      RegexIK body (Regex.makeRegex body)
+    else LiteralIK str
 
 
 data Pair a b = Pair !a !b
@@ -557,3 +611,10 @@ instance {-# OVERLAPPING #-} FromYAML String where
 
 instance (FromYAML a, Eq a, Hashable a) => FromYAML (HashSet a) where
   parseYAML y = HashSet.fromList <$> parseYAML y
+
+instance (FromYAML k, Eq k, Hashable k, FromYAML v) =>
+         FromYAML (HashMap k v) where
+  parseYAML = YAML.withMap "mapping" $
+    fmap HashMap.fromList .
+    traverse (bitraverse parseYAML parseYAML) .
+    Map.toList

make-pages/make-pages.cabal

@@ -52,6 +52,7 @@ executable make-pages
     HsYAML               ^>= 0.2.1.0,
     optparse-applicative ^>= 0.15.1.0,
     process              ^>= 1.6.8.2,
+    regex-tdfa            == 1.3.2.*,
     template-haskell      >= 2.18.0.0 && < 2.23,
     text                  >= 1.2.3.1  && < 2.2,
     time                  >= 1.8.0.2  && < 1.13,