From b4c8b4e26202b640dd7875ea6d7e03a0e1abec88 Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Tue, 21 Nov 2023 13:46:28 +0000 Subject: [PATCH 01/14] Added Regression tests for Static Analysis before creating Incremental Static Analysis. --- marlowe-test/marlowe-test.cabal | 3 ++ marlowe-test/test/Spec.hs | 2 ++ .../test/Spec/Marlowe/StaticAnalysis.hs | 33 +++++++++++++++++++ 3 files changed, 38 insertions(+) create mode 100644 marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs diff --git a/marlowe-test/marlowe-test.cabal b/marlowe-test/marlowe-test.cabal index 380b80b868..069a033456 100644 --- a/marlowe-test/marlowe-test.cabal +++ b/marlowe-test/marlowe-test.cabal @@ -192,6 +192,8 @@ test-suite marlowe-test Spec.Marlowe.Serialization.CoreJson Spec.Marlowe.Serialization.ExtendedJson Spec.Marlowe.Service.Isabelle + Spec.Marlowe.StaticAnalysis + Spec.Marlowe.StaticAnalysis.Regression build-depends: , aeson >=2 && <3 @@ -200,6 +202,7 @@ test-suite marlowe-test , cardano-api ^>=8.2 , containers ^>=0.6.5 , data-default ^>=0.7.1 + , errors , filepath ^>=1.4 , hint ^>=0.9 , ilist ==0.4.0.1 diff --git a/marlowe-test/test/Spec.hs b/marlowe-test/test/Spec.hs index 30ed7a0851..5442553cc3 100644 --- a/marlowe-test/test/Spec.hs +++ b/marlowe-test/test/Spec.hs @@ -21,6 +21,7 @@ import qualified Spec.Marlowe.Plutus (tests) import qualified Spec.Marlowe.Semantics (tests) import qualified Spec.Marlowe.Serialization (tests) import qualified Spec.Marlowe.Service.Isabelle (tests) +import qualified Spec.Marlowe.StaticAnalysis (tests) -- | Timeout seconds for static analysis, which can take so much time on a complex contract -- that it exceeds hydra/CI resource limits, see SCP-4267. @@ -49,4 +50,5 @@ tests = , Spec.Marlowe.Semantics.tests , Spec.Marlowe.Plutus.tests , Spec.Marlowe.Service.Isabelle.tests + , Spec.Marlowe.StaticAnalysis.tests ] diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs new file mode 100644 index 0000000000..1219a1c655 --- /dev/null +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- + +----------------------------------------------------------------------------- + +-- | Tests of Marlowe semantics. +module Spec.Marlowe.StaticAnalysis ( + -- * Testing + main, + tests, +) where + +import Test.Tasty (TestTree, defaultMain, testGroup) + +import qualified Spec.Marlowe.StaticAnalysis.Regression (tests) + +-- | Entry point for the tests. +main :: IO () +main = defaultMain tests + +-- | Run the tests. +tests :: TestTree +tests = + testGroup + "StaticAnalysis" + [ Spec.Marlowe.StaticAnalysis.Regression.tests + ] From 06856ba549882e4b2286e7682575e6c02511242a Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Tue, 21 Nov 2023 15:10:51 +0000 Subject: [PATCH 02/14] Added regression test file for Static Analysis. --- .../test/Spec/Marlowe/StaticAnalysis.hs | 5 - .../Spec/Marlowe/StaticAnalysis/Regression.hs | 213 ++++++++++++++++++ 2 files changed, 213 insertions(+), 5 deletions(-) create mode 100644 marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs index 1219a1c655..03dc81521b 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs @@ -12,7 +12,6 @@ -- | Tests of Marlowe semantics. module Spec.Marlowe.StaticAnalysis ( -- * Testing - main, tests, ) where @@ -20,10 +19,6 @@ import Test.Tasty (TestTree, defaultMain, testGroup) import qualified Spec.Marlowe.StaticAnalysis.Regression (tests) --- | Entry point for the tests. -main :: IO () -main = defaultMain tests - -- | Run the tests. tests :: TestTree tests = diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs new file mode 100644 index 0000000000..1e444593e9 --- /dev/null +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -0,0 +1,213 @@ +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +----------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} + +-- | Regression tests for the important behaviour of the Static Analysis functions. +module Spec.Marlowe.StaticAnalysis.Regression ( + -- * Testing + tests, +) where + +import Control.Monad ( + join, + ) +import Language.Marlowe.Util (ada) +import Test.Tasty (TestTree, testGroup) +import Prelude + +import Control.Error (listToMaybe) +import Control.Error.Util (hush) +import Data.Either (fromRight, isRight) +import Data.Functor ((<&>)) +import Data.Maybe (isNothing) +import Language.Marlowe ( + Action (..), + Case (..), + Contract (..), + Observation (..), + Payee (..), + Token (..), + TransactionWarning (..), + Value (..), + ) +import Language.Marlowe.Analysis.FSSemantics (warningsTrace) +import Spec.Marlowe.Common (alicePk) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +isTransactionPartialPay :: TransactionWarning -> Bool +isTransactionPartialPay (TransactionPartialPay{}) = True +isTransactionPartialPay _ = False + +isTransactionNonPositivePay :: TransactionWarning -> Bool +isTransactionNonPositivePay (TransactionNonPositivePay{}) = True +isTransactionNonPositivePay _ = False + +isTransactionNonPositiveDeposit :: TransactionWarning -> Bool +isTransactionNonPositiveDeposit (TransactionNonPositiveDeposit{}) = True +isTransactionNonPositiveDeposit _ = False + +isTransactionShadowing :: TransactionWarning -> Bool +isTransactionShadowing (TransactionShadowing{}) = True +isTransactionShadowing _ = False + +isTransactionAssertionFailed :: TransactionWarning -> Bool +isTransactionAssertionFailed (TransactionAssertionFailed{}) = True +isTransactionAssertionFailed _ = False + +getWarning :: Contract -> IO (Maybe TransactionWarning) +getWarning contract = + warningsTrace contract <&> \res -> do + (_, _, t) <- join $ hush res + listToMaybe t + +analysisWorks :: IO () +analysisWorks = do + let contract n d = + If + (DivValue (Constant n) (Constant d) `ValueGE` Constant 5) + Close + (Pay alicePk (Party alicePk) ada (Constant (-100)) Close) + result <- warningsTrace (contract 10 11) + assertBool "Analyse a contract" $ isRight result + +emptyTrace :: IO () +emptyTrace = do + let contract = Close + result <- warningsTrace contract + assertBool "Empty trace" $ isRight result && isNothing (fromRight Nothing result) + +nonPositivePay :: IO () +nonPositivePay = do + let contract = Pay alicePk (Party alicePk) ada (Constant (-100)) Close + result <- getWarning contract + assertBool "Detect negative pay" $ maybe False isTransactionNonPositivePay result + let contract2 = Pay alicePk (Party alicePk) ada (Constant 0) Close + result2 <- getWarning contract2 + assertBool "Detect zero pay" $ maybe False isTransactionNonPositivePay result2 + +partialPay :: IO () +partialPay = do + let contract = Pay alicePk (Party alicePk) ada (Constant 100) Close + result <- getWarning contract + assertBool "Detect partial pay" $ maybe False isTransactionPartialPay result + +nonPositiveDeposit :: IO () +nonPositiveDeposit = do + let contract v = + When + [ Case + ( Deposit + alicePk + alicePk + (Token "" "") + (Constant v) + ) + Close + ] + 1699974289397 + Close + result <- getWarning (contract (-100)) + assertBool "Negative deposit" $ maybe False isTransactionNonPositiveDeposit result + result2 <- getWarning (contract 0) + assertBool "Zero deposit" $ maybe False isTransactionNonPositiveDeposit result2 + +transactionShadowing :: IO () +transactionShadowing = do + let contract = Let "x" (Constant 1) (Let "x" (Constant 2) Close) + result <- getWarning contract + assertBool "Shadowing x" $ maybe False isTransactionShadowing result + +assertionFailed :: IO () +assertionFailed = do + let contract = Let "x" (Constant 1) (Assert (ValueEQ (UseValue "x") (Constant 2)) Close) + result <- getWarning contract + assertBool "Detect partial pay" $ maybe False isTransactionAssertionFailed result + +-- The current UI drops in instrumentation in the form of assertions and then checks for AssertionFailed +reachability :: IO () +reachability = do + let contract = + Let + "x" + (Constant 1) + ( If + ( ValueGE + (UseValue "x") + (Constant 2) + ) + ( Assert + ( ValueGE + (UseValue "x") + (Constant 2) + ) + Close + ) + ( Assert + ( ValueLT + (UseValue "x") + (Constant 2) + ) + (Assert FalseObs Close) + ) + ) + result <- getWarning contract + assertBool "Detect unreachable path" $ maybe False isTransactionAssertionFailed result + let contract2 = + Let + "x" + (Constant 1) + ( If + ( ValueGE + (UseValue "x") + (Constant 2) + ) + ( Assert + ( ValueGE + (UseValue "x") + (Constant 2) + ) + (Assert FalseObs Close) + ) + ( Assert + ( ValueLT + (UseValue "x") + (Constant 2) + ) + Close + ) + ) + result2 <- getWarning contract2 + assertEqual "Don't trigger a warning on the unreachable path" result2 Nothing + +-- The current UI drops in instrumentation in the form of assertions and then checks for AssertionFailed +fundsOnClose :: IO () +fundsOnClose = do + let contract = + When + [Case (Deposit alicePk alicePk ada (Constant 100)) (Assert (ValueEQ (AvailableMoney alicePk ada) (Constant 0)) Close)] + 1699974289397 + Close + result <- getWarning contract + assertBool "Detect funds on close" $ maybe False isTransactionAssertionFailed result + +tests :: TestTree +tests = + testGroup + "Static Analysis Regression" + [ testCase "Analysis works" analysisWorks + , testCase "Empty trace" emptyTrace + , testCase "Partial Pay" partialPay + , testCase "Non-Positive Pay" nonPositivePay + , testCase "Non-Positive Deposit" nonPositiveDeposit + , testCase "Transaction shadowing" transactionShadowing + , testCase "Assertion failed" assertionFailed + , testCase "Reachability checks" reachability + , testCase "Funds on Close" fundsOnClose + ] From 4bc68478afc0da4f271b65b64231ff24419384ae Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Tue, 21 Nov 2023 15:15:58 +0000 Subject: [PATCH 03/14] Added changelog file. --- marlowe-test/changelog.d/20231121_151418_ramsay.md | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 marlowe-test/changelog.d/20231121_151418_ramsay.md diff --git a/marlowe-test/changelog.d/20231121_151418_ramsay.md b/marlowe-test/changelog.d/20231121_151418_ramsay.md new file mode 100644 index 0000000000..a0c9dc2515 --- /dev/null +++ b/marlowe-test/changelog.d/20231121_151418_ramsay.md @@ -0,0 +1,4 @@ +### Added + +- Regression tests for Static Analysis. Specifically: explicit tests for each of the warning typles, plus reachability and payouts on close. + From 1a2ae2e915cfb2d323401fcc7bdd26e656ddb143 Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Tue, 21 Nov 2023 21:06:56 +0000 Subject: [PATCH 04/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs Co-authored-by: Brian W Bush --- marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs index 03dc81521b..ab272e47fb 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs @@ -15,7 +15,7 @@ module Spec.Marlowe.StaticAnalysis ( tests, ) where -import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty (TestTree, testGroup) import qualified Spec.Marlowe.StaticAnalysis.Regression (tests) From 3a12fbeba33ba81b4a79ea840e7cfc5eb721e588 Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:24:14 +0000 Subject: [PATCH 05/14] Update marlowe-test/changelog.d/20231121_151418_ramsay.md Co-authored-by: Pablo Lamela --- marlowe-test/changelog.d/20231121_151418_ramsay.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-test/changelog.d/20231121_151418_ramsay.md b/marlowe-test/changelog.d/20231121_151418_ramsay.md index a0c9dc2515..bbae219018 100644 --- a/marlowe-test/changelog.d/20231121_151418_ramsay.md +++ b/marlowe-test/changelog.d/20231121_151418_ramsay.md @@ -1,4 +1,4 @@ ### Added -- Regression tests for Static Analysis. Specifically: explicit tests for each of the warning typles, plus reachability and payouts on close. +- Regression tests for Static Analysis. Specifically: explicit tests for each of the warning types, plus reachability and payouts on close. From 6a15872a9e8ad4791ac98654328e53029755b7f8 Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:24:23 +0000 Subject: [PATCH 06/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs Co-authored-by: Pablo Lamela --- marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs index 1e444593e9..d998984381 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Module : $Headers +-- Module : Spec.Marlowe.StaticAnalysis.Regression -- License : Apache 2.0 -- -- Stability : Experimental From f08fce10c7fd0b8bb3f1494106c68330728f266c Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:24:37 +0000 Subject: [PATCH 07/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs Co-authored-by: Pablo Lamela --- marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs index ab272e47fb..c9f2144626 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Module : $Headers +-- Module : Spec.Marlowe.StaticAnalysis -- License : Apache 2.0 -- -- Stability : Experimental From 1cdb2ce7896c6d125b2c6f7e0964607ee58012e6 Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:24:57 +0000 Subject: [PATCH 08/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs Co-authored-by: Pablo Lamela --- marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs index d998984381..c595bb275f 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -15,9 +15,7 @@ module Spec.Marlowe.StaticAnalysis.Regression ( tests, ) where -import Control.Monad ( - join, - ) +import Control.Monad (join) import Language.Marlowe.Util (ada) import Test.Tasty (TestTree, testGroup) import Prelude From 5f2cf47bc96d89397007438d0928a888bec378dd Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:26:48 +0000 Subject: [PATCH 09/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs Co-authored-by: Pablo Lamela --- marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs index c595bb275f..86b14c9946 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -156,7 +156,7 @@ reachability = do ) ) result <- getWarning contract - assertBool "Detect unreachable path" $ maybe False isTransactionAssertionFailed result + assertBool "Detect reachable path" $ maybe False isTransactionAssertionFailed result let contract2 = Let "x" From 21f93ca906563ef61926ab81778bb6f3f9912c71 Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:27:37 +0000 Subject: [PATCH 10/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs Co-authored-by: Pablo Lamela --- marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs index 86b14c9946..2ccca33a58 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -126,7 +126,7 @@ assertionFailed :: IO () assertionFailed = do let contract = Let "x" (Constant 1) (Assert (ValueEQ (UseValue "x") (Constant 2)) Close) result <- getWarning contract - assertBool "Detect partial pay" $ maybe False isTransactionAssertionFailed result + assertBool "Detect wrong assertion" $ maybe False isTransactionAssertionFailed result -- The current UI drops in instrumentation in the form of assertions and then checks for AssertionFailed reachability :: IO () From 82b6efe70fa4ad9b1f4a2b1caaa674dc5760783e Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:28:03 +0000 Subject: [PATCH 11/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs Co-authored-by: Pablo Lamela --- .../test/Spec/Marlowe/StaticAnalysis/Regression.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs index 2ccca33a58..9b9fc925e4 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -83,11 +83,10 @@ emptyTrace = do nonPositivePay :: IO () nonPositivePay = do - let contract = Pay alicePk (Party alicePk) ada (Constant (-100)) Close - result <- getWarning contract + let contract n = Pay alicePk (Party alicePk) ada (Constant n) Close + result <- getWarning $ contract (-100) assertBool "Detect negative pay" $ maybe False isTransactionNonPositivePay result - let contract2 = Pay alicePk (Party alicePk) ada (Constant 0) Close - result2 <- getWarning contract2 + result2 <- getWarning $ contract 0 assertBool "Detect zero pay" $ maybe False isTransactionNonPositivePay result2 partialPay :: IO () From 17d13d7eb4b6ee12faeb36e722446d0c19c9fed1 Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:28:30 +0000 Subject: [PATCH 12/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs Co-authored-by: Pablo Lamela --- .../test/Spec/Marlowe/StaticAnalysis/Regression.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs index 9b9fc925e4..76e1af7b5c 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -61,9 +61,10 @@ isTransactionAssertionFailed _ = False getWarning :: Contract -> IO (Maybe TransactionWarning) getWarning contract = - warningsTrace contract <&> \res -> do - (_, _, t) <- join $ hush res - listToMaybe t + do res <- warningsTrace contract + return $ case res of + Right (Just (_, _, (w:_))) -> Just w + _ -> Nothing analysisWorks :: IO () analysisWorks = do From 6e0132af8cd3da110de239c5f8c43f87a509a3b6 Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:28:53 +0000 Subject: [PATCH 13/14] Update marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs Co-authored-by: Pablo Lamela --- marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs index 76e1af7b5c..8e18f76833 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -80,7 +80,7 @@ emptyTrace :: IO () emptyTrace = do let contract = Close result <- warningsTrace contract - assertBool "Empty trace" $ isRight result && isNothing (fromRight Nothing result) + assertBool "Close passes static analysis" $ isRight result && isNothing (fromRight Nothing result) nonPositivePay :: IO () nonPositivePay = do From 84e1e2968f0329155cd1b03b8e7713de1b5f75ab Mon Sep 17 00:00:00 2001 From: Ramsay Taylor Date: Thu, 23 Nov 2023 09:57:20 +0000 Subject: [PATCH 14/14] Pablo's suggestions made some imports redundant. --- marlowe-test/marlowe-test.cabal | 1 - .../Spec/Marlowe/StaticAnalysis/Regression.hs | 24 +++++++++---------- 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/marlowe-test/marlowe-test.cabal b/marlowe-test/marlowe-test.cabal index 069a033456..d8e4989c45 100644 --- a/marlowe-test/marlowe-test.cabal +++ b/marlowe-test/marlowe-test.cabal @@ -202,7 +202,6 @@ test-suite marlowe-test , cardano-api ^>=8.2 , containers ^>=0.6.5 , data-default ^>=0.7.1 - , errors , filepath ^>=1.4 , hint ^>=0.9 , ilist ==0.4.0.1 diff --git a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs index 8e18f76833..0ca641d08a 100644 --- a/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs +++ b/marlowe-test/test/Spec/Marlowe/StaticAnalysis/Regression.hs @@ -15,15 +15,11 @@ module Spec.Marlowe.StaticAnalysis.Regression ( tests, ) where -import Control.Monad (join) import Language.Marlowe.Util (ada) import Test.Tasty (TestTree, testGroup) import Prelude -import Control.Error (listToMaybe) -import Control.Error.Util (hush) import Data.Either (fromRight, isRight) -import Data.Functor ((<&>)) import Data.Maybe (isNothing) import Language.Marlowe ( Action (..), @@ -61,10 +57,11 @@ isTransactionAssertionFailed _ = False getWarning :: Contract -> IO (Maybe TransactionWarning) getWarning contract = - do res <- warningsTrace contract - return $ case res of - Right (Just (_, _, (w:_))) -> Just w - _ -> Nothing + do + res <- warningsTrace contract + return $ case res of + Right (Just (_, _, w : _)) -> Just w + _ -> Nothing analysisWorks :: IO () analysisWorks = do @@ -72,7 +69,7 @@ analysisWorks = do If (DivValue (Constant n) (Constant d) `ValueGE` Constant 5) Close - (Pay alicePk (Party alicePk) ada (Constant (-100)) Close) + (Pay alicePk (Party alicePk) Language.Marlowe.Util.ada (Constant (-100)) Close) result <- warningsTrace (contract 10 11) assertBool "Analyse a contract" $ isRight result @@ -84,7 +81,7 @@ emptyTrace = do nonPositivePay :: IO () nonPositivePay = do - let contract n = Pay alicePk (Party alicePk) ada (Constant n) Close + let contract n = Pay alicePk (Party alicePk) Language.Marlowe.Util.ada (Constant n) Close result <- getWarning $ contract (-100) assertBool "Detect negative pay" $ maybe False isTransactionNonPositivePay result result2 <- getWarning $ contract 0 @@ -92,7 +89,7 @@ nonPositivePay = do partialPay :: IO () partialPay = do - let contract = Pay alicePk (Party alicePk) ada (Constant 100) Close + let contract = Pay alicePk (Party alicePk) Language.Marlowe.Util.ada (Constant 100) Close result <- getWarning contract assertBool "Detect partial pay" $ maybe False isTransactionPartialPay result @@ -189,7 +186,10 @@ fundsOnClose :: IO () fundsOnClose = do let contract = When - [Case (Deposit alicePk alicePk ada (Constant 100)) (Assert (ValueEQ (AvailableMoney alicePk ada) (Constant 0)) Close)] + [ Case + (Deposit alicePk alicePk Language.Marlowe.Util.ada (Constant 100)) + (Assert (ValueEQ (AvailableMoney alicePk Language.Marlowe.Util.ada) (Constant 0)) Close) + ] 1699974289397 Close result <- getWarning contract