use-cases: Add TH module for tests

* Add a Spec.TH module with quoted expressions for creating `PendingTx`
  values

.hlint.yaml

@@ -33,7 +33,7 @@
 - ignore: {name: Parse error}
 - ignore: {name: Eta reduce, within: [Language.PlutusCore.MkPlc]}
 # PLC plugin only accepts lists that are constructed in a certain way
-- ignore: {name: Use list literal, within: [Spec.Crowdfunding]}
+- ignore: {name: Use list literal, within: [Spec.TH]}
 # PLC plugin requires && to be defined in side TH splices
 - ignore: {name: Redundant if, within: [Language.Plutus.Coordination.Contracts.CrowdFunding, Language.Plutus.Coordination.Contracts.Vesting]}
 

plutus-use-cases/plutus-use-cases.cabal

@@ -56,6 +56,7 @@ test-suite plutus-use-cases-test
     other-modules:
       Spec.Crowdfunding
       Spec.Vesting
+      Spec.TH
     build-depends:
         base >=4.9 && <5,
         containers -any,
@@ -67,4 +68,5 @@ test-suite plutus-use-cases-test
         plutus-use-cases,
         plutus-th -any,
         microlens -any,
-        core-to-plc -any
+        core-to-plc -any,
+        template-haskell -any

plutus-use-cases/src/Language/Plutus/Coordination/Contracts/CrowdFunding.hs

@@ -2,12 +2,13 @@
 -- This is the fully parallel version that collects all contributions
 -- in a single transaction. This is, of course, limited by the maximum
 -- number of inputs a transaction can have.
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ViewPatterns        #-}
 {-# OPTIONS -fplugin=Language.Plutus.CoreToPLC.Plugin -fplugin-opt Language.Plutus.CoreToPLC.Plugin:dont-typecheck #-}
 module Language.Plutus.Coordination.Contracts.CrowdFunding (
     -- * Campaign parameters

plutus-use-cases/test/Spec/Crowdfunding.hs

@@ -1,6 +1,8 @@
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 {-# OPTIONS -fplugin=Language.Plutus.CoreToPLC.Plugin -fplugin-opt Language.Plutus.CoreToPLC.Plugin:dont-typecheck #-}
 module Spec.Crowdfunding(tests) where
 
@@ -23,11 +25,12 @@ import qualified Wallet.Generators                                   as Gen
 import           Language.Plutus.Coordination.Contracts.CrowdFunding (Campaign (..), CampaignActor, CampaignPLC (..),
                                                                       contribute, refund)
 import qualified Language.Plutus.Coordination.Contracts.CrowdFunding as CF
-import           Language.Plutus.CoreToPLC.Plugin                    (plc)
-import           Language.Plutus.Runtime                             (Hash (..), PendingTx (..), PendingTxIn (..),
-                                                                      PendingTxOut (..), PendingTxOutRef (..), Value)
+import qualified Language.Plutus.Runtime                             as Runtime
+import           Language.Plutus.TH                                  (plutus)
 import qualified Wallet.UTXO                                         as UTXO
 
+import           Spec.TH                                             (pendingTxCrowdfunding)
+
 tests :: TestTree
 tests = testGroup "crowdfunding" [
         testProperty "make a contribution" makeContribution,
@@ -40,7 +43,7 @@ tests = testGroup "crowdfunding" [
 -- | Make a contribution to the campaign from a wallet. Returns the reference
 --   to the transaction output that is locked by the campaign's validator
 --   script (and can be collected by the campaign owner)
-contrib :: Wallet -> CampaignPLC -> Value -> Trace TxOutRef'
+contrib :: Wallet -> CampaignPLC -> Runtime.Value -> Trace TxOutRef'
 contrib w c v = exContrib <$> walletAction w (contribute c v) where
     exContrib = snd . head . filter (isPayToScriptOut . fst) . txOutRefs . head
 
@@ -72,14 +75,7 @@ successfulCampaign = checkCFTrace scenario1 $ do
     con2 <- contrib w2 c 600
     con3 <- contrib w3 c 800
     updateAll'
-    setValidationData $ ValidationData $ plc PendingTx {
-        pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 1) (), 600),
-        pendingTxOtherInputs  = (PendingTxIn (PendingTxOutRef 200 1) (), 800):[],
-        pendingTxOutputs      = []::[PendingTxOut CampaignActor],
-        pendingTxForge        = 0,
-        pendingTxFee          = 0,
-        pendingTxBlockHeight  = 11
-        }
+    setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 11 600 (Just 800) |])
     collect w1 c [(con2, w2, 600), (con3, w3, 800)]
     updateAll'
     mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 1400)]
