Merge pull request #185 from j-mueller/th

use-cases: Add TH module for tests

.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/src/Language/Plutus/Coordination/Contracts/Vesting.hs

@@ -11,7 +11,8 @@ module Language.Plutus.Coordination.Contracts.Vesting (
     VestingData(..),
     vestFunds,
     retrieveFunds,
-    validatorScript
+    validatorScript,
+    totalAmount
     ) where
 
 import           Control.Monad.Error.Class            (MonadError (..))

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

@@ -1,11 +1,14 @@
-{-# 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
 
 import           Data.Bifunctor                                      (Bifunctor (..))
 import           Data.Either                                         (isLeft, isRight)
+import           Data.Foldable                                       (traverse_)
 import qualified Data.Map                                            as Map
 import           Hedgehog                                            (Property, forAll, property)
 import qualified Hedgehog
@@ -23,11 +26,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 +44,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
 
@@ -56,7 +60,7 @@ makeContribution :: Property
 makeContribution = checkCFTrace scenario1 $ do
     let w = Wallet 2
         contribution = 600
-        rest = fromIntegral $ 1000 - contribution
+        rest = startingBalance - fromIntegral contribution
     blockchainActions >>= walletNotifyBlock w
     contrib w (cfCampaign scenario1) contribution
     blockchainActions >>= walletNotifyBlock w
@@ -72,17 +76,10 @@ 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)]
+    traverse_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 600 + 800)]
 
 -- | Check that the campaign owner cannot collect the monies before the campaign deadline
 cantCollectEarly :: Property
@@ -93,17 +90,10 @@ 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)]
+    traverse_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 0)]
 
 
 -- | Check that the campaign owner cannot collect the monies after the
@@ -116,17 +106,10 @@ 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)]
+    traverse_ (uncurry assertOwnFundsEq) [(w2, startingBalance - 600), (w3, startingBalance - 800), (w1, 0)]
 
 
 -- | Run a successful campaign that ends with a refund
@@ -138,18 +121,11 @@ 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'
-    mapM_ (uncurry assertOwnFundsEq) [(w2, 1000), (w3, 1000), (w1, 0)]
+    traverse_ (uncurry assertOwnFundsEq) [(w2, startingBalance), (w3, startingBalance), (w1, 0)]
 
 -- | Crowdfunding scenario with test parameters
 data CFScenario = CFScenario {
@@ -160,17 +136,21 @@ 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),
-        (PubKey 2, 1000),
-        (PubKey 3, 1000)]
+        (PubKey 2, startingBalance),
+        (PubKey 3, startingBalance)]
+
+-- | Funds available to wallets `Wallet 2` and `Wallet 3`
+startingBalance :: UTXO.Value
+startingBalance = 1000
 
 -- | Run a trace with the given scenario and check that the emulator finished
 --   successfully with an empty transaction pool.

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

@@ -0,0 +1,51 @@
+{-# 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
+        hash = 1123 -- stand-in for a transaction hash
+        rest  = total - out
+    in PendingTx {
+        pendingTxCurrentInput = (PendingTxIn (PendingTxOutRef 100 0) (), total),
+        pendingTxOtherInputs  = []::[(PendingTxIn (), Value)],
+        pendingTxOutputs      = (PendingTxOut out Nothing (PubKeyTxOut (PubKey 1))::(PendingTxOut VestingData)):(PendingTxOut rest (Just (VestingData hash 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
+        }
+    |]