gallery/make-pages/TagTransforms.hs

{-# LANGUAGE RecordWildCards #-}
module TagTransforms
  (TransformResult (..),
   TagWarning (..), showWarning, printWarning,
   matchWarning, applyImplies, applyTransforms1, applyTransforms,
   transformInfoTags)
where

import Info
import BuilderQQ qualified as Builder
import Control.Monad
import Data.Array (Array)
import Data.Array.Base ((!?))
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Text.Regex.TDFA qualified as Regex
import System.IO (hPutStrLn, stderr)
import Control.Applicative (Alternative(..), asum)
import Control.Monad.Writer.CPS


data TagWarning
  = ReplaceWarn Text Text
  | PresenceWarn Text
  | UndefinedCapture Int Text
  | ReplaceParseError Text
  deriving Show

data TransformResult = TR (HashSet Text) [TagWarning]
  deriving Show

instance Semigroup TransformResult where
  TR t1 w1 <> TR t2 w2 = TR (t1 <> t2) (w1 <> w2)
instance Monoid TransformResult where
  mempty = TR [] []

showWarning :: FilePath -> TagWarning -> String
showWarning file (ReplaceWarn from to) =
  file ++ ": contains tag " ++ show from ++
  " (replacing with " ++ show to ++ ")"
showWarning file (PresenceWarn what) =
  file ++ ": contains tag " ++ show what
showWarning file (UndefinedCapture i txt) =
  file ++ ": replacement string " ++ show txt ++
  " contains undefined capture group $" ++ show i
showWarning file (ReplaceParseError txt) =
  file ++ ": cannot parse replacement string " ++ show txt

printWarning :: FilePath -> TagWarning -> IO ()
printWarning f w =
  hPutStrLn stderr $ "[WARN] " ++ showWarning f w

matchWarning :: Text -> Warning -> Bool
matchWarning txt (RegexW _ rx) = Regex.match rx txt
matchWarning txt (LiteralW l)  = l == txt

applyImplies1 :: Array Int Text -> Replacement -> TransformResult
applyImplies1 subs (Re txt rhs) =
  case traverse app rhs of
    Left  i   -> TR [] [UndefinedCapture i txt]
    Right oks -> TR [Builder.toStrictText $ mconcat oks] []
 where
  app (Left  str) = Right $ Builder.build str
  app (Right i)   = case subs !? i of
    Just sub -> Right $ Builder.build sub
    Nothing  -> Left i

applyImplies :: Text -> Implies -> Maybe TransformResult
applyImplies tag (RegexI _ rx outs) =
  let res = Regex.mrSubs $ Regex.match rx tag in
  if null res then empty else pure $ foldMap (applyImplies1 res) outs
applyImplies tag (LiteralI str outs) =
  TR (HashSet.fromList outs) [] <$ guard (tag == str)

ifJust :: Applicative m => Maybe a -> (a -> m ()) -> m Bool
ifJust m f = maybe (pure False) (\x -> True <$ f x) m

applyTransforms1 :: TagTransforms -> Text -> TransformResult
applyTransforms1 t = execWriter . go where
  go tag = do
    replacedW <- ifJust (HashMap.lookup tag t.replaceWarn) \out -> do
      tell $ TR [] [ReplaceWarn tag out]
      go out
    replaced <- ifJust (HashMap.lookup tag t.replace) go
    unless (replacedW || replaced) do
      tell $ TR [tag] []
      when (any (matchWarning tag) t.warn) do
        tell $ TR [] [PresenceWarn tag]
      forM_ (asum $ map (applyImplies tag) t.implies) \(TR tags ws) -> do
        tell $ TR [] ws
        forM_ tags go

applyTransforms :: Foldable f => TagTransforms -> f Text -> TransformResult
applyTransforms t tags = foldMap (applyTransforms1 t) tags

transformInfoTags :: TagTransforms -> Info -> Info
transformInfoTags t (Info {..}) =
  let TR tags'     _ = applyTransforms t tags
      TR nsfwTags' _ = applyTransforms t nsfwTags in
  Info {
    tags     = HashSet.difference tags'     excludeTags,
    nsfwTags = HashSet.difference nsfwTags' excludeTags, ..
  }