PIR: restructure tests

plutus-core/plutus-core.cabal

@@ -557,28 +557,44 @@ library plutus-ir
     build-depends: integer-gmp
 
 test-suite plutus-ir-test
-  import:         lang
+  import:             lang
 
   -- needs linux 'diff' available
   if os(windows)
     buildable: False
 
-  type:           exitcode-stdio-1.0
-  main-is:        Spec.hs
-  hs-source-dirs: plutus-ir/test
+  type:               exitcode-stdio-1.0
+  main-is:            Driver.hs
+  hs-source-dirs:     plutus-ir/test
   other-modules:
-    AnalysisSpec
-    Check.Spec
-    GeneratorSpec
-    GeneratorSpec.Builtin
-    GeneratorSpec.Substitution
-    GeneratorSpec.Terms
-    GeneratorSpec.Types
-    NamesSpec
-    ParserSpec
-    TransformSpec
-    TypeSpec
-
+    PlutusCore.Generators.QuickCheck.BuiltinsTests
+    PlutusCore.Generators.QuickCheck.SubstitutionTests
+    PlutusCore.Generators.QuickCheck.TypesTests
+    PlutusIR.Analysis.RetainedSize.Tests
+    PlutusIR.Check.Uniques.Tests
+    PlutusIR.Compiler.Tests
+    PlutusIR.Core.Tests
+    PlutusIR.Generators.QuickCheck.Tests
+    PlutusIR.Parser.Tests
+    PlutusIR.Purity.Tests
+    PlutusIR.Scoping.Tests
+    PlutusIR.Transform.Beta.Tests
+    PlutusIR.Transform.CommuteFnWithConst.Tests
+    PlutusIR.Transform.DeadCode.Tests
+    PlutusIR.Transform.EvaluateBuiltins.Tests
+    PlutusIR.Transform.Inline.Tests
+    PlutusIR.Transform.KnownCon.Tests
+    PlutusIR.Transform.LetFloatIn.Tests
+    PlutusIR.Transform.LetFloatOut.Tests
+    PlutusIR.Transform.NonStrict.Tests
+    PlutusIR.Transform.RecSplit.Tests
+    PlutusIR.Transform.Rename.Tests
+    PlutusIR.Transform.StrictifyBindings.Tests
+    PlutusIR.Transform.ThunkRecursions.Tests
+    PlutusIR.Transform.Unwrap.Tests
+    PlutusIR.TypeCheck.Tests
+
+  build-tool-depends: tasty-discover:tasty-discover
   build-depends:
     , base                                                       >=4.9   && <5
     , containers

plutus-core/plutus-ir/test/Driver.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}

plutus-core/plutus-ir/test/GeneratorSpec/Builtin.hs → plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/BuiltinsTests.hs

@@ -1,5 +1,5 @@
 
-module GeneratorSpec.Builtin where
+module PlutusCore.Generators.QuickCheck.BuiltinsTests where
 
 import PlutusCore.Data
 import PlutusCore.Generators.QuickCheck
@@ -9,5 +9,5 @@ import Test.QuickCheck
 
 -- | This mainly tests that the `Data` generator isn't non-terminating or too slow.
 prop_genData :: Property
-prop_genData = forAll arbitrary $ \(d :: Data) ->
+prop_genData = withMaxSuccess 3000 $ forAll arbitrary $ \(d :: Data) ->
     d == deserialise (serialise d)

plutus-core/plutus-ir/test/GeneratorSpec/Substitution.hs → plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/SubstitutionTests.hs

@@ -1,5 +1,5 @@
 -- editorconfig-checker-disable-file
-module GeneratorSpec.Substitution where
+module PlutusCore.Generators.QuickCheck.SubstitutionTests where
 
 import PlutusCore.Generators.QuickCheck
 
@@ -38,7 +38,7 @@ import Test.QuickCheck hiding (choose, vectorOf)
 -- So we don't get great coverage, but given that it takes a few seconds to generate dozens of
 -- thousands of (non-filtered) test cases, we do still get some reasonable coverage in the end.
 prop_unify :: Property
