[Test] Add do-notation support for 'TestNested'

plutus-benchmark/lists/test/Lookup/Spec.hs

@@ -1,20 +1,20 @@
 module Lookup.Spec (tests) where
 
 import Test.Tasty
-import Test.Tasty.Extras (TestNested, runTestGroupNestedGhc)
+import Test.Tasty.Extras (TestNested, runTestNested, testNestedGhc)
 
 import PlutusBenchmark.Lists.Lookup.Compiled qualified as Compiled
 
 import PlutusTx.Test qualified as Tx
 
 -- Make a set of golden tests with results stored in a given subdirectory
 -- inside a subdirectory determined by the GHC version.
-testGroupGhcIn :: [FilePath] -> [TestNested] -> TestTree
-testGroupGhcIn dir = runTestGroupNestedGhc (["lists", "test"] ++ dir)
+runTestGhc :: [FilePath] -> [TestNested] -> TestTree
+runTestGhc path = runTestNested (["lists", "test"] ++ path) . pure . testNestedGhc
 
 tests :: TestTree
 tests =
-  testGroupGhcIn ["Lookup"] $
+  runTestGhc ["Lookup"] $
     flip concatMap sizes $ \sz ->
       [ Tx.goldenBudget ("match-scott-list-" ++ show sz) $
         Compiled.mkMatchWithListsCode (Compiled.workloadOfSize sz)

plutus-benchmark/lists/test/Sum/Spec.hs

@@ -2,7 +2,7 @@
 module Sum.Spec (tests) where
 
 import Test.Tasty
-import Test.Tasty.Extras (TestNested, runTestGroupNestedGhc)
+import Test.Tasty.Extras (TestNested, runTestNested, testNestedGhc)
 import Test.Tasty.QuickCheck
 
 import PlutusBenchmark.Common (Term, cekResultMatchesHaskellValue)
@@ -14,8 +14,8 @@ import PlutusTx.Test qualified as Tx
 
 -- Make a set of golden tests with results stored in a given subdirectory
 -- inside a subdirectory determined by the GHC version.
-testGroupGhcIn :: [FilePath] -> [TestNested] -> TestTree
-testGroupGhcIn dir = runTestGroupNestedGhc (["lists", "test"] ++ dir)
+runTestGhc :: [FilePath] -> [TestNested] -> TestTree
+runTestGhc path = runTestNested (["lists", "test"] ++ path) . pure . testNestedGhc
 
 -- | Check that the various summation functions all give the same result as 'sum'
 
@@ -37,7 +37,7 @@ tests =
       , testProperty "Compiled left fold (built-in lists)"     $ prop_sum Compiled.mkSumLeftBuiltinTerm
       , testProperty "Compiled left fold (data lists)"         $ prop_sum Compiled.mkSumLeftDataTerm
       ]