@@ -93,14 +89,7 @@ cantCollectEarly = checkCFTrace scenario1 $ do
     con2 <- contrib w2 c 600
     con3 <- contrib w3 c 800
     updateAll'
-    setValidationData $ ValidationData $ plc PendingTx {
-        pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 1) (), 600),
-        pendingTxOtherInputs  = (PendingTxIn (PendingTxOutRef 200 1) (), 800):[],
-        pendingTxOutputs      = []::[PendingTxOut CampaignActor],
-        pendingTxForge        = 0,
-        pendingTxFee          = 0,
-        pendingTxBlockHeight  = 8
-        }
+    setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 8 600 (Just 800) |])
     collect w1 c [(con2, w2, 600), (con3, w3, 800)]
     updateAll'
     mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 0)]
@@ -116,14 +105,7 @@ cantCollectLate = checkCFTrace scenario1 $ do
     con2 <- contrib w2 c 600
     con3 <- contrib w3 c 800
     updateAll'
-    setValidationData $ ValidationData $ plc PendingTx {
-        pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 1) (), 600),
-        pendingTxOtherInputs  = (PendingTxIn (PendingTxOutRef 200 1) (), 800):[],
-        pendingTxOutputs      = []::[PendingTxOut CampaignActor],
-        pendingTxForge        = 0,
-        pendingTxFee          = 0,
-        pendingTxBlockHeight  = 17
-        }
+    setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 17 600 (Just 800) |])
     collect w1 c [(con2, w2, 600), (con3, w3, 800)]
     updateAll'
     mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w3, 200), (w1, 0)]
@@ -138,14 +120,7 @@ canRefund = checkCFTrace scenario1 $ do
     con2 <- contrib w2 c 600
     con3 <- contrib w3 c 800
     updateAll'
-    setValidationData $ ValidationData $ plc PendingTx {
-        pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 1) (), 600),
-        pendingTxOtherInputs  = []::[(PendingTxIn (), Value)],
-        pendingTxOutputs      = []::[PendingTxOut CampaignActor],
-        pendingTxForge        = 0,
-        pendingTxFee          = 0,
-        pendingTxBlockHeight  = 18
-        }
+    setValidationData $ ValidationData $(plutus [| $(pendingTxCrowdfunding) 18 600 Nothing |])
     walletAction w2 (refund c con2 600)
     walletAction w3 (refund c con3 800)
     updateAll'