-prop_unify =
+prop_unify = withMaxSuccess 10000 $
   forAllDoc "n"   arbitrary shrink         $ \ (NonNegative n) ->
   forAllDoc "nSub" (choose (0, n)) shrink  $ \ nSub ->
   -- See Note [Chaotic Good fresh name generation].
@@ -84,7 +84,7 @@ prop_unifyRename =
 -- | Check that substitution eliminates from the type all free occurrences of variables present in
 -- the domain of the substitution.
 prop_substType :: Property
-prop_substType =
+prop_substType = withMaxSuccess 10000 $
   -- No shrinking because every nested shrink makes properties harder to shrink (because you'd need
   -- to regenerate the stuff that depends on the context, meaning you don't have the same
   -- counterexample as you did before) and context minimality doesn't help readability very much.

plutus-core/plutus-ir/test/GeneratorSpec/Types.hs → plutus-core/plutus-ir/test/PlutusCore/Generators/QuickCheck/TypesTests.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE TupleSections #-}
 
-module GeneratorSpec.Types where
+module PlutusCore.Generators.QuickCheck.TypesTests where
 
 import PlutusCore.Generators.QuickCheck
 
@@ -9,11 +9,14 @@ import Data.Either
 import Data.Map.Strict qualified as Map
 import Test.QuickCheck
 
