test suite

code/week08/hie.yaml

@@ -2,3 +2,5 @@ cradle:
   cabal:
     - path: "./src"
       component: "lib:plutus-pioneer-program-week08"
+    - path: "./test"
+      component: "test:plutus-pioneer-program-week08-tests"

code/week08/plutus-pioneer-program-week08.cabal

@@ -11,14 +11,9 @@ License-files:       LICENSE
 library
   hs-source-dirs:      src
   exposed-modules:     Week08.TokenSale
-                     , Week08.TestTokenSale
-                     , Week08.TraceTokenSale
   build-depends:       aeson
                      , base ^>=4.14.1.0
                      , containers
-                     , data-default
-                     , freer-extras
-                     , lens
                      , playground-common
                      , plutus-contract
                      , plutus-ledger
@@ -27,7 +22,30 @@ library
                      , plutus-tx
                      , plutus-use-cases
                      , prettyprinter
-                     , QuickCheck
                      , text
   default-language:    Haskell2010
   ghc-options:         -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise
+
+test-suite plutus-pioneer-program-week08-tests
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs: test
+  other-modules:       Spec.Model
+                     , Spec.Trace
+  default-language: Haskell2010
+  ghc-options:         -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas
+  build-depends:       base ^>=4.14.1.0
+                     , containers
+                     , data-default
+                     , freer-extras
+                     , lens
+                     , plutus-contract
+                     , plutus-ledger
+                     , plutus-pioneer-program-week08
+                     , plutus-tx
+                     , QuickCheck
+                     , tasty
+                     , tasty-quickcheck
+                     , text
+  if !(impl(ghcjs) || os(ghcjs))
+    build-depends: plutus-tx-plugin -any

code/week08/test/Spec.hs

@@ -0,0 +1,16 @@
+module Main
+    ( main
+    ) where
+
+import qualified Spec.Model
+import qualified Spec.Trace
+import           Test.Tasty
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "token sale"
+    [ Spec.Trace.tests
+    , Spec.Model.tests
+    ]

code/week08/test/Spec/Model.hs

@@ -14,7 +14,10 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 
-module Week08.TestTokenSale where
+module Spec.Model
+    ( tests
+    , test
+    )  where
 
 import           Control.Lens                       hiding (elements)
 import           Control.Monad                      (void, when)
@@ -31,6 +34,8 @@ import           Ledger                             hiding (singleton)
 import           Ledger.Ada                         as Ada
 import           Ledger.Value
 import           Test.QuickCheck
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
 
 import           Week08.TokenSale                   (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName)
 
@@ -47,6 +52,9 @@ newtype TSModel = TSModel {_tsModel :: Map Wallet TSState}
 
 makeLenses ''TSModel
 
+tests :: TestTree
+tests = testProperty "token sale model" prop_TS
+
 instance ContractModel TSModel where
 
     data Action TSModel =
@@ -126,8 +134,11 @@ instance ContractModel TSModel where
         (BuyTokens v w n)  -> callEndpoint @"buy tokens" (h $ UseKey v w) n                                                                    >> delay 1
         (Withdraw v w n l) -> callEndpoint @"withdraw"   (h $ UseKey v w) (n, l)                                                               >> delay 1
 
-    precondition s (Start w) = isNothing $ getTSState' s w
+    precondition s (Start w)          = isNothing $ getTSState' s w
-    precondition _ _         = True
+    precondition s (SetPrice v _ _)   = isJust    $ getTSState' s v
+    precondition s (AddTokens v _ _)  = isJust    $ getTSState' s v
+    precondition s (BuyTokens v _ _)  = isJust    $ getTSState' s v
+    precondition s (Withdraw v _ _ _) = isJust    $ getTSState' s v
 
 deriving instance Eq (ContractInstanceKey TSModel w s e)
 deriving instance Show (ContractInstanceKey TSModel w s e)
@@ -193,7 +204,7 @@ tokenAmt :: Integer
 tokenAmt = 1_000
 
 prop_TS :: Actions TSModel -> Property
-prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions
+prop_TS = withMaxSuccess 100 . propRunActionsWithOptions
     (defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d))
     instanceSpec
     (const $ pure True)

code/week08/test/Spec/Trace.hs

@@ -12,8 +12,12 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 
-module Week08.TraceTokenSale where
+module Spec.Trace
+    ( tests
+    , runMyTrace
+    ) where
 
+import           Control.Lens
 import           Control.Monad              hiding (fmap)
 import           Control.Monad.Freer.Extras as Extras
 import           Data.Default               (Default (..))
@@ -22,24 +26,32 @@ import           Data.Monoid                (Last (..))
 import           Ledger
 import           Ledger.Value
 import           Ledger.Ada                 as Ada
+import           Plutus.Contract.Test
 import           Plutus.Trace.Emulator      as Emulator
 import           PlutusTx.Prelude
 import           Prelude                    (IO, String, Show (..))
-import           Wallet.Emulator.Wallet
+import           Test.Tasty
 
 import           Week08.TokenSale
 
-test :: IO ()
+tests :: TestTree
-test = runEmulatorTraceIO' def emCfg myTrace
+tests = checkPredicateOptions
-  where
+    (defaultCheckOptions & emulatorConfig .~ emCfg)
-    emCfg :: EmulatorConfig
+    "token sale trace"
-    emCfg = EmulatorConfig $ Left $ Map.fromList
+    (     walletFundsChange (Wallet 1) (Ada.lovelaceValueOf   10_000_000  <> assetClassValue token (-60))
-        [ (Wallet w, v)
+     .&&. walletFundsChange (Wallet 2) (Ada.lovelaceValueOf (-20_000_000) <> assetClassValue token   20)
-        | w <- [1 .. 3]
+     .&&. walletFundsChange (Wallet 3) (Ada.lovelaceValueOf (- 5_000_000) <> assetClassValue token    5)
-        ]
+    )
+    myTrace
 
+runMyTrace :: IO ()
+runMyTrace = runEmulatorTraceIO' def emCfg myTrace
+
+emCfg :: EmulatorConfig
+emCfg = EmulatorConfig $ Left $ Map.fromList [(Wallet w, v) | w <- [1 .. 3]]
+  where
     v :: Value
-    v =    Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000
+    v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000
 
 currency :: CurrencySymbol
 currency = "aa"