@@ -160,12 +135,12 @@ data CFScenario = CFScenario {
 
 scenario1 :: CFScenario
 scenario1 = CFScenario{..} where
-    cfCampaign = CampaignPLC $ plc Campaign {
+    cfCampaign = CampaignPLC $(plutus [| Campaign {
         campaignDeadline = 10,
         campaignTarget   = 1000,
         campaignCollectionDeadline = 15,
         campaignOwner              = PubKey 1
-        }
+        } |])
     cfWallets = Wallet <$> [1..3]
     cfInitialBalances = Map.fromList [
         (PubKey 1, 0),

plutus-use-cases/test/Spec/TH.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+-- | Quoted expressions for generating validation data
+module Spec.TH(
+    pendingTxVesting,
+    pendingTxCrowdfunding
+    ) where
+
+import           Language.Haskell.TH                                 (Exp, Q)
+import qualified Language.Plutus.CoreToPLC.Primitives                as Prim
+import           Language.Plutus.Runtime                             (Hash (..), Height, PendingTx (..),
+                                                                      PendingTxIn (..), PendingTxOut (..),
+                                                                      PendingTxOutRef (..), PendingTxOutType (..),
+                                                                      Value)
+import           Wallet.API                                          (PubKey (..))
+
+import           Language.Plutus.Coordination.Contracts.CrowdFunding (CampaignActor)
+import           Language.Plutus.Coordination.Contracts.Vesting      (VestingData (..))
+
+-- | Create a `PendingTx () VestingData` from a block height and a value
+--   (of funds taken out of the scheme)
+pendingTxVesting :: Q Exp
+pendingTxVesting = [| \(h :: Height) (out :: Value) ->
+    let total = 600
+        rest  = total - out
+    in PendingTx {
+        pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), 600),
+        pendingTxOtherInputs  = []::[(PendingTxIn (), Value)],
+        pendingTxOutputs      = (PendingTxOut out Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut rest (Just (VestingData 1123 out)) DataTxOut::(PendingTxOut VestingData)):([]::[PendingTxOut VestingData]),
+        pendingTxForge        = 0,
+        pendingTxFee          = 0,
+        pendingTxBlockHeight  = h
+        } |]
+
+-- | Create a `PendingTx () CampaignActor` from a block height and one or two inputs.
+pendingTxCrowdfunding :: Q Exp
+pendingTxCrowdfunding = [| \(h :: Height) (v1::Value) (v2::Maybe Value) ->
+    let i1 = (PendingTxIn (PendingTxOutRef 100 1) (), v1)
+        i2 = case v2 of
+                Just v2' -> (PendingTxIn (PendingTxOutRef 200 1) (), v2'):[]
+                Nothing  -> []::[(PendingTxIn (), Value)]
+    in PendingTx {
+        pendingTxCurrentInput = i1,
+        pendingTxOtherInputs  = i2,
+        pendingTxOutputs      = []::[PendingTxOut CampaignActor],
+        pendingTxForge        = 0,
+        pendingTxFee          = 0,
+        pendingTxBlockHeight  = h
+        }
+    |]

plutus-use-cases/test/Spec/Vesting.hs

@@ -1,7 +1,8 @@
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 {-# OPTIONS -fplugin=Language.Plutus.CoreToPLC.Plugin -fplugin-opt Language.Plutus.CoreToPLC.Plugin:dont-typecheck #-}
 module Spec.Vesting(tests) where
 
@@ -16,26 +17,27 @@ import           Test.Tasty.Hedgehog                            (testProperty)
 
 import           Language.Plutus.Coordination.Contracts.Vesting (Vesting (..), VestingData (..), VestingPLC (..),
                                                                  VestingTranche (..), retrieveFunds, vestFunds)
-import           Language.Plutus.Runtime                        (Hash (..), PendingTx (..), PendingTxIn (..),
-                                                                 PendingTxOut (..), PendingTxOutRef (..),
-                                                                 PendingTxOutType (..), Value)
+import qualified Language.Plutus.Runtime                        as Runtime
 import           Language.Plutus.TH                             (plutus)
 import           Wallet.API                                     (PubKey (..))
 import           Wallet.Emulator                                hiding (Value)
 import qualified Wallet.Generators                              as Gen
 import qualified Wallet.UTXO                                    as UTXO
 
+import           Spec.TH                                        (pendingTxVesting)
+
 tests :: TestTree
 tests = testGroup "vesting" [
     testProperty "secure some funds with the vesting script" secureFunds,
     testProperty "retrieve some funds" canRetrieveFunds,
-    testProperty "cannot retrieve more than allowed" cannotRetrieveTooMuch
+    testProperty "cannot retrieve more than allowed" cannotRetrieveTooMuch,
+    testProperty "can retrieve everything at end" canRetrieveFundsAtEnd
     ]
 
 -- | Commit some funds from a wallet to a vesting scheme. Returns the reference
 --   to the transaction output that is locked by the schemes's validator
 --   script (and can be collected by the scheme's owner)
-commit :: Wallet -> Vesting -> VestingPLC -> Value -> Trace TxOutRef'
+commit :: Wallet -> Vesting -> VestingPLC -> Runtime.Value -> Trace TxOutRef'
 commit w vv vplc vl = exScriptOut <$> walletAction w (void $ vestFunds vplc vv vl) where
     exScriptOut = snd . head . filter (isPayToScriptOut . fst) . txOutRefs . head
 
@@ -49,6 +51,7 @@ secureFunds = checkVestingTrace scen1 $ do
     updateAll'
     mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1000)]
 
