diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs index c8c531e9fbf..620f6eacf79 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Analysis.hs @@ -103,6 +103,7 @@ genProjectedPayoffs getRiskFactors ct@ContractTermsPoly {..} = filtersSchedules :: (EventType, ShiftedDay) -> Bool filtersSchedules (_, ShiftedDay {..}) | contractType == OPTNS = calculationDay > ct_SD + filtersSchedules (_, ShiftedDay {..}) | contractType == FUTUR = calculationDay > ct_SD filtersSchedules (_, ShiftedDay {..}) = isNothing ct_TD || Just calculationDay <= ct_TD filtersStates :: (ContractState, EventType, ShiftedDay) -> Bool diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractState.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractState.hs index a368abbd542..3f321754a17 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractState.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractState.hs @@ -10,7 +10,7 @@ import Language.Marlowe.ACTUS.Definitions.ContractTerms (PRF) -} data ContractStatePoly a b = ContractStatePoly { - tmd :: b -- ^ Maturity Date (MD): The timestamp as per which the contract matures according to the initial terms or as per unscheduled events + tmd :: Maybe b -- ^ Maturity Date (MD): The timestamp as per which the contract matures according to the initial terms or as per unscheduled events , nt :: a -- ^ Notional Principal (NT): The outstanding nominal value , ipnr :: a -- ^ Nominal Interest Rate (IPNR) : The applicable nominal rate , ipac :: a -- ^ Accrued Interest (IPAC): The current value of accrued interest diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs index 73d0c138749..352ef2653bd 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Definitions/ContractTerms.hs @@ -319,6 +319,7 @@ data ContractTermsPoly a b = ContractTermsPoly , ct_STP :: Maybe Cycle -- ^ Settlement Period , ct_DS :: Maybe DS -- ^ Delivery Settlement , ct_XA :: Maybe a -- ^ Exercise Amount + , ct_PFUT :: Maybe a -- ^ Futures Price -- Penalty , ct_PYRT :: Maybe a -- ^ Penalty Rate diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs index 9f36dd0efe3..3e57e5ed4c2 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator.hs @@ -41,7 +41,7 @@ import Language.Marlowe.ACTUS.Definitions.ContractTerms (Ass TermValidationError (..)) import Language.Marlowe.ACTUS.Definitions.Schedule (CashFlow (..), ShiftedDay (..), calculationDay) -import Language.Marlowe.ACTUS.MarloweCompat (constnt, letval, marloweTime, +import Language.Marlowe.ACTUS.MarloweCompat (constnt, letval, letval', marloweTime, timeToSlotNumber, toMarloweFixedPoint, useval) import Language.Marlowe.ACTUS.Model.APPLICABILITY.Applicability (validateTerms) @@ -134,7 +134,7 @@ genFsContract' ct = stateToContract :: ContractStateMarlowe -> Contract -> Contract stateToContract ContractStatePoly {..} = - letval "tmd" i tmd + letval' "tmd" i tmd . letval "nt" i nt . letval "ipnr" i ipnr . letval "ipac" i ipac @@ -144,6 +144,8 @@ genFsContract' ct = . letval "sd" i sd . letval "prnxt" i prnxt . letval "ipcb" i ipcb + . letval' "xa" i xa + . letval' "xd" i xd comment :: EventType -> Contract -> Contract comment IED = letval "IED" i (constnt 0) @@ -167,8 +169,10 @@ genFsContract' ct = feac = useval "feac" $ i P.- 1, ipnr = useval "ipnr" $ i P.- 1, ipcb = useval "ipcb" $ i P.- 1, + xa = Just $ useval "xa" $ i P.- 1, + xd = Just $ useval "xd" $ i P.- 1, prnxt = useval "prnxt" $ i P.- 1, - tmd = useval "tmd" i, + tmd = Just $ useval "tmd" i, prf = undefined, sd = useval "sd" (timeToSlotNumber prevDate) } @@ -236,7 +240,7 @@ genFsContract' ct = stateInitialisation :: ContractState -> Contract -> Contract stateInitialisation ContractStatePoly {..} = - letval "tmd" 0 (marloweTime tmd) + letval' "tmd" 0 (marloweTime <$> tmd) . letval "nt" 0 (constnt nt) . letval "ipnr" 0 (constnt ipnr) . letval "ipac" 0 (constnt ipac) @@ -246,6 +250,8 @@ genFsContract' ct = . letval "sd" 0 (marloweTime sd) . letval "prnxt" 0 (constnt prnxt) . letval "ipcb" 0 (constnt ipcb) + . letval' "xa" 0 (constnt <$> xa) + . letval' "xd" 0 (marloweTime <$> xd) postProcess :: Contract -> Contract postProcess cont = diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs index b53607a4358..708c8bf3e96 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/MarloweCompat.hs @@ -16,6 +16,10 @@ useval name t = UseValue $ ValueId $ fromString $ name ++ "_" ++ show t letval :: String -> Integer -> Value Observation -> Contract -> Contract letval name t = Let $ ValueId $ fromString $ name ++ "_" ++ show t +letval' :: String -> Integer -> Maybe (Value Observation) -> Contract -> Contract +letval' name t (Just o) c = Let (ValueId $ fromString $ name ++ "_" ++ show t) o c +letval' _ _ Nothing c = c + toMarloweFixedPoint :: Double -> Integer toMarloweFixedPoint = round <$> (fromIntegral marloweFixedPoint *) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs index a2a9289127b..cba466b1d71 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/INIT/StateInitializationModel.hs @@ -12,8 +12,9 @@ module Language.Marlowe.ACTUS.Model.INIT.StateInitializationModel ) where +import Control.Applicative ((<|>)) import Control.Monad.Reader (Reader, reader) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, maybeToList) import Data.Time.LocalTime (LocalTime) import Language.Marlowe.ACTUS.Definitions.ContractState (ContractState, ContractStatePoly (..)) import Language.Marlowe.ACTUS.Definitions.ContractTerms (CT (..), ContractTerms, ContractTermsPoly (..), @@ -38,7 +39,7 @@ initializeState = reader initializeState' { sd = t0, prnxt = nextPrincipalRedemptionPayment contractTerms, ipcb = interestPaymentCalculationBase contractTerms, - tmd = contractMaturity maturity, + tmd = maturity, nt = notionalPrincipal contractTerms, ipnr = nominalInterestRate contractTerms, ipac = interestAccrued contractTerms, @@ -47,7 +48,7 @@ initializeState = reader initializeState' isc = interestScaling contractTerms, prf = contractPerformance contractTerms, xd = ct_XD contractTerms, - xa = ct_XA contractTerms + xa = ct_XA contractTerms <|> ct_PFUT contractTerms } where t0 = ct_SD contractTerms @@ -155,7 +156,7 @@ initializeState = reader initializeState' frac = annuity ipnr ti in frac * scale where - prDates = prSchedule ++ [contractMaturity maturity] + prDates = prSchedule ++ maybeToList maturity ti = zipWith (\tn tm -> _y dcc tn tm md) prDates (tail prDates) nextPrincipalRedemptionPayment _ = 0.0 @@ -206,7 +207,3 @@ initializeState = reader initializeState' contractPerformance :: ContractTerms -> PRF contractPerformance ContractTermsPoly {ct_PRF = Just prf} = prf contractPerformance _ = error "PRF is not set in ContractTerms" - - contractMaturity :: Maybe LocalTime -> LocalTime - contractMaturity (Just mat) = mat - contractMaturity _ = error "Maturity is not specified" diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs index 254085cd662..3e8bec439b2 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/POF/Payoff.hs @@ -152,6 +152,16 @@ payoff } _ _ = _POF_PRD_STK cntrl pprd +payoff + PRD + _ + ContractTermsPoly + { contractType = FUTUR, + ct_CNTRL = cntrl, + ct_PPRD = Just pprd + } + _ + _ = _POF_PRD_STK cntrl pprd payoff PRD RiskFactorsPoly {..} @@ -248,4 +258,14 @@ payoff ContractStatePoly { xa = Just exerciseAmount} _ = _POF_STD_OPTNS cntrl o_rf_CURS exerciseAmount +payoff + STD + RiskFactorsPoly {..} + ContractTermsPoly + { contractType = FUTUR, + ct_CNTRL = cntrl + } + ContractStatePoly + { xa = Just exerciseAmount} + _ = _POF_STD_OPTNS cntrl o_rf_CURS exerciseAmount payoff _ _ _ _ _ = _zero diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs index 34d7742d3f5..28225374da5 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/SCHED/ContractSchedule.hs @@ -104,9 +104,9 @@ schedule ev c = schedule' ev c { ct_MD = maturity c } schedule' STD ct@ContractTermsPoly{ contractType = OPTNS } = _SCHED_STD_OPTNS c { ct_MD = ct_MD c <|> ct_MD ct } schedule' PRD ct@ContractTermsPoly{ contractType = FUTUR } = _SCHED_PRD_PAM ct - schedule' MD ct@ContractTermsPoly{ contractType = FUTUR } = _SCHED_MD_PAM c { ct_MD = ct_MD c <|> ct_MD ct } -- TODO schedule' TD ct@ContractTermsPoly{ contractType = FUTUR } = _SCHED_TD_PAM ct - schedule' XD ct@ContractTermsPoly{ contractType = FUTUR } = _SCHED_XD_OPTNS ct + schedule' MD ct@ContractTermsPoly{ contractType = FUTUR } = _SCHED_MD_PAM c { ct_MD = ct_MD c <|> ct_MD ct } -- TODO + schedule' XD ct@ContractTermsPoly{ contractType = FUTUR } = _SCHED_XD_OPTNS ct { ct_MD = ct_MD c <|> ct_MD ct } schedule' STD ct@ContractTermsPoly{ contractType = FUTUR } = _SCHED_STD_OPTNS c { ct_MD = ct_MD c <|> ct_MD ct } schedule' _ _ = [] diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs index 9dc8491ab51..4685d90f18f 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransition.hs @@ -84,6 +84,7 @@ stateTransition ev rf t st@ContractStatePoly{..} = reader stateTransition' stf SC ContractTermsPoly {contractType = NAM, ct_DCC = Just dcc, ct_MD = md} = _STF_SC_LAM contractTerms st rf t (_y dcc sd t md) (_y dcc tfp_minus t md) (_y dcc tfp_minus tfp_plus md) stf SC ContractTermsPoly {contractType = ANN, ct_DCC = Just dcc, ct_MD = md} = _STF_SC_LAM contractTerms st rf t (_y dcc sd t md) (_y dcc tfp_minus t md) (_y dcc tfp_minus tfp_plus md) stf XD ContractTermsPoly {contractType = OPTNS} = _STF_XD_OPTNS contractTerms st rf t + stf XD ContractTermsPoly {contractType = FUTUR} = _STF_XD_FUTUR contractTerms st rf t stf CE ContractTermsPoly {ct_DCC = Just dcc, ct_MD = md} = _STF_CE_PAM st t (_y dcc sd t md) stf _ _ = st diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs index b60d758b91e..b5a2492635c 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Model/STF/StateTransitionModel.hs @@ -675,3 +675,17 @@ _STF_XD_OPTNS _ st _ t = st { sd = t } + +_STF_XD_FUTUR :: ActusNum a => ContractTermsPoly a b -> ContractStatePoly a b -> RiskFactorsPoly a -> b -> ContractStatePoly a b +_STF_XD_FUTUR + ContractTermsPoly + { ct_PFUT = Just futuresPrice + } + st + RiskFactorsPoly {..} + t = st + { xa = Just $ pp_payoff - futuresPrice, + sd = t + } +_STF_XD_FUTUR _ _ _ _ = undefined + diff --git a/marlowe-actus/test/Spec.hs b/marlowe-actus/test/Spec.hs index 29eb5517972..3eef63b62e2 100644 --- a/marlowe-actus/test/Spec.hs +++ b/marlowe-actus/test/Spec.hs @@ -22,7 +22,7 @@ main = do $ p ++ "actus-tests-ann.json" stkTests <- testCasesFromFile [] $ p ++ "actus-tests-stk.json" optnsTests <- testCasesFromFile [] $ p ++ "actus-tests-optns.json" - -- futurTests <- testCasesFromFile [] $ p ++ "actus-tests-futur.json" + futurTests <- testCasesFromFile [] $ p ++ "actus-tests-futur.json" defaultMain $ testGroup @@ -35,7 +35,7 @@ main = do , Spec.Marlowe.ACTUS.TestFramework.tests "ANN" annTests , Spec.Marlowe.ACTUS.TestFramework.tests "STK" stkTests , Spec.Marlowe.ACTUS.TestFramework.tests "OPTNS" optnsTests - -- , Spec.Marlowe.ACTUS.TestFramework.tests "FUTUR" futurTests + , Spec.Marlowe.ACTUS.TestFramework.tests "FUTUR" futurTests ], testGroup "ACTUS examples" diff --git a/marlowe-actus/test/Spec/Marlowe/ACTUS/Examples.hs b/marlowe-actus/test/Spec/Marlowe/ACTUS/Examples.hs index d7276773a8f..06a0ecf20de 100644 --- a/marlowe-actus/test/Spec/Marlowe/ACTUS/Examples.hs +++ b/marlowe-actus/test/Spec/Marlowe/ACTUS/Examples.hs @@ -47,10 +47,12 @@ example01 = ContractTermsPoly { contractId = "0", contractType = PAM, + contractStructure = [], ct_IED = iso8601ParseM "2020-01-01T00:00:00", ct_SD = fromJust $ iso8601ParseM "2019-12-31T00:00:00", ct_MD = iso8601ParseM "2030-01-01T00:00:00", ct_AD = Nothing, + ct_XD = Nothing, ct_TD = Nothing, ct_PRNXT = Nothing, ct_PRD = Nothing, @@ -71,9 +73,6 @@ example01 = -- Penalties ct_PYRT = Nothing, ct_PYTP = Just PYTP_O, -- no penalty - -- Optionality - ct_OPCL = Nothing, - ct_OPANX = Nothing, -- Scaling ct_SCIP = Nothing, ct_SCIED = Nothing, @@ -83,6 +82,17 @@ example01 = ct_SCNT = Nothing, ct_SCCL = Nothing, ct_SCANX = Nothing, + -- Optionality + ct_OPCL = Nothing, + ct_OPANX = Nothing, + ct_OPTP = Nothing, + ct_OPS1 = Nothing, + ct_OPXT = Nothing, + -- Settlement + ct_STP = Nothing, + ct_DS = Nothing, + ct_XA = Nothing, + ct_PFUT = Nothing, -- Rate Reset ct_RRCL = Nothing, ct_RRANX = Nothing, @@ -113,6 +123,10 @@ example01 = ct_FEB = Nothing, ct_FER = Nothing, ct_CURS = Nothing, + -- Dividend + ct_DVCL = Nothing, + ct_DVANX = Nothing, + ct_DVNP = Nothing, enableSettlement = False, constraints = Nothing, collateralAmount = 0 @@ -178,10 +192,12 @@ example02 = ContractTermsPoly { contractId = "0", contractType = LAM, + contractStructure = [], ct_IED = iso8601ParseM "2020-01-01T00:00:00", ct_SD = fromJust $ iso8601ParseM "2019-12-31T00:00:00", ct_MD = iso8601ParseM "2030-01-01T00:00:00", ct_AD = Nothing, + ct_XD = Nothing, ct_TD = Nothing, ct_PRNXT = Just 1000.0, ct_PRD = Nothing, @@ -205,6 +221,14 @@ example02 = -- Optionality ct_OPCL = Nothing, ct_OPANX = Nothing, + ct_OPTP = Nothing, + ct_OPS1 = Nothing, + ct_OPXT = Nothing, + -- Settlement + ct_STP = Nothing, + ct_DS = Nothing, + ct_XA = Nothing, + ct_PFUT = Nothing, -- Scaling ct_SCIP = Nothing, ct_SCIED = Nothing, @@ -244,6 +268,10 @@ example02 = ct_FEB = Nothing, ct_FER = Nothing, ct_CURS = Nothing, + -- Dividend + ct_DVCL = Nothing, + ct_DVANX = Nothing, + ct_DVNP = Nothing, enableSettlement = False, constraints = Nothing, collateralAmount = 0 @@ -309,10 +337,12 @@ example03 = ContractTermsPoly { contractId = "0", contractType = NAM, + contractStructure = [], ct_IED = iso8601ParseM "2020-01-01T00:00:00", ct_SD = fromJust $ iso8601ParseM "2019-12-31T00:00:00", ct_MD = iso8601ParseM "2030-01-01T00:00:00", ct_AD = Nothing, + ct_XD = Nothing, ct_TD = Nothing, ct_PRNXT = Just 1000.0, ct_PRD = Nothing, @@ -336,6 +366,14 @@ example03 = -- Optionality ct_OPCL = Nothing, ct_OPANX = Nothing, + ct_OPTP = Nothing, + ct_OPS1 = Nothing, + ct_OPXT = Nothing, + -- Settlement + ct_STP = Nothing, + ct_DS = Nothing, + ct_XA = Nothing, + ct_PFUT = Nothing, -- Scaling ct_SCIP = Nothing, ct_SCIED = Nothing, @@ -375,6 +413,10 @@ example03 = ct_FEB = Nothing, ct_FER = Nothing, ct_CURS = Nothing, + -- Dividend + ct_DVCL = Nothing, + ct_DVANX = Nothing, + ct_DVNP = Nothing, enableSettlement = False, constraints = Nothing, collateralAmount = 0 @@ -440,10 +482,12 @@ example04 = ContractTermsPoly { contractId = "0", contractType = ANN, + contractStructure = [], ct_IED = iso8601ParseM "2020-01-01T00:00:00", ct_SD = fromJust $ iso8601ParseM "2019-12-31T00:00:00", ct_MD = iso8601ParseM "2030-01-01T00:00:00", ct_AD = Nothing, + ct_XD = Nothing, ct_TD = Nothing, ct_PRNXT = Just 1000, ct_PRD = Nothing, @@ -467,6 +511,14 @@ example04 = -- Optionality ct_OPCL = Nothing, ct_OPANX = Nothing, + ct_OPTP = Nothing, + ct_OPS1 = Nothing, + ct_OPXT = Nothing, + -- Settlement + ct_STP = Nothing, + ct_DS = Nothing, + ct_XA = Nothing, + ct_PFUT = Nothing, -- Scaling ct_SCIP = Nothing, ct_SCIED = Nothing, @@ -506,6 +558,10 @@ example04 = ct_FEB = Nothing, ct_FER = Nothing, ct_CURS = Nothing, + -- Dividend + ct_DVCL = Nothing, + ct_DVANX = Nothing, + ct_DVNP = Nothing, enableSettlement = False, constraints = Nothing, collateralAmount = 0 diff --git a/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFramework.hs b/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFramework.hs index 8fc40e76f58..4ca45fbd2c4 100644 --- a/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFramework.hs +++ b/marlowe-actus/test/Spec/Marlowe/ACTUS/TestFramework.hs @@ -75,8 +75,9 @@ runTest tc@TestCase {..} = _ -> riskFactors {o_rf_CURS = value} cashFlows = genProjectedCashflows getRiskFactors contract + po = genProjectedPayoffs getRiskFactors contract cashFlowsTo = maybe cashFlows (\d -> filter (\cf -> cashCalculationDay cf <= d) cashFlows) (parseDate to) - -- in pTraceShow (contract, cashFlowsTo) $ assertTestResults cashFlowsTo results identifier + -- in pTraceShow (contract, po, cashFlowsTo) $ assertTestResults cashFlowsTo results identifier in assertTestResults cashFlowsTo results identifier testCasesFromFile :: [String] -> FilePath -> IO [TestCase] @@ -293,6 +294,7 @@ testToContractTerms tc@TestCase{terms = t} = , ct_XA = readMaybe $ Map.lookup "exerciseAmount" terms' :: Maybe Double , ct_DS = readMaybe (maybeConcatPrefix "DS_" (Map.lookup "deliverySettlement" terms')) :: Maybe DS , ct_XD = parseMaybeDate $ Map.lookup "exerciseDate" terms' + , ct_PFUT = readMaybe $ Map.lookup "futuresPrice" terms' :: Maybe Double , enableSettlement = False , constraints = Nothing , collateralAmount = 0