-    , testGroupGhcIn ["Sum"]
+    , runTestGhc ["Sum"]
       [ Tx.goldenBudget "right-fold-scott"    $ Compiled.mkSumRightScottCode input
       , Tx.goldenBudget "right-fold-built-in" $ Compiled.mkSumRightBuiltinCode input
       , Tx.goldenBudget "right-fold-data"     $ Compiled.mkSumRightDataCode input

plutus-benchmark/marlowe/test/Spec.hs

@@ -4,7 +4,7 @@
 module Main (main) where
 
 import Test.Tasty
-import Test.Tasty.Extras (TestNested, runTestGroupNestedGhc)
+import Test.Tasty.Extras (TestNested, runTestNested, testNestedGhc)
 
 import PlutusBenchmark.Marlowe.BenchUtil (benchmarkToUPLC, rolePayoutBenchmarks,
                                           semanticsBenchmarks)
@@ -30,8 +30,8 @@ mkBudgetTest validator bm@M.Benchmark{..} =
 
 -- Make a set of golden tests with results stored in a given subdirectory
 -- inside a subdirectory determined by the GHC version.
-testGroupGhcIn :: [FilePath] -> [TestNested] -> TestTree
-testGroupGhcIn path = runTestGroupNestedGhc (["marlowe", "test"] ++ path)
+runTestGhc :: [FilePath] -> [TestNested] -> TestTree
+runTestGhc path = runTestNested (["marlowe", "test"] ++ path) . pure . testNestedGhc
 
 main :: IO ()
 main = do
@@ -45,13 +45,13 @@ main = do
   let allTests :: TestTree
       allTests =
         testGroup "plutus-benchmark Marlowe tests"
-            [ testGroupGhcIn ["semantics"] $
+            [ runTestGhc ["semantics"] $
                 goldenSize "semantics" marloweValidator
                   : [ goldenUEvalBudget name [value]
                     | bench <- semanticsMBench
                     , let (name, value) = mkBudgetTest marloweValidator bench
                     ]
-            , testGroupGhcIn ["role-payout"] $
+            , runTestGhc ["role-payout"] $
                 goldenSize "role-payout" rolePayoutValidator
                   : [ goldenUEvalBudget name [value]
                     | bench <- rolePayoutMBench

plutus-benchmark/nofib/test/Spec.hs

@@ -8,7 +8,7 @@ run to completion. -}
 module Main where
 
 import Test.Tasty
-import Test.Tasty.Extras (TestNested, runTestGroupNestedGhc)
+import Test.Tasty.Extras (TestNested, runTestNested, testNestedGhc)
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 
@@ -26,8 +26,8 @@ import PlutusTx.Test qualified as Tx
 
 -- Make a set of golden tests with results stored in subdirectories determined
 -- by the GHC version.
-testGroupGhc :: [TestNested] -> TestTree
-testGroupGhc = runTestGroupNestedGhc ["nofib", "test"]
+runTestGhc :: [TestNested] -> TestTree
+runTestGhc = runTestNested ["nofib", "test"] . pure . testNestedGhc
 
 -- Unit tests comparing PLC and Haskell computations on given inputs
 
@@ -47,7 +47,7 @@ testClausify = testGroup "clausify"
                , testCase "formula3" $ mkClausifyTest Clausify.F3
                , testCase "formula4" $ mkClausifyTest Clausify.F4
                , testCase "formula5" $ mkClausifyTest Clausify.F5
-               , testGroupGhc
+               , runTestGhc
                      [ Tx.goldenPirReadable "clausify-F5" formula5example
                      , Tx.goldenSize "clausify-F5" formula5example
                      , Tx.goldenBudget "clausify-F5" formula5example
@@ -70,7 +70,7 @@ testKnights = testGroup "knights"  -- Odd sizes call "error" because there are n
               , testCase "depth 100, 4x4" $ mkKnightsTest 100 4
               , testCase "depth 100, 6x6" $ mkKnightsTest 100 6
               , testCase "depth 100, 8x8" $ mkKnightsTest 100 8
-              , testGroupGhc
+              , runTestGhc
                     [ Tx.goldenPirReadable "knights10-4x4" knightsExample
                     , Tx.goldenSize "knights10-4x4" knightsExample
                     , Tx.goldenBudget "knights10-4x4" knightsExample
@@ -93,7 +93,7 @@ testQueens = testGroup "queens"
                , testCase "Bjbt1" $ mkQueensTest 4 Queens.Bjbt1
                , testCase "Bjbt2" $ mkQueensTest 4 Queens.Bjbt2
                , testCase "Fc"    $ mkQueensTest 4 Queens.Fc
-               , testGroupGhc
+               , runTestGhc
                      [ Tx.goldenPirReadable "queens4-bt" queens4btExample
                      , Tx.goldenSize "queens4-bt" queens4btExample
                      , Tx.goldenBudget "queens4-bt" queens4btExample
@@ -106,7 +106,7 @@ testQueens = testGroup "queens"
                , testCase "Bjbt1" $ mkQueensTest 5 Queens.Bjbt1
                , testCase "Bjbt2" $ mkQueensTest 5 Queens.Bjbt2
                , testCase "Fc"    $ mkQueensTest 5 Queens.Fc
-               , testGroupGhc
+               , runTestGhc
                      [ Tx.goldenPirReadable "queens5-fc" queens5fcExample
                      , Tx.goldenSize "queens5-fc" queens5fcExample
                      , Tx.goldenBudget "queens5-fc" queens5fcExample

plutus-benchmark/script-contexts/test/Spec.hs

@@ -5,7 +5,7 @@ module Main (main) where
 import Data.Text qualified as Text
 
 import Test.Tasty
-import Test.Tasty.Extras (TestNested, runTestGroupNestedGhc)
+import Test.Tasty.Extras (TestNested, runTestNested, testNestedGhc)
 import Test.Tasty.HUnit
 
 import PlutusBenchmark.Common (Term, compiledCodeToTerm, runTermCek, unsafeRunTermCek)
@@ -17,8 +17,8 @@ import PlutusTx.Test qualified as Tx
 
 -- Make a set of golden tests with results stored in subdirectories determined
 -- by the GHC version.
-testGroupGhc :: [TestNested] -> TestTree
-testGroupGhc = runTestGroupNestedGhc ["script-contexts", "test"]
+runTestGhc :: [TestNested] -> TestTree
+runTestGhc = runTestNested ["script-contexts", "test"] . pure . testNestedGhc
 
 assertSucceeded :: Term -> Assertion
 assertSucceeded t =
@@ -43,7 +43,7 @@ testCheckSc1 = testGroup "checkScriptContext1"
         compiledCodeToTerm $ mkCheckScriptContext1Code (mkScriptContext 4)
     , testCase "fails on 5" . assertFailed $
         compiledCodeToTerm $ mkCheckScriptContext1Code (mkScriptContext 5)
-    , testGroupGhc [ Tx.goldenSize "checkScriptContext1" $
+    , runTestGhc [ Tx.goldenSize "checkScriptContext1" $
                         mkCheckScriptContext1Code (mkScriptContext 1)
                    , Tx.goldenPirReadable "checkScriptContext1" $
                         mkCheckScriptContext1Code (mkScriptContext 1)
@@ -64,7 +64,7 @@ testCheckSc2 = testGroup "checkScriptContext2"
           compiledCodeToTerm $ mkCheckScriptContext2Code (mkScriptContext 4)
     , testCase "succeed on 5" . assertSucceeded $
           compiledCodeToTerm $ mkCheckScriptContext2Code (mkScriptContext 5)
-    , testGroupGhc [ Tx.goldenSize "checkScriptContext2" $
+    , runTestGhc [ Tx.goldenSize "checkScriptContext2" $
                         mkCheckScriptContext2Code (mkScriptContext 1)
                    , Tx.goldenPirReadable "checkScriptContext2" $
                         mkCheckScriptContext2Code (mkScriptContext 1)
@@ -81,7 +81,7 @@ testCheckSc2 = testGroup "checkScriptContext2"
 
 testCheckScEquality :: TestTree
 testCheckScEquality = testGroup "checkScriptContextEquality"
-    [ testGroupGhc [ Tx.goldenBudget "checkScriptContextEqualityData-20" $
+    [ runTestGhc [ Tx.goldenBudget "checkScriptContextEqualityData-20" $
                         mkScriptContextEqualityDataCode (mkScriptContext 20)
                    , Tx.goldenEvalCekCatch "checkScriptContextEqualityData-20" $
                         [mkScriptContextEqualityDataCode (mkScriptContext 20)]

plutus-core/executables/src/PlutusCore/Executable/Common.hs

@@ -71,7 +71,6 @@ import PlutusIR.Parser qualified as PIR (parse, program)
 import Control.Monad.Except
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as BSL
-import Data.Foldable (traverse_)
 import Data.HashMap.Monoidal qualified as H
 import Data.Kind (Type)
 import Data.List (intercalate)

plutus-core/plutus-core.cabal

@@ -816,6 +816,7 @@ library plutus-core-testlib
     , data-default-class
     , dependent-map                         >=0.4.0.0
     , filepath
+    , free
     , hashable
     , hedgehog                              >=1.0
     , lazy-search

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

@@ -29,7 +29,7 @@ module PlutusCore.MkPlc
     , mkTyVar
     , tyDeclVar
     , Def (..)
-    , embed
+    , embedTerm
     , TermDef
     , TypeDef
     , FunctionType (..)
@@ -121,20 +121,20 @@ instance TermLike (Term tyname name uni fun) tyname name uni fun where
     constr   = Constr
     kase     = Case
 
-embed :: TermLike term tyname name uni fun => Term tyname name uni fun ann -> term ann
-embed = \case
+embedTerm :: TermLike term tyname name uni fun => Term tyname name uni fun ann -> term ann
+embedTerm = \case
     Var a n           -> var a n
-    TyAbs a tn k t    -> tyAbs a tn k (embed t)
-    LamAbs a n ty t   -> lamAbs a n ty (embed t)
-    Apply a t1 t2     -> apply a (embed t1) (embed t2)
+    TyAbs a tn k t    -> tyAbs a tn k (embedTerm t)
+    LamAbs a n ty t   -> lamAbs a n ty (embedTerm t)
+    Apply a t1 t2     -> apply a (embedTerm t1) (embedTerm t2)
     Constant a c      -> constant a c
     Builtin a bi      -> builtin a bi
-    TyInst a t ty     -> tyInst a (embed t) ty
+    TyInst a t ty     -> tyInst a (embedTerm t) ty
     Error a ty        -> error a ty
-    Unwrap a t        -> unwrap a (embed t)
-    IWrap a ty1 ty2 t -> iWrap a ty1 ty2 (embed t)
-    Constr a ty i es  -> constr a ty i (fmap embed es)
-    Case a ty arg cs  -> kase a ty (embed arg) (fmap embed cs)
+    Unwrap a t        -> unwrap a (embedTerm t)
+    IWrap a ty1 ty2 t -> iWrap a ty1 ty2 (embedTerm t)
+    Constr a ty i es  -> constr a ty i (fmap embedTerm es)
+    Case a ty arg cs  -> kase a ty (embedTerm arg) (fmap embedTerm cs)
 
 -- | Make a 'Var' referencing the given 'VarDecl'.
 mkVar :: TermLike term tyname name uni fun => ann -> VarDecl tyname name uni ann -> term ann

plutus-core/plutus-core/test/Pretty/Readable.hs

@@ -31,8 +31,7 @@ test_PrettyReadable =
   where
     folder :: Pretty fun => PlcFolderContents DefaultUni fun -> TestTree
     folder
-        = runTestNestedIn ["plutus-core", "test", "Pretty", "Golden"]
-        . testNested "Readable"
+        = runTestNested ["plutus-core", "test", "Pretty", "Golden", "Readable"]
         . foldPlcFolderContents testNested testReadable testReadable
 
 test_Pretty :: TestTree

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

@@ -36,7 +36,6 @@ import PlutusCore.Test
 
 import Control.Monad.Except
 import Data.ByteString.Lazy qualified as BSL
-import Data.Foldable (for_)
 import Data.Proxy
 import Data.Text qualified as T
 import Data.Text.Encoding (encodeUtf8)

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

@@ -67,8 +67,7 @@ foldAssertWell
     -> PlcFolderContents DefaultUni fun
     -> TestTree
 foldAssertWell semvar
-    = runTestNestedIn ["plutus-core", "test", "TypeSynthesis"]
-    . testNested "Golden"
+    = runTestNested ["plutus-core", "test", "TypeSynthesis", "Golden"]
     . foldPlcFolderContents testNested
         (\name -> nestedGoldenVsErrorOrThing name . kindcheck)
         (\name -> nestedGoldenVsErrorOrThing name . typecheck semvar)
@@ -126,29 +125,28 @@ test_typecheckIllTyped =
                 TypeErrorE (NameMismatch {}) -> True
                 _                            -> False
             ]
-
 test_typecheckAllFun
-    :: forall fun. (ToBuiltinMeaning DefaultUni fun, Show fun)
+    :: forall fun. (ToBuiltinMeaning DefaultUni fun, Show fun, Show (BuiltinSemanticsVariant fun))
     => String
     -> BuiltinSemanticsVariant fun
-    -> TestTree
-test_typecheckAllFun name semvar
-    = runTestNestedIn ["plutus-core", "test", "TypeSynthesis", "Golden"]
-    . testNested name
+    -> TestNested
+test_typecheckAllFun name semVar
+    = testNestedNamed name (show semVar)
     . map testFun
     $ enumerate @fun
   where
     testFun fun =
-        nestedGoldenVsErrorOrThing (show fun) . kindcheck $ typeOfBuiltinFunction semvar fun
+        nestedGoldenVsErrorOrThing (show fun) . kindcheck $ typeOfBuiltinFunction semVar fun
 
 test_typecheckDefaultFuns :: TestTree
 test_typecheckDefaultFuns =
     -- This checks that for each set of builtins the Plutus type of every builtin is the same
     -- regardless of versioning.
-    testGroup "builtins" $ concat
-        [ map (test_typecheckAllFun @DefaultFun "DefaultFun") enumerate
-        , map (test_typecheckAllFun @ExtensionFun "ExtensionFun") enumerate
-        ]
+    testGroup "builtins" . pure $
+        runTestNested ["plutus-core", "test", "TypeSynthesis", "Golden"] $ concat
+            [ map (test_typecheckAllFun @DefaultFun "DefaultFun") enumerate
+            , map (test_typecheckAllFun @ExtensionFun "ExtensionFun") enumerate
+            ]
 
 test_typecheck :: TestTree
 test_typecheck =

plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs

@@ -13,8 +13,8 @@ import PlutusIR.Test
 import PlutusPrelude
 
 test_retainedSize :: TestTree
-test_retainedSize = runTestNestedIn ["plutus-ir", "test", "PlutusIR", "Analysis"] $
-    testNested "RetainedSize" $
+test_retainedSize =
+    runTestNested ["plutus-ir", "test", "PlutusIR", "Analysis", "RetainedSize"] $
         map
             (goldenPir renameAndAnnotate pTerm)
             [ "typeLet"

plutus-core/plutus-ir/test/PlutusIR/Compiler/Datatype/Tests.hs

@@ -8,15 +8,15 @@ import Test.Tasty.Extras
 
 test_datatypes :: TestTree
 test_datatypes =
-    runTestNestedIn ["plutus-ir", "test", "PlutusIR", "Compiler"] $ testNested "Datatype"
-    [ goldenPlcFromPir pTermAsProg "maybe"
-    , goldenPlcFromPir pTermAsProg "listMatch"
-    , goldenPlcFromPir pTermAsProg "idleAll"
-    , goldenPlcFromPir pTermAsProg "some"
-    , goldenEvalPir pTermAsProg "listMatchEval"
-    , goldenTypeFromPir topSrcSpan pTerm "dataEscape"
-    , testNested "scott"
-        [ goldenPlcFromPirScott pTermAsProg "maybe"
-        , goldenPlcFromPirScott pTermAsProg "listMatch"
+    runTestNested ["plutus-ir", "test", "PlutusIR", "Compiler", "Datatype"]
+        [ goldenPlcFromPir pTermAsProg "maybe"
+        , goldenPlcFromPir pTermAsProg "listMatch"
+        , goldenPlcFromPir pTermAsProg "idleAll"
+        , goldenPlcFromPir pTermAsProg "some"
+        , goldenEvalPir pTermAsProg "listMatchEval"
+        , goldenTypeFromPir topSrcSpan pTerm "dataEscape"
+        , testNested "scott"
+            [ goldenPlcFromPirScott pTermAsProg "maybe"
+            , goldenPlcFromPirScott pTermAsProg "listMatch"
+            ]
         ]
-    ]

plutus-core/plutus-ir/test/PlutusIR/Compiler/Error/Tests.hs

@@ -6,7 +6,8 @@ import Test.Tasty
 import Test.Tasty.Extras
 
 test_error :: TestTree
-test_error = runTestNestedIn ["plutus-ir", "test", "PlutusIR", "Compiler"] $ testNested "Error"
-    [ goldenPlcFromPir pTermAsProg "mutuallyRecursiveTypes"
-    , goldenPlcFromPir pTermAsProg "recursiveTypeBind"
-    ]
+test_error =
+    runTestNested ["plutus-ir", "test", "PlutusIR", "Compiler", "Error"]
+        [ goldenPlcFromPir pTermAsProg "mutuallyRecursiveTypes"
+        , goldenPlcFromPir pTermAsProg "recursiveTypeBind"
+        ]

plutus-core/plutus-ir/test/PlutusIR/Compiler/Let/Tests.hs

@@ -22,10 +22,11 @@ import Test.Tasty.Extras
 import Test.Tasty.QuickCheck
 
 test_lets :: TestTree
-test_lets = runTestNestedIn ["plutus-ir", "test", "PlutusIR", "Compiler"] $ testNested "Let"
-    [ goldenPlcFromPir pTermAsProg "letInLet"
-    , goldenPlcFromPir pTermAsProg "letDep"
-    ]
+test_lets =
+    runTestNested ["plutus-ir", "test", "PlutusIR", "Compiler", "Let"]
+        [ goldenPlcFromPir pTermAsProg "letInLet"
+        , goldenPlcFromPir pTermAsProg "letDep"
+        ]
 
 -- FIXME: this fails because some of the let passes expect certain things to be
 -- gone, e.g. non-strict bindings. We should a) add pre-/post-conditions for these,