+
 canRetrieveFunds :: Property
 canRetrieveFunds = checkVestingTrace scen1 $ do
     let VestingScenario splc s [w1, w2] _ = scen1
@@ -57,14 +60,7 @@ canRetrieveFunds = checkVestingTrace scen1 $ do
     updateAll'
     ref <- commit w2 s splc total
     updateAll'
-    setValidationData $ ValidationData $(plutus [| PendingTx {
-        pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), 600),
-        pendingTxOtherInputs  = []::[(PendingTxIn (), Value)],
-        pendingTxOutputs      = (PendingTxOut 150 Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut 450 (Just (VestingData 1123 150)) DataTxOut::(PendingTxOut VestingData)):([]::[PendingTxOut VestingData]),
-        pendingTxForge        = 0,
-        pendingTxFee          = 0,
-        pendingTxBlockHeight  = 11
-        } |])
+    setValidationData $ ValidationData $(plutus [| $(pendingTxVesting) 11 150  |])
     let ds = DataScript $(plutus [|  VestingData 1123 150 |])
     walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 150)
     updateAll'
@@ -78,22 +74,28 @@ cannotRetrieveTooMuch = checkVestingTrace scen1 $ do
     updateAll'
     ref <- commit w2 s splc total
     updateAll'
-    setValidationData $ ValidationData $(plutus [|
-
-        let tooMuch = 250 in -- at block height 11, not more than 200 may be taken out
-        PendingTx {
-            pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), 600),
-            pendingTxOtherInputs  = []::[(PendingTxIn (), Value)],
-            pendingTxOutputs      = (PendingTxOut tooMuch Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut 350 (Just (VestingData 1123 250)) DataTxOut::(PendingTxOut VestingData)):([]::[PendingTxOut VestingData]),
-            pendingTxForge        = 0,
-            pendingTxFee          = 0,
-            pendingTxBlockHeight  = 11
-        } |])
-    let ds = DataScript $(plutus [|  VestingData 1123 150 |])
-    walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 300)
+    -- at block height 11, not more than 200 may be taken out
+    setValidationData $ ValidationData $(plutus [| $(pendingTxVesting) 11 250 |])
+    let ds = DataScript $(plutus [|  VestingData 1123 250 |])
+    walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 250)
     updateAll'
     mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1000)]
 
+canRetrieveFundsAtEnd :: Property
+canRetrieveFundsAtEnd = checkVestingTrace scen1 $ do
+    let VestingScenario splc s [w1, w2] _ = scen1
+        total = 600
+        updateAll' = updateAll scen1
+    updateAll'
+    ref <- commit w2 s splc total
+    updateAll'
+    -- everything can be taken out at h=21
+    setValidationData $ ValidationData $(plutus [| $(pendingTxVesting) 21 600 |])
+    let ds = DataScript $(plutus [|  VestingData 1123 600 |])
+    walletAction w1 $ void (retrieveFunds s splc (VestingData 1123 0) ds ref 600)
+    updateAll'
+    mapM_ (uncurry assertOwnFundsEq) [(w2, 400), (w1, 1600)]
+
 -- | Vesting scenario with test parameters
 data VestingScenario = VestingScenario {
     vsVestingSchemePLC :: VestingPLC,