added test entree

Something is wrong. It does not work.

agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs

@@ -5,8 +5,10 @@ Description: Sample based testing for Treasury Withdrawal Effect
 
 This module tests the Treasury Withdrawal Effect.
 -}
-module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1) where
+module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where
 
+import Plutarch.Evaluate
+import Plutarch.Builtin
 import Plutarch.Api.V1
 import Plutus.V1.Ledger.Api
 import Plutus.V1.Ledger.Interval qualified as Interval
@@ -16,12 +18,16 @@ import Data.ByteString.Hash
 
 import Agora.Effect.TreasuryWithdrawal
 
+import Spec.Util
+
+import Test.Tasty
+
 -- receiverList :: TreasuryWithdrawalDatum
 -- receiverList = TreasuryWithdrawalDatum [(mempty, mempty)]
 
 -- | A sample Currency Symbol.
 currSymbol :: CurrencySymbol
-currSymbol = CurrencySymbol "Orangebottle19721121"
+currSymbol = CurrencySymbol "ff"
 
 -- | A sample 'PubKeyHash'.
 signer :: PubKeyHash
@@ -31,14 +37,23 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 users :: [Credential]
 users =
   PubKeyCredential . PubKeyHash . toBuiltin . sha2
-    <$> [ "Hello world"
-        , "Hello Agora"
-        , "Hello Plutarch"
+    <$> [ "Orange"
+        , "Bottle"
+        , "Hello"
+        ]
+
+-- | List of users who the effect will pay to.
+treasuries :: [Credential]
+treasuries =
+  ScriptCredential . ValidatorHash . toBuiltin . sha2
+    <$> [ "1234"
+        , "qwer"
+        , "asdf"
         ]
 
 -- | Datum for Treasury Withdrawal Effect Validator.
-_datum :: TreasuryWithdrawalDatum
-_datum =
+datum :: TreasuryWithdrawalDatum
+datum =
   TreasuryWithdrawalDatum
     [ (users !! 0, Value.singleton currSymbol validatorHashTN 1)
     , (users !! 1, Value.singleton currSymbol validatorHashTN 1)
@@ -60,23 +75,23 @@ scriptContext1 =
         TxInfo
           { txInfoInputs =
               [ TxInInfo -- Initiator
-                  (TxOutRef "Initiator" 1)
+                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
                   TxOut
                     { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
                     , txOutValue = Value.singleton "" "" 2000000
                     , txOutDatumHash = Nothing
                     }
               , TxInInfo -- Treasury 1
-                  (TxOutRef "Treasury 1" 1)
+                  (TxOutRef "Treasury 1" 2)
                   TxOut
-                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    { txOutAddress = Address (treasuries !! 0) Nothing
                     , txOutValue = Value.singleton currSymbol validatorHashTN 10
                     , txOutDatumHash = Nothing
                     }
               , TxInInfo -- Treasury 2
-                  (TxOutRef "Treasury 2" 1)
+                  (TxOutRef "Treasury 2" 3)
                   TxOut
-                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    { txOutAddress = Address (treasuries !! 1) Nothing
                     , txOutValue = Value.singleton currSymbol validatorHashTN 10
                     , txOutDatumHash = Nothing
                     }
@@ -97,6 +112,17 @@ scriptContext1 =
                   , txOutValue = Value.singleton currSymbol validatorHashTN 1
                   , txOutDatumHash = Nothing
                   }
+              -- Send left overs to treasuries
+              , TxOut
+                  { txOutAddress = Address (treasuries !! 0) Nothing
+                  , txOutValue = Value.singleton currSymbol validatorHashTN 7
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (treasuries !! 1) Nothing
+                  , txOutValue = Value.singleton currSymbol validatorHashTN 10
+                  , txOutDatumHash = Nothing
+                  }                  
               ]
           , txInfoFee = Value.singleton "" "" 2
           , txInfoMint = mempty
@@ -110,3 +136,20 @@ scriptContext1 =
     , scriptContextPurpose =
         Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
     }
+
+
+tests :: [TestTree]
+tests =
+  [ testGroup
+    "effect"
+    [ effectFailsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
+  ]
+
+_asdfa :: IO ()
+_asdfa = do
+    let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1)
+    case res of
+      Left e -> do
+        putStrLn $ show e <> " Traces: " <> show traces
+      Right _v ->
+        pure ()

agora-test/Spec/Util.hs

@@ -13,6 +13,8 @@ module Spec.Util (
   policyFailsWith,
   validatorSucceedsWith,
   validatorFailsWith,
+  effectSucceedsWith,
+  effectFailsWith,
 
   -- * Plutus-land utils
   datumHash,
@@ -129,6 +131,45 @@ validatorFailsWith tag policy datum redeemer scriptContext =
           # pconstant scriptContext
       )
 
+
+-- | Check that a validator script succeeds, given a name and arguments.
+effectSucceedsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  ScriptContext ->
+  TestTree
+effectSucceedsWith tag eff datum scriptContext =
+  scriptSucceeds tag $
+    compile
+      ( eff
+          # pforgetData (pconstantData datum)
+          # pforgetData (pconstantData ())
+          # pconstant scriptContext
+      )
+
+-- | Check that a validator script fails, given a name and arguments.
+effectFailsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  ScriptContext ->
+  TestTree
+effectFailsWith tag eff datum scriptContext =
+  scriptFails tag $
+    compile
+      ( eff
+          # pforgetData (pconstantData datum)
+          # pforgetData (pconstantData ())
+          # pconstant scriptContext
+      )
+
 -- | Check that an arbitrary script doesn't error when evaluated, given a name.
 scriptSucceeds :: String -> Script -> TestTree
 scriptSucceeds name script = testCase name $ do