[Refac] Make UPLC and TPLC tests more uniform (#7159)

* [Refac] Make UPLC and TPLC tests more uniform

* Document 'regenConstantUntil'

* Fix warnings

Author: effectfully

plutus-core/plutus-core.cabal

@@ -459,7 +459,6 @@ library untyped-plutus-core-testlib
     Evaluation.Machines
     Evaluation.Regressions
     Flat.Spec
-    Generators.Lib
     Generators.Spec
     Scoping.Spec
     Transform.CaseOfCase.Spec
@@ -551,7 +550,6 @@ library plutus-ir
     PlutusIR.Transform.RewriteRules.CommuteFnWithConst
     PlutusIR.Transform.RewriteRules.RemoveTrace
     PlutusIR.Transform.StrictifyBindings
-    PlutusIR.Transform.Substitute
     PlutusIR.Transform.ThunkRecursions
     PlutusIR.Transform.Unwrap
     PlutusIR.TypeCheck
@@ -800,7 +798,7 @@ library plutus-core-testlib
     PlutusIR.Pass.Test
     PlutusIR.Test
     Test.Tasty.Extras
-    UntypedPlutusCore.Generators.Hedgehog
+    UntypedPlutusCore.Generators.Hedgehog.AST
     UntypedPlutusCore.Test.DeBruijn.Bad
     UntypedPlutusCore.Test.DeBruijn.Good
 

plutus-core/plutus-core/src/PlutusCore/Subst.hs

@@ -24,7 +24,10 @@ module PlutusCore.Subst
     , vTerm
     , tvTerm
     , tvTy
-    , purely
+    , substConstantA
+    , substConstant
+    , termSubstConstantsM
+    , termSubstConstants
     ) where
 
 import PlutusPrelude
@@ -37,8 +40,7 @@ import PlutusCore.Name.Unique (HasUnique)
 import PlutusCore.Name.UniqueSet (UniqueSet)
 import PlutusCore.Name.UniqueSet qualified as USet
 
-purely :: ((a -> Identity b) -> c -> Identity d) -> (a -> b) -> c -> d
-purely = coerce
+import Universe
 
 -- | Applicatively replace a type variable using the given function.
 substTyVarA
@@ -277,3 +279,34 @@ tvTerm = termSubtypesDeep . typeTyVars
 -- | Get all the type variables in a type.
 tvTy :: Fold (Type tyname uni ann) tyname
 tvTy = typeSubtypesDeep . typeTyVars
+
+-- | Applicatively replace a constant using the given function.
+substConstantA
+    :: Applicative f
+    => (ann -> Some (ValueOf uni) -> f (Maybe (Term tyname name uni fun ann)))
+    -> Term tyname name uni fun ann
+    -> f (Term tyname name uni fun ann)
+substConstantA valF t@(Constant ann val) = fromMaybe t <$> valF ann val
+substConstantA _    t                    = pure t
+
+-- | Replace a constant using the given function.
+substConstant
+    :: (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann))
+    -> Term tyname name uni fun ann
+    -> Term tyname name uni fun ann
+substConstant = purely (substConstantA . curry) . uncurry
+
+-- | Monadically substitute constants using the given function.
+termSubstConstantsM
+    :: Monad m
+    => (ann -> Some (ValueOf uni) -> m (Maybe (Term tyname name uni fun ann)))
+    -> Term tyname name uni fun ann
+    -> m (Term tyname name uni fun ann)
+termSubstConstantsM = transformMOf termSubterms . substConstantA
+
+-- | Substitute constants using the given function.
+termSubstConstants
+    :: (ann -> Some (ValueOf uni) -> Maybe (Term tyname name uni fun ann))
+    -> Term tyname name uni fun ann
+    -> Term tyname name uni fun ann
+termSubstConstants = purely (termSubstConstantsM . curry) . uncurry

plutus-core/plutus-core/test/Names/Spec.hs

