add HasParameterisedGenerator and wire tests up

agora-test/Model/MultiSig.hs

@@ -1,9 +1,28 @@
-module Model.MultiSig () where
+module Model.MultiSig (plutarchTests, genTests) where
 
-import Agora.MultiSig (MultiSig (..))
+import Agora.MultiSig (MultiSig (..), validatedByMultisig)
-import Apropos (Apropos (Apropos), Formula (ExactlyOne), (:+))
+import Apropos (Apropos (Apropos), Formula (ExactlyOne, Var, Yes), HasLogicalModel (..), HasParameterisedGenerator, LogicalModel (logic), parameterisedGenerator, runGeneratorTestsWhere, (:+))
-import Apropos.Script (HasScriptRunner (expect, script))
+import Apropos.Gen (Gen, choice, int, linear, list)
-import Plutus.V1.Ledger.Api (PubKeyHash, Script)
+import Apropos.LogicalModel (Enumerable)
+import Apropos.LogicalModel.Enumerable (Enumerable (enumerated))
+import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script))
+import Data.List (intersect)
+import Plutarch (compile)
+import Plutus.V1.Ledger.Api (
+  Script,
+  ScriptContext (scriptContextPurpose),
+  ScriptPurpose (Spending),
+  TxInfo (txInfoDCert, txInfoData, txInfoFee, txInfoId, txInfoInputs, txInfoMint, txInfoOutputs, txInfoValidRange, txInfoWdrl),
+  TxOutRef (TxOutRef),
+  scriptContextTxInfo,
+  txInfoSignatories,
+ )
+import Plutus.V1.Ledger.Contexts (ScriptContext (ScriptContext), TxInfo (TxInfo))
+import Plutus.V1.Ledger.Crypto (PubKeyHash)
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Hedgehog (fromGroup)
 
 {-
 
@@ -33,27 +52,94 @@ data MultiSigModel = MultiSigModel
   { ms :: MultiSig
   , ctx :: ScriptContext
   }
+  deriving stock (Eq, Show)
 
 data MultiSigProp
   = MeetsMinSigs
   | DoesNotMeetMinSigs
+  deriving stock (Eq, Show, Ord)
 
-instance LogicalModel MultiSigModel where
+instance Enumerable MultiSigProp where
+  enumerated = [MeetsMinSigs, DoesNotMeetMinSigs]
+
+instance LogicalModel MultiSigProp where
   logic = ExactlyOne [Var MeetsMinSigs, Var DoesNotMeetMinSigs]
 
 instance HasLogicalModel MultiSigProp MultiSigModel where
   satisfiesProperty :: MultiSigProp -> MultiSigModel -> Bool
   satisfiesProperty p m =
     let minSigs = m.ms.minSigs
-        signatories = m.ctx.txInfo.txInfoSignatories
+        signatories = txInfoSignatories $ scriptContextTxInfo $ m.ctx
         matchingSigs = intersect m.ms.keys signatories
      in case p of
-          MeetsMinSigs -> length matchingSigs >= minSigs
+          MeetsMinSigs -> length matchingSigs >= fromInteger minSigs
-          DoesNotMeetMinSigs -> length matchingSigs < minSigs
+          DoesNotMeetMinSigs -> length matchingSigs < fromInteger minSigs
 
-instance HasScriptRunner MultiSigProp MultiSig where
+contextWithSignatures :: [PubKeyHash] -> ScriptContext
+contextWithSignatures sigs =
+  ScriptContext
+    { scriptContextTxInfo =
+        TxInfo
+          { txInfoInputs = []
+          , txInfoOutputs = []
+          , txInfoFee = Value.singleton "" "" 2
+          , txInfoMint = mempty
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = sigs
+          , txInfoData = []
+          , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+          }
+    , scriptContextPurpose = Spending (TxOutRef "" 0)
+    }
+
+genPK :: Gen PubKeyHash
+genPK =
+  choice
+    [ pure "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+    , pure "0b12051dd2da4b3629cebb92e2be111e0e99c63c04727ed55b74a296"
+    , pure "87f5f31e4d7437463cd901c4c9edb7a51903ac858661503e9d72f492"
+    , pure "f74ccaee8244264b3c73fce3b66bd2337de3db70efff4261d6ff145b"
+    ]
+
+instance HasParameterisedGenerator MultiSigProp MultiSigModel where
+  parameterisedGenerator s = do
+    expectedSignatures <- list (linear 1 4) genPK
+    minSigs <- toInteger <$> int (linear 1 (length expectedSignatures))
+    let msig = MultiSig expectedSignatures minSigs
+
+    actualSignaturesLength <-
+      if MeetsMinSigs `elem` s
+        then int (linear (fromInteger minSigs) (length expectedSignatures))
+        else pure 0
+    let actualSignatures = take actualSignaturesLength expectedSignatures
+
+    let ctx = contextWithSignatures actualSignatures
+    pure (MultiSigModel msig ctx)
+
+instance HasScriptRunner MultiSigProp MultiSigModel where
   expect :: (MultiSigModel :+ MultiSigProp) -> Formula MultiSigProp
-  expect = undefined
+  expect Apropos = Var MeetsMinSigs
 
-  script :: (MultiSigModel :+ MultiSigProp) -> MultiSig -> Script
+  script :: (MultiSigModel :+ MultiSigProp) -> MultiSigModel -> Script
-  script Apropos msm = compile $ validatedByMultisig msm . ms
+  script Apropos msm =
+    compile $
+      pif
+        (validatedByMultisig msm.ms # pconstant msm.ctx.scriptContextTxInfo)
+        (pcon PUnit)
+        perror
+
+genTests :: TestTree
+genTests =
+  testGroup "genTests" $
+    fromGroup
+      <$> [ runGeneratorTestsWhere (Apropos :: MultiSigModel :+ MultiSigProp) "Generator" Yes
+          ]
+
+plutarchTests :: TestTree
+plutarchTests =
+  testGroup "plutarchTests" $
+    fromGroup
+      <$> [ runScriptTestsWhere (Apropos :: MultiSigModel :+ MultiSigProp) "ScriptValid" Yes
+          ]

agora-test/Spec.hs

@@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
 
+import Model.MultiSig qualified
 import Spec.Int
 import Spec.Stake qualified as Stake
 
@@ -25,5 +26,10 @@ main =
               "Int"
               [ intPlutarchTests
               ]
+          , testGroup
+              "MultiSig"
+              [ Model.MultiSig.plutarchTests
+              , Model.MultiSig.genTests
+              ]
           ]
       ]

agora.cabal

@@ -151,6 +151,7 @@ test-suite agora-test
     Spec.Int
     Spec.Sample.Stake
     Spec.Stake
+    Model.MultiSig
     Spec.Util
 
   build-depends:  agora

agora/Agora/MultiSig.hs

@@ -47,7 +47,7 @@ data MultiSig = MultiSig
   -- ^ List of PubKeyHashes that must be present in the list of signatories.
   , minSigs :: Integer
   }
-  deriving stock (GHC.Generic)
+  deriving stock (GHC.Generic, Eq, Show)
   deriving anyclass (Generic)
 
 PlutusTx.makeLift ''MultiSig