[Test] Make 'test_mangle' not fail (#7297)

Author: effectfully

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

@@ -27,6 +27,7 @@ import Control.Monad.Except (modifyError)
 import Data.String (IsString (fromString))
 import Data.Text qualified as Text
 import Hedgehog (Gen, Property, forAll, property, tripping, (/==), (===))
+import Hedgehog.Gen qualified as Gen
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (testPropertyNamed)
 import Test.Tasty.HUnit (assertBool, testCase, (@?=))
@@ -53,9 +54,10 @@ test_DeBruijnInteresting =
 test_mangle :: TestTree
 test_mangle =
   testPropertyNamed "equality does not survive mangling" "equality_mangling" . property $ do
-    (term, termMangled) <- forAll . runAstGen $ do
+    (term, termMangled) <- forAll . runAstGen . Gen.justT $ do
       term <- AST.genTerm
-      (,) term <$> mangleNames term
+      mayTermMang <- mangleNames term
+      pure $ (,) term <$> mayTermMang
     term /== termMangled
     termMangled /== term
 

plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs

@@ -185,8 +185,12 @@ subset1 s
     where xs = Set.toList s
 
 -- See Note [Name mangling]
-genNameMangler :: Set Name -> AstGen (Name -> AstGen (Maybe Name))
-genNameMangler names = Gen.justT $ do
+-- Returns a 'Maybe' instead of doing 'Gen.justT' at the end so that if the original term is hard to
+-- mangle (few names and they clash with what 'genNames' produces), then the caller can pick a
+-- different term instead of repeatedly trying to mangle the original one until Hedgehog runs out of
+-- steam.
+genNameMangler :: Set Name -> AstGen (Maybe (Name -> AstGen (Maybe Name)))
+genNameMangler names = do
     mayNamesMangle <- subset1 names
     for mayNamesMangle $ \namesMangle -> do
         let isNew name = not $ name `Set.member` namesMangle
@@ -212,7 +216,7 @@ allTermNames = setOf $ vTerm <^> tvTerm . coerced
 -- See Note [Name mangling]
 mangleNames
     :: Term TyName Name DefaultUni DefaultFun ()
-    -> AstGen (Term TyName Name DefaultUni DefaultFun ())
+    -> AstGen (Maybe (Term TyName Name DefaultUni DefaultFun ()))
 mangleNames term = do
-    mang <- genNameMangler $ allTermNames term
-    substAllNames mang term
+    mayMang <- genNameMangler $ allTermNames term
+    for mayMang $ \mang -> substAllNames mang term

plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs

@@ -8,6 +8,8 @@ module UntypedPlutusCore.Generators.Hedgehog.AST
   , mangleNames
   ) where
 
+import PlutusPrelude
+
 import PlutusCore.Generators.Hedgehog.AST qualified as PLC
 
 import PlutusCore.Compiler.Erase
@@ -37,7 +39,9 @@ genProgram
 genProgram = fmap eraseProgram PLC.genProgram
 
 -- See Note [Name mangling]
-mangleNames :: Term Name DefaultUni DefaultFun () -> PLC.AstGen (Term Name DefaultUni DefaultFun ())
+mangleNames
+    :: Term Name DefaultUni DefaultFun ()
+    -> PLC.AstGen (Maybe (Term Name DefaultUni DefaultFun ()))
 mangleNames term = do
-    mang <- PLC.genNameMangler $ setOf vTerm term
-    termSubstNamesM (fmap (fmap $ UPLC.Var ()) . mang) term
+    mayMang <- PLC.genNameMangler $ setOf vTerm term
+    for mayMang $ \mang -> termSubstNamesM (fmap (fmap $ UPLC.Var ()) . mang) term

plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs

@@ -20,6 +20,7 @@ import PlutusCore.Rename
 import PlutusCore.Test qualified as T
 
 import Hedgehog
+import Hedgehog.Gen qualified as Gen
 import Test.Tasty
 import Test.Tasty.Hedgehog
 import Test.Tasty.HUnit
@@ -28,9 +29,10 @@ test_mangle :: TestTree
 test_mangle =
   testPropertyNamed "equality does not survive mangling" "equality_mangling" $
       withDiscards 1000000 . T.mapTestLimitAtLeast 300 (`div` 3) . property $ do
-          (term, termMangled) <- forAll . runAstGen $ do
+          (term, termMangled) <- forAll . runAstGen . Gen.justT $ do
             term <- genTerm
-            (,) term <$> mangleNames term
+            mayTermMang <- mangleNames term
+            pure $ (,) term <$> mayTermMang
           term /== termMangled
           termMangled /== term