Merge branch 'master' of github.com:Liqwid-Labs/agora into jhodgdev/treasury-tests

agora-test/Spec.hs

@@ -11,7 +11,7 @@ import Test.Tasty (defaultMain, testGroup)
 import Spec.Model.MultiSig qualified as MultiSig
 import Spec.Stake qualified as Stake
 
--- | The Agora test suite
+-- | The Agora test suite.
 main :: IO ()
 main =
   defaultMain $

agora-test/Spec/Model/MultiSig.hs

@@ -53,7 +53,7 @@ import Apropos (
 import Apropos.Gen (Gen, choice, int, linear, list)
 import Apropos.LogicalModel (Enumerable)
 import Apropos.LogicalModel.Enumerable (Enumerable (enumerated))
-import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script))
+import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (fromGroup)
 
@@ -157,7 +157,7 @@ instance HasParameterisedGenerator MultiSigProp MultiSigModel where
     -- Return the generated model.
     pure (MultiSigModel msig ctx)
 
-instance HasScriptRunner MultiSigProp MultiSigModel where
+instance ScriptModel MultiSigProp MultiSigModel where
   -- When the script runs, we want the model to meet the minimum signatures.
   expect :: (MultiSigModel :+ MultiSigProp) -> Formula MultiSigProp
   expect Apropos = Var MeetsMinSigs
@@ -171,7 +171,7 @@ instance HasScriptRunner MultiSigProp MultiSigModel where
         (pcon PUnit)
         perror
 
--- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel'
+-- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel'.
 genTests :: TestTree
 genTests =
   testGroup "genTests" $
@@ -182,7 +182,7 @@ genTests =
               Yes
           ]
 
--- | Tests for the 'HasScriptRunner' instance of 'MultiSigModel'
+-- | Tests for the 'ScriptModel' instance of 'MultiSigModel'.
 plutarchTests :: TestTree
 plutarchTests =
   testGroup "plutarchTests" $

agora-test/Spec/Sample/Stake.hs

@@ -21,7 +21,6 @@ module Spec.Sample.Stake (
 ) where
 
 --------------------------------------------------------------------------------
-
 import Plutarch.Api.V1 (
   mintingPolicySymbol,
   mkMintingPolicy,
@@ -47,20 +46,30 @@ import Plutus.V1.Ledger.Api (
 import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
 import Plutus.V1.Ledger.Interval qualified as Interval
 import Plutus.V1.Ledger.Scripts (Validator)
-import Plutus.V1.Ledger.Value (TokenName (TokenName))
+import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
 import Plutus.V1.Ledger.Value qualified as Value
 
 --------------------------------------------------------------------------------
 
-import Agora.SafeMoney
+import Agora.SafeMoney (GTTag)
 import Agora.Stake
+import Plutarch.SafeMoney
 import Spec.Util (datumPair, toDatumHash)
 
 --------------------------------------------------------------------------------
 
 -- | 'Stake' parameters for 'LQ'.
-stake :: Stake LQ
-stake = Stake
+stake :: Stake
+stake =
+  Stake
+    { gtClassRef =
+        Tagged
+          ( AssetClass
+              ( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
+              , "LQ"
+              )
+          )
+    }
 
 -- | 'Stake' policy instance.
 policy :: MintingPolicy
@@ -86,7 +95,7 @@ stakeCreation :: ScriptContext
 stakeCreation =
   let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
       datum :: Datum
-      datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer)
+      datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
    in ScriptContext
         { scriptContextTxInfo =
             TxInfo
@@ -114,7 +123,7 @@ stakeCreation =
 stakeCreationWrongDatum :: ScriptContext
 stakeCreationWrongDatum =
   let datum :: Datum
-      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer) -- Too much GT
+      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
    in ScriptContext
         { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
         , scriptContextPurpose = Minting policySymbol
@@ -135,9 +144,9 @@ stakeCreationUnsigned =
 
 -- | Config for creating a ScriptContext that deposits or withdraws.
 data DepositWithdrawExample = DepositWithdrawExample
-  { startAmount :: Integer
+  { startAmount :: Tagged GTTag Integer
   -- ^ The amount of GT stored before the transaction.
-  , delta :: Integer
+  , delta :: Tagged GTTag Integer
   -- ^ The amount of GT deposited or withdrawn from the Stake.
   }
 
@@ -146,7 +155,7 @@ stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
 stakeDepositWithdraw config =
   let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
       stakeBefore :: StakeDatum
-      stakeBefore = StakeDatum config.startAmount signer
+      stakeBefore = StakeDatum config.startAmount signer []
 
       stakeAfter :: StakeDatum
       stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
@@ -160,10 +169,7 @@ stakeDepositWithdraw config =
                         { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
                         , txOutValue =
                             st
-                              <> Value.singleton
-                                "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
-                                "LQ"
-                                stakeBefore.stakedAmount
+                              <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
                         , txOutDatumHash = Just (toDatumHash stakeAfter)
                         }
                   ]
@@ -172,10 +178,7 @@ stakeDepositWithdraw config =
                       { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
                       , txOutValue =
                           st
-                            <> Value.singleton
-                              "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
-                              "LQ"
-                              stakeAfter.stakedAmount
+                            <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
                       , txOutDatumHash = Just (toDatumHash stakeAfter)
                       }
                   ]

agora-test/Spec/Stake.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE QuasiQuotes #-}
+
 {- |
 Module     : Spec.Stake
 Maintainer : emi@haskell.fyi
@@ -27,7 +29,7 @@ import Spec.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWi
 
 --------------------------------------------------------------------------------
 
--- | Stake tests
+-- | Stake tests.
 tests :: [TestTree]
 tests =
   [ testGroup
@@ -50,20 +52,20 @@ tests =
       , validatorSucceedsWith
           "stakeDepositWithdraw deposit"
           (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
+          (toDatum $ StakeDatum 100_000 signer [])
           (toDatum $ DepositWithdraw 100_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
       , validatorSucceedsWith
           "stakeDepositWithdraw withdraw"
           (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
-          (toDatum $ DepositWithdraw (negate 100_000))
+          (toDatum $ StakeDatum 100_000 signer [])
+          (toDatum $ DepositWithdraw $ negate 100_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
       , validatorFailsWith
           "stakeDepositWithdraw negative GT"
           (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
-          (toDatum $ DepositWithdraw (negate 1_000_000))
+          (toDatum $ StakeDatum 100_000 signer [])
+          (toDatum $ DepositWithdraw 1_000_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
       ]
   ]