+prop_genKindCorrect :: Property
+prop_genKindCorrect = p_genKindCorrect False
+
 -- | Check that the types we generate are kind-correct.
 -- See Note [Debugging generators that don't generate well-typed/kinded terms/types]
 -- and see the utility tests below when this property fails.
-prop_genKindCorrect :: Bool -> Property
-prop_genKindCorrect debug =
+p_genKindCorrect :: Bool -> Property
+p_genKindCorrect debug = withMaxSuccess 100000 $
   -- Context minimality doesn't help readability, so no shrinking here
   forAllDoc "ctx" genCtx (const []) $ \ ctx ->
   -- Note, no shrinking here because shrinking relies on well-kindedness.
@@ -22,7 +25,7 @@ prop_genKindCorrect debug =
 
 -- | Check that shrinking types maintains kinds.
 prop_shrinkTypeSound :: Property
-prop_shrinkTypeSound =
+prop_shrinkTypeSound = withMaxSuccess 30000 $
   forAllDoc "ctx" genCtx (const []) $ \ ctx ->
   forAllDoc "k,ty" (genKindAndTypeWithCtx ctx) (shrinkKindAndType ctx) $ \ (k, ty) ->
   -- See discussion about the same trick in 'prop_shrinkTermSound'.
@@ -36,7 +39,7 @@ prop_shrinkTypeSound =
 
 -- | Test that shrinking a type results in a type of a smaller kind. Useful for debugging shrinking.
 prop_shrinkTypeSmallerKind :: Property
-prop_shrinkTypeSmallerKind =
+prop_shrinkTypeSmallerKind = withMaxSuccess 30000 $
   forAllDoc "k,ty" genKindAndType (shrinkKindAndType Map.empty) $ \ (k, ty) ->
   assertNoCounterexamples
     [ (k', ty')
@@ -46,13 +49,13 @@ prop_shrinkTypeSmallerKind =
 
 -- | Test that shrinking kinds generates smaller kinds.
 prop_shrinkKindSmaller :: Property
-prop_shrinkKindSmaller =
+prop_shrinkKindSmaller = withMaxSuccess 30000 $
   forAllDoc "k" arbitrary shrink $ \ k ->
   assertNoCounterexamples [k' | k' <- shrink k, not $ leKind k' k]
 
 -- | Test that fixKind actually gives you something of the right kind.
 prop_fixKind :: Property
-prop_fixKind =
+prop_fixKind = withMaxSuccess 30000 $
   forAllDoc "ctx" genCtx (const []) $ \ ctx ->
   forAllDoc "k,ty" genKindAndType (shrinkKindAndType ctx) $ \ (k, ty) ->
   -- Note, fixKind only works on smaller kinds, so we use shrink to get a definitely smaller kind

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

@@ -0,0 +1,46 @@
+module PlutusIR.Analysis.RetainedSize.Tests where
+
+import Test.Tasty
+import Test.Tasty.Extras
+
+import PlutusCore.Name
+import PlutusCore.Pretty qualified as PLC
+import PlutusCore.Quote
+import PlutusCore.Rename qualified as PLC
+import PlutusIR.Analysis.RetainedSize qualified as RetainedSize
+import PlutusIR.Parser
+import PlutusIR.Test
+import PlutusPrelude
+
+test_retainedSize :: TestTree
+test_retainedSize = runTestNestedIn ["plutus-ir/test/PlutusIR/Analysis"] $
+    testNested "RetainedSize" $
+        map
+            (goldenPir renameAndAnnotate pTerm)
+            [ "typeLet"
+            , "termLet"
+            , "strictLet"
+            , "nonstrictLet"
+            , -- @Maybe@ is referenced, so it retains all of the data type.
+              "datatypeLiveType"
+            , -- @Nothing@ is referenced, so it retains all of the data type.
+              "datatypeLiveConstr"
+            , -- @match_Maybe@ is referenced, so it retains all of the data type.
+              "datatypeLiveDestr"
+            , "datatypeDead"
+            , "singleBinding"
+            , "builtinBinding"
+            , "etaBuiltinBinding"
+            , "etaBuiltinBindingUsed"
+            , "nestedBindings"
+            , "nestedBindingsIndirect"
+            , "recBindingSimple"
+            , "recBindingComplex"
+            ]
+  where
+    displayAnnsConfig = PLC.PrettyConfigClassic PLC.defPrettyConfigName True
+    renameAndAnnotate =
+        PLC.AttachPrettyConfig displayAnnsConfig
+            . RetainedSize.annotateWithRetainedSize def
+            . runQuote
+            . PLC.rename

plutus-core/plutus-ir/test/Check/Spec.hs → plutus-core/plutus-ir/test/PlutusIR/Check/Uniques/Tests.hs

@@ -4,7 +4,7 @@
 
 -- | This module contains tests that ensure the definition analysis is correct. We may consider
 -- renaming this module, along with the corresponding PLC module to better reflect the scope.
-module Check.Spec (uniqueness) where
+module PlutusIR.Check.Uniques.Tests where
 
 
 import Control.Monad.Except (MonadError, runExcept)
@@ -16,23 +16,16 @@ import PlutusCore.Name (Unique (..))
 import PlutusCore.Quote (freshTyName, runQuoteT)
 import PlutusIR.Check.Uniques qualified as Uniques
 import PlutusIR.Core.Type
-import Test.Tasty (TestTree, testGroup)
+import Test.Tasty (TestTree)
 import Test.Tasty.HUnit (testCase, (@?=))
 
-uniqueness :: TestTree
-uniqueness = testGroup "uniqueness"
-    [shadowed
-    , multiplyDefined
-    , shadowedInLet
-    ]
-
 data Tag = Tag Int | Ignore deriving stock (Show, Eq, Ord)
 
 checkTermUniques :: (Ord a, MonadError (UniqueError a) m) => Term TyName Name uni fun a -> m ()
 checkTermUniques = Uniques.checkTerm (\case MultiplyDefined{} -> True; _ -> False)
 
-shadowed :: TestTree
-shadowed =
+test_shadowed :: TestTree
+test_shadowed =
     let
         u = Unique (-1)
         checked = runExcept $ runQuoteT $ do
@@ -46,8 +39,8 @@ shadowed =
         assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2))
     in testCase "shadowed" assertion
 
-multiplyDefined :: TestTree
-multiplyDefined =
+test_multiplyDefined :: TestTree
+test_multiplyDefined =
     let
         u = Unique (-1)
         checked = runExcept $ runQuoteT $ do
@@ -61,8 +54,8 @@ multiplyDefined =
         assertion = checked @?= Left (MultiplyDefined u (Tag 1) (Tag 2))
     in testCase "multiplyDefined" assertion
 
-shadowedInLet :: TestTree
-shadowedInLet =
+test_shadowedInLet :: TestTree
+test_shadowedInLet =
     let
         u = Unique (-1)
         checked = runExcept $ runQuoteT $ do