[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/plutus/AnyProgram/Compile.hs

@@ -131,7 +131,7 @@ compileProgram = curry $ \case
  (SUplc _ _, SPir SName _) -> throwingPIR "Cannot compile uplc to pir"
 
 embedProgram :: PLC.Program tyname name uni fun ann -> PIR.Program tyname name uni fun ann
-embedProgram (PLC.Program a v t) = PIR.Program a v $ embed t
+embedProgram (PLC.Program a v t) = PIR.Program a v $ embedTerm t
 
 toOutAnn :: (Functor f, PIR.AsError e uni fun a, MonadError e m)
  => SAnn s1

plutus-core/executables/plutus/AnyProgram/Run.hs

@@ -19,7 +19,6 @@ import Types
 import UntypedPlutusCore as UPLC
 import UntypedPlutusCore.Evaluation.Machine.Cek as UPLC
 
-import Data.Foldable
 import Data.Text as Text
 
 runRun :: (?opts :: Opts)

plutus-core/executables/plutus/Debugger/TUI/Main.hs

@@ -46,7 +46,6 @@ import Control.Concurrent
 import Control.Monad.Except (runExcept)
 import Control.Monad.Primitive (unsafeIOToPrim)
 import Control.Monad.ST (RealWorld)
-import Data.Foldable
 import Data.Maybe
 import GHC.IO (stToIO)
 import Graphics.Vty qualified as Vty

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

@@ -821,6 +821,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/Check/Normal.hs

@@ -16,7 +16,6 @@ import PlutusCore.Core
 import PlutusCore.Error
 
 import Control.Monad.Except
-import Data.Foldable (traverse_)
 
 -- | Ensure that all types in the 'Program' are normalized.
 checkProgram

plutus-core/plutus-core/src/PlutusCore/Core/Instance/Eq.hs

@@ -22,8 +22,6 @@ import PlutusCore.Rename.Monad
 
 import Universe
 
-import Data.Foldable (for_)
-
 instance (GEq uni, Eq ann) => Eq (Type TyName uni ann) where
  ty1 == ty2 = runEqRename @TypeRenaming $ eqTypeM ty1 ty2
 

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"
+ ]
  ]
- ]