From 33e3dbdbccff02a50d7fc001eec07e79a7260bc3 Mon Sep 17 00:00:00 2001 From: Yves Hauser Date: Mon, 17 Jan 2022 13:00:23 +0100 Subject: [PATCH] SCP-3192: Running test cases converted to Marlowe --- marlowe-actus/marlowe-actus.cabal | 1 + marlowe-actus/test/Spec.hs | 9 ++ .../test/Spec/Marlowe/ACTUS/TestFramework.hs | 2 + .../Marlowe/ACTUS/TestFrameworkMarlowe.hs | 89 +++++++++++++++++++ 4 files changed, 101 insertions(+) create mode 100644 marlowe-actus/test/Spec/Marlowe/ACTUS/TestFrameworkMarlowe.hs diff --git a/marlowe-actus/marlowe-actus.cabal b/marlowe-actus/marlowe-actus.cabal index 15c3c67e98..10b8949111 100644 --- a/marlowe-actus/marlowe-actus.cabal +++ b/marlowe-actus/marlowe-actus.cabal @@ -96,6 +96,7 @@ test-suite marlowe-actus-test other-modules: Spec.Marlowe.ACTUS.Examples Spec.Marlowe.ACTUS.TestFramework + Spec.Marlowe.ACTUS.TestFrameworkMarlowe Spec.Marlowe.ACTUS.QCGenerator Spec.Marlowe.ACTUS.QCTests build-depends: diff --git a/marlowe-actus/test/Spec.hs b/marlowe-actus/test/Spec.hs index 0b7dc8f2b1..c0ca765b59 100644 --- a/marlowe-actus/test/Spec.hs +++ b/marlowe-actus/test/Spec.hs @@ -5,6 +5,7 @@ module Main (main) where import Spec.Marlowe.ACTUS.Examples import Spec.Marlowe.ACTUS.QCTests import Spec.Marlowe.ACTUS.TestFramework +import Spec.Marlowe.ACTUS.TestFrameworkMarlowe import System.Environment import Test.Tasty @@ -45,6 +46,14 @@ main = do , Spec.Marlowe.ACTUS.TestFramework.tests "CEG" cegTests -- , Spec.Marlowe.ACTUS.TestFramework.tests "CEC" cecTests ], + testGroup + "ACTUS test-framework Marlowe" + [ Spec.Marlowe.ACTUS.TestFrameworkMarlowe.tests "PAM" pamTests + , Spec.Marlowe.ACTUS.TestFrameworkMarlowe.tests "LAM" lamTests + -- TODO: uncomment when Slot is replaced with POSIXTime + -- , Spec.Marlowe.ACTUS.TestFrameworkMarlowe.tests "NAM" namTests + -- , Spec.Marlowe.ACTUS.TestFrameworkMarlowe.tests "ANN" annTests + ], testGroup "ACTUS examples" [ Spec.Marlowe.ACTUS.Examples.tests diff --git a/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFramework.hs b/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFramework.hs index df73e0f1de..b579cd7d01 100644 --- a/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFramework.hs +++ b/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFramework.hs @@ -15,6 +15,8 @@ module Spec.Marlowe.ACTUS.TestFramework ( tests , testCasesFromFile + , TestCase (..) + , TestResult (..) ) where diff --git a/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFrameworkMarlowe.hs b/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFrameworkMarlowe.hs new file mode 100644 index 0000000000..57de69e682 --- /dev/null +++ b/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFrameworkMarlowe.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Spec.Marlowe.ACTUS.TestFrameworkMarlowe + ( tests + ) + where + +import Control.Monad.Reader (Reader, ask, runReader) +import Data.Time (LocalTime (..)) +import GHC.Records (getField) +import Language.Marlowe.ACTUS.Domain.BusinessEvents +import Language.Marlowe.ACTUS.Domain.ContractTerms hiding (Assertion) +import Language.Marlowe.ACTUS.Domain.Ops +import Language.Marlowe.ACTUS.Domain.Schedule +import Language.Marlowe.ACTUS.Generator.Analysis +import Language.Marlowe.ACTUS.Generator.MarloweCompat (toMarlowe) +import Language.Marlowe.ACTUS.Model.ContractSchedule as S (maturity, schedule) +import Language.Marlowe.ACTUS.Model.StateTransition (CtxSTF (..)) +import Spec.Marlowe.ACTUS.TestFramework hiding (tests) +import Test.Tasty +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase) +import Text.Printf (printf) + +tests :: String -> [TestCase] -> TestTree +tests n t = + testGroup + n + [testCase (getField @"identifier" tc) (runTest tc {terms = setDefaultContractTermValues (terms tc)}) | tc <- t] + where + runTest :: TestCase -> Assertion + runTest tc@TestCase {..} = + let cashFlows = + runReader + (run tc) + $ CtxSTF + (toMarlowe terms) + (calculationDay <$> schedule FP terms) + (calculationDay <$> schedule PR terms) + (calculationDay <$> schedule IP terms) + (S.maturity terms) + defaultRiskFactors + + in assertTestResults cashFlows results + + assertTestResults :: (RoleSignOps a, ScheduleOps a, YearFractionOps a) => + [CashFlowPoly a] -> [TestResult] -> IO () + assertTestResults [] [] = return () + assertTestResults (cf : cfs) (r : rs) = assertTestResult cf r >> assertTestResults cfs rs + assertTestResults _ _ = assertFailure "Sizes differ" + + assertTestResult :: CashFlowPoly a -> TestResult -> IO () + assertTestResult CashFlowPoly {..} TestResult {eventDate, eventType} = do + assertEqual cashEvent eventType + assertEqual cashPaymentDay eventDate + -- assertEqual (reduce amount) (constnt payoff) + where + assertEqual a b = assertBool (err a b) $ a == b + err a b = printf "Mismatch: actual %s, expected %s" (show a) (show b) + +defaultRiskFactors :: ActusOps a => EventType -> LocalTime -> RiskFactorsPoly a +defaultRiskFactors _ _ = + RiskFactorsPoly + { o_rf_CURS = _one, + o_rf_RRMO = _one, + o_rf_SCMO = _one, + pp_payoff = _zero, + xd_payoff = _zero, + dv_payoff = _zero + } + +run :: (RoleSignOps a, ScheduleOps a, YearFractionOps a) => + TestCase -> Reader (CtxSTF a) [CashFlowPoly a] +run TestCase {..} = do + ctx <- ask + pof <- genProjectedPayoffs + let schedCfs = genCashflow (contractTerms ctx) <$> pof + return $ maybe schedCfs (\d -> filter ((<= d) . cashCalculationDay) schedCfs) to