[Test] Add do-notation support for 'TestNested' (#5948)

This refactors the `TestNested` machinery, so that 1. it supports listing tests in a `do`-block, which is something that I need in a different PR to update a huge `do`-block so that some of the tests there become golden 2. the API is more granular and pushes the user in the right direction I've also improved some of the tests while I was there and unified the formatting. Most of the tests we have use 4 spaces instead of 2, so I preserved that, we're probably going to run `fourmolu` over all the files eventually anyway and that'll make the indentation 2-space-based.
IntersectMBO · May 23, 2024 · 1afe001 · 1afe001
1 parent 6c6918c
commit 1afe001
Show file tree

Hide file tree

Showing 130 changed files with 653 additions and 572 deletions.
diff --git a/plutus-benchmark/lists/test/Lookup/Spec.hs b/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)

diff --git a/plutus-benchmark/lists/test/Sum/Spec.hs b/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

diff --git a/plutus-benchmark/marlowe/test/Spec.hs b/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 [email protected]{..} =
 
 -- 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

diff --git a/plutus-benchmark/nofib/test/Spec.hs b/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

diff --git a/plutus-benchmark/script-contexts/test/Spec.hs b/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)]

diff --git a/plutus-core/executables/plutus/AnyProgram/Compile.hs b/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

diff --git a/plutus-core/executables/plutus/AnyProgram/Run.hs b/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)

diff --git a/plutus-core/executables/plutus/Debugger/TUI/Main.hs b/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

diff --git a/plutus-core/executables/src/PlutusCore/Executable/Common.hs b/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)

diff --git a/plutus-core/plutus-core.cabal b/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

diff --git a/plutus-core/plutus-core/src/PlutusCore/Check/Normal.hs b/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

diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Eq.hs b/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
 

diff --git a/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs b/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

diff --git a/plutus-core/plutus-core/test/Pretty/Readable.hs b/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

diff --git a/plutus-core/plutus-core/test/Spec.hs b/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)

diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs b/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)
@@ -128,27 +127,27 @@ test_typecheckIllTyped =
             ]
 
 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 =

diff --git a/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs b/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"

diff --git a/plutus-core/plutus-ir/test/PlutusIR/Compiler/Datatype/Tests.hs b/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"
+            ]
         ]
-    ]