103 lines
3.5 KiB
Haskell
103 lines
3.5 KiB
Haskell
{-# 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
|
|
|
|
|
|
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, ..
|
|
}
|