@@ -26,8 +26,7 @@ import PlutusCore.Test (BindingRemoval (BindingRemovalNotOk), Prerename (Prerena
 import Control.Monad.Except (modifyError)
 import Data.String (IsString (fromString))
 import Data.Text qualified as Text
-import Hedgehog (Gen, Property, assert, forAll, property, tripping)
-import Hedgehog.Gen qualified as Gen
+import Hedgehog (Gen, Property, forAll, property, tripping, (/==), (===))
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (testPropertyNamed)
 import Test.Tasty.HUnit (assertBool, testCase, (@?=))
@@ -53,24 +52,23 @@ test_DeBruijnInteresting =
 
 test_mangle :: TestTree
 test_mangle =
-  testPropertyNamed "equality does not survive mangling" "equality_mangling" $ property do
-    (term, termMangled) <- forAll . Gen.just $ runAstGen do
+  testPropertyNamed "equality does not survive mangling" "equality_mangling" . property $ do
+    (term, termMangled) <- forAll . runAstGen $ do
       term <- AST.genTerm
-      mayTermMang <- mangleNames term
-      pure $ do
-        termMang <- mayTermMang
-        Just (term, termMang)
-    assert $ term /= termMangled && termMangled /= term
+      (,) term <$> mangleNames term
+    term /== termMangled
+    termMangled /== term
 
 -- | Test equality of a program and its renamed version, given a renamer.
 prop_equalityFor
-  :: (program ~ Program TyName Name DefaultUni DefaultFun ())
+  :: program ~ Program TyName Name DefaultUni DefaultFun ()
   => (program -> Quote program)
   -> Property
 prop_equalityFor ren = property do
   prog <- forAllPretty $ runAstGen genProgram
   let progRen = runQuote $ ren prog
-  assert $ progRen == prog && prog == progRen
+  progRen === prog
+  prog === progRen
 
 test_equalityRename :: TestTree
 test_equalityRename =

plutus-core/plutus-core/test/Parser/Spec.hs

@@ -20,7 +20,7 @@ import Test.Tasty.Hedgehog
 propTermSrcSpan :: Property
 propTermSrcSpan = property $ do
     term <- _progTerm <$>
-        forAllWith display (runAstGen $ discardIfAnyConstant (not . isSerialisable) genProgram)
+        forAllWith display (runAstGen $ regenConstantsUntil isSerialisable =<< genProgram)
     let code = display (term :: Term TyName Name DefaultUni DefaultFun ())
     let (endingLine, endingCol) = length &&& T.length . last $ T.lines code
     trailingSpaces <- forAll $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n'])

plutus-core/plutus-core/test/Spec.hs

@@ -65,83 +65,10 @@ main = do
       includingOptions [Option $ Proxy @NEAT.GenMode, Option $ Proxy @NEAT.GenDepth]
         : defaultIngredients
 
-compareName :: Name -> Name -> Bool
-compareName = (==) `on` _nameText
-
-compareTyName :: TyName -> TyName -> Bool
-compareTyName (TyName n) (TyName n') = compareName n n'
-
-compareTerm ::
-  (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq a) =>
-  Term TyName Name uni fun a ->
-  Term TyName Name uni fun a ->
-  Bool
-compareTerm (Var _ n) (Var _ n') = compareName n n'
-compareTerm (TyAbs _ n k t) (TyAbs _ n' k' t') =
-  compareTyName n n' && k == k' && compareTerm t t'
-compareTerm (LamAbs _ n ty t) (LamAbs _ n' ty' t') =
-  compareName n n' && compareType ty ty' && compareTerm t t'
-compareTerm (Apply _ t t'') (Apply _ t' t''') =
-  compareTerm t t' && compareTerm t'' t'''
-compareTerm (Constant _ x) (Constant _ y) = x == y
-compareTerm (Builtin _ bi) (Builtin _ bi') = bi == bi'
-compareTerm (TyInst _ t ty) (TyInst _ t' ty') =
-  compareTerm t t' && compareType ty ty'
-compareTerm (Unwrap _ t) (Unwrap _ t') = compareTerm t t'
-compareTerm (IWrap _ pat1 arg1 t1) (IWrap _ pat2 arg2 t2) =
-  compareType pat1 pat2 && compareType arg1 arg2 && compareTerm t1 t2
-compareTerm (Constr _ ty i es) (Constr _ ty' i' es') =
-  compareType ty ty' && i == i' && maybe False (all (uncurry compareTerm)) (zipExact es es')
-compareTerm (Case _ ty arg cs) (Case _ ty' arg' cs') =
-  compareType ty ty'
-    && compareTerm arg arg'
-    && maybe False (all (uncurry compareTerm)) (zipExact cs cs')
-compareTerm (Error _ ty) (Error _ ty') = compareType ty ty'
-compareTerm _ _ = False
-
-compareType ::
-  (GEq uni, Closed uni, uni `Everywhere` Eq, Eq a) =>
-  Type TyName uni a ->
-  Type TyName uni a ->
-  Bool
-compareType (TyVar _ n) (TyVar _ n') = compareTyName n n'
-compareType (TyFun _ t s) (TyFun _ t' s') =
-  compareType t t' && compareType s s'
-compareType (TyIFix _ pat1 arg1) (TyIFix _ pat2 arg2) =
-  compareType pat1 pat2 && compareType arg1 arg2
-compareType (TyForall _ n k t) (TyForall _ n' k' t') =
-  compareTyName n n' && k == k' && compareType t t'
-compareType (TyBuiltin _ x) (TyBuiltin _ y) = x == y
-compareType (TyLam _ n k t) (TyLam _ n' k' t') =
-  compareTyName n n' && k == k' && compareType t t'
-compareType (TyApp _ t t') (TyApp _ t'' t''') =
-  compareType t t'' && compareType t' t'''
-compareType (TySOP _ tyls) (TySOP _ tyls') =
-  maybe
-    False
-    (all (\(tyl1, tyl2) -> maybe False (all (uncurry compareType)) (zipExact tyl1 tyl2)))
-    (zipExact tyls tyls')
-compareType _ _ = False
-
-compareProgram ::
-  (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq a) =>
-  Program TyName Name uni fun a ->
-  Program TyName Name uni fun a ->
-  Bool
-compareProgram (Program _ v t) (Program _ v' t') = v == v' && compareTerm t t'
-
--- | A 'Program' which we compare using textual equality of names rather than alpha-equivalence.
-newtype TextualProgram a = TextualProgram
-  {unTextualProgram :: Program TyName Name DefaultUni DefaultFun a}
-  deriving stock (Show)
-
-instance (Eq a) => Eq (TextualProgram a) where
-  (TextualProgram p1) == (TextualProgram p2) = compareProgram p1 p2
-
 propFlat :: Property
 propFlat = property $ do
   prog <- forAllPretty . runAstGen $
-    discardIfAnyConstant (not . isSerialisable) $ genProgram @DefaultFun
+    regenConstantsUntil isSerialisable =<< genProgram @DefaultFun
   Hedgehog.tripping prog Flat.flat Flat.unflat
 
 {- The following tests check that (A) the parser can
@@ -223,18 +150,11 @@ text, hopefully returning the same thing.
 -}
 propParser :: Property
 propParser = property $ do
-  prog <- TextualProgram <$>
-    forAllPretty (runAstGen $ discardIfAnyConstant (not . isSerialisable) genProgram)
-  Hedgehog.tripping
-    prog
-    (displayPlc . unTextualProgram)
-    (\p -> fmap (TextualProgram . void) (parseProg p))
+  prog <- forAllPretty . runAstGen $ regenConstantsUntil isSerialisable =<< genProgram
+  Hedgehog.tripping prog displayPlc (fmap void . parseProg)
   where
     parseProg ::
-      T.Text ->
-      Either
-        ParserErrorBundle
-        (Program TyName Name DefaultUni DefaultFun SrcSpan)
+      T.Text -> Either ParserErrorBundle (Program TyName Name DefaultUni DefaultFun SrcSpan)
     parseProg = runQuoteT . parseProgram
 
 type TestFunction = T.Text -> Either DefaultError T.Text

plutus-core/plutus-ir/src/PlutusIR/Compiler/Datatype.hs

@@ -23,7 +23,7 @@ import PlutusIR.Compiler.Provenance
 import PlutusIR.Compiler.Types
 import PlutusIR.Error
 import PlutusIR.MkPir qualified as PIR
-import PlutusIR.Transform.Substitute
+import PlutusIR.Subst
 
 import PlutusCore.Core qualified as PLC
 import PlutusCore.MkPlc qualified as PLC