diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/BusinessEvents.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/BusinessEvents.hs index 608281e79e..cb7fe24638 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/BusinessEvents.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/BusinessEvents.hs @@ -6,7 +6,7 @@ module Language.Marlowe.ACTUS.Domain.BusinessEvents where import Data.Aeson.Types (FromJSON, ToJSON) import GHC.Generics (Generic) -import Language.Marlowe (Observation, Value) +import Language.Marlowe (PubKeyHash, Token, Value) {-| ACTUS event types https://github.com/actusfrf/actus-dictionary/blob/master/actus-dictionary-event.json @@ -54,4 +54,4 @@ data RiskFactorsPoly a = RiskFactorsPoly deriving anyclass (FromJSON, ToJSON) type RiskFactors = RiskFactorsPoly Double -type RiskFactorsMarlowe = RiskFactorsPoly (Value Observation) +type RiskFactorsMarlowe = RiskFactorsPoly (Value PubKeyHash Token) diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/ContractState.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/ContractState.hs index 8e99c9188d..1a90e2f251 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/ContractState.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/ContractState.hs @@ -9,7 +9,7 @@ module Language.Marlowe.ACTUS.Domain.ContractState where import Data.Aeson.Types (ToJSON) import Data.Time (LocalTime) import GHC.Generics (Generic) -import Language.Marlowe (Observation, Value) +import Language.Marlowe (PubKeyHash, Token, Value) import Language.Marlowe.ACTUS.Domain.ContractTerms (PRF) {-| ACTUS contract states are defined in @@ -37,7 +37,7 @@ data ContractStatePoly a = ContractStatePoly deriving stock (Show, Eq) type ContractState = ContractStatePoly Double -type ContractStateMarlowe = ContractStatePoly (Value Observation) +type ContractStateMarlowe = ContractStatePoly (Value PubKeyHash Token) deriving instance Generic ContractState deriving instance ToJSON ContractState diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/ContractTerms.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/ContractTerms.hs index 973c8df7f7..35261363c2 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/ContractTerms.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/ContractTerms.hs @@ -18,7 +18,7 @@ import Data.Text as T hiding (reverse, takeWhile) import Data.Text.Read as T import Data.Time (Day, LocalTime) import GHC.Generics (Generic) -import qualified Language.Marlowe as Marlowe (Observation, Value) +import qualified Language.Marlowe as Marlowe (PubKeyHash, Token, Value) -- |ContractType data CT = PAM -- ^ Principal at maturity @@ -585,7 +585,7 @@ instance FromJSON ContractTerms where parseJSON _ = mzero type ContractTerms = ContractTermsPoly Double -type ContractTermsMarlowe = ContractTermsPoly (Marlowe.Value Marlowe.Observation) +type ContractTermsMarlowe = ContractTermsPoly (Marlowe.Value Marlowe.PubKeyHash Marlowe.Token) setDefaultContractTermValues :: ContractTerms -> ContractTerms setDefaultContractTermValues ct@ContractTermsPoly {..} = diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/Ops.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/Ops.hs index fbe18fa721..4c7053dd9d 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/Ops.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Domain/Ops.hs @@ -4,7 +4,7 @@ module Language.Marlowe.ACTUS.Domain.Ops where import Data.Time (LocalTime) -import Language.Marlowe (Observation (..), Value (..)) +import Language.Marlowe (Observation (..), PubKeyHash, Token, Value, Value_ (..)) import Language.Marlowe.ACTUS.Domain.ContractTerms (CR (..), DCC (..)) import Language.Marlowe.ACTUS.Utility.YearFraction (yearFraction) @@ -49,7 +49,7 @@ class (ActusNum a, ActusOps a) => RoleSignOps a where _r CR_PF = _negate _one instance RoleSignOps Double -instance RoleSignOps (Value Observation) +instance RoleSignOps (Value PubKeyHash Token) instance ActusOps Double where _min = min @@ -72,12 +72,12 @@ instance YearFractionOps Double where instance ScheduleOps Double where _ceiling = ceiling -instance YearFractionOps (Value Observation) where +instance YearFractionOps (Value PubKeyHash Token) where _y a b c d = Constant . toMarloweFixedPoint $ yearFraction a b c d where toMarloweFixedPoint = round <$> (fromIntegral marloweFixedPoint Prelude.*) -instance ScheduleOps (Value Observation) where +instance ScheduleOps (Value PubKeyHash Token) where _ceiling (Constant a) = a `div` marloweFixedPoint -- ACTUS is implemented only for Fixed Schedules -- that means schedules are known before the contract @@ -85,7 +85,7 @@ instance ScheduleOps (Value Observation) where -- riskfactors _ceiling _ = error "Precondition: Fixed schedules" -instance ActusOps (Value Observation) where +instance ActusOps (Value PubKeyHash Token) where _min a b = Cond (ValueLT a b) a b _max a b = Cond (ValueGT a b) a b _abs a = _max a (SubValue _zero a) @@ -97,7 +97,7 @@ instance ActusOps (Value Observation) where infixl 7 *, / infixl 6 +, - -instance ActusNum (Value Observation) where +instance ActusNum (Value PubKeyHash Token) where -- add x + (Constant 0) = x (Constant 0) + y = y diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/Generator.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/Generator.hs index 7df5a66271..f10f4c0826 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/Generator.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/Generator.hs @@ -10,11 +10,11 @@ module Language.Marlowe.ACTUS.Generator.Generator where import Data.String (IsString (fromString)) -import Language.Marlowe (Action (..), Case (..), Contract (..), Observation (..), POSIXTime (..), Party (..), - Payee (..), Value (..), ada) +import Language.Marlowe (Action (..), Case_ (..), Contract (..), POSIXTime (..), Party (..), Payee (..), PubKeyHash, + Token, Value, ada) import Ledger.Value (TokenName (TokenName)) -invoice :: String -> String -> Value Observation -> POSIXTime -> Contract -> Contract +invoice :: String -> String -> Value PubKeyHash Token -> POSIXTime -> Contract PubKeyHash Token -> Contract PubKeyHash Token invoice from to amount timeout continue = let party = Role $ TokenName $ fromString from counterparty = Role $ TokenName $ fromString to diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/GeneratorFs.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/GeneratorFs.hs index 0062e0e2a3..f002103a26 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/GeneratorFs.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/GeneratorFs.hs @@ -32,19 +32,19 @@ import Language.Marlowe.ACTUS.Model.Applicability (validateTerms) -- to genereate a Marlowe contract with risk factors observed at a given point -- in time genFsContract :: - (EventType -> LocalTime -> RiskFactorsMarlowe) -- ^ Risk factors per event and time - -> ContractTermsMarlowe -- ^ ACTUS contract terms - -> Validation [TermValidationError] Contract -- ^ Marlowe contract or applicabilty errors + (EventType -> LocalTime -> RiskFactorsMarlowe) -- ^ Risk factors per event and time + -> ContractTermsMarlowe -- ^ ACTUS contract terms + -> Validation [TermValidationError] (Contract PubKeyHash Token) -- ^ Marlowe contract or applicabilty errors genFsContract rf = fmap (genFsContract' rf) . validateTerms genFsContract' :: (EventType -> LocalTime -> RiskFactorsMarlowe) -> ContractTermsMarlowe -> - Contract + Contract PubKeyHash Token genFsContract' rf ct = let cfs = genProjectedCashflows rf ct - gen :: CashFlowPoly (Value Observation) -> Contract -> Contract + gen :: CashFlowPoly (Value PubKeyHash Token) -> Contract PubKeyHash Token -> Contract PubKeyHash Token gen CashFlowPoly {..} cont = let t = POSIXTime $ timeToSlotNumber cashPaymentDay a = reduce $ DivValue amount (Constant marloweFixedPoint) @@ -88,7 +88,7 @@ genFsContract' rf ct = ) in foldl' (flip gen) Close $ reverse cfs -reduceObservation :: Observation -> Observation +reduceObservation :: Observation i t -> Observation i t reduceObservation (AndObs a b) = AndObs (reduceObservation a) (reduceObservation b) reduceObservation (OrObs a b) = OrObs (reduceObservation a) (reduceObservation b) reduceObservation (NotObs a) = NotObs (reduceObservation a) @@ -99,7 +99,7 @@ reduceObservation (ValueLT a b) = ValueLT (reduce a) (reduce b) reduceObservation (ValueEQ a b) = ValueEQ (reduce a) (reduce b) reduceObservation x = x -reduce :: Value Observation -> Value Observation +reduce :: Value i t -> Value i t reduce (ChoiceValue i) = ChoiceValue i reduce (UseValue i) = UseValue i reduce (Constant i) = Constant i diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/GeneratorStatic.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/GeneratorStatic.hs index da016c7530..0b2d0a602b 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/GeneratorStatic.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/GeneratorStatic.hs @@ -14,7 +14,7 @@ where import Data.List as L (foldl') import Data.Time (LocalTime) import Data.Validation (Validation (..)) -import Language.Marlowe (Contract (..), POSIXTime (..), Value (..)) +import Language.Marlowe (Contract (..), POSIXTime (..), PubKeyHash, Token, Value_ (..)) import Language.Marlowe.ACTUS.Domain.BusinessEvents (EventType (..), RiskFactors) import Language.Marlowe.ACTUS.Domain.ContractTerms (ContractTerms, TermValidationError (..)) import Language.Marlowe.ACTUS.Domain.Schedule (CashFlowPoly (..)) @@ -27,16 +27,16 @@ import Language.Marlowe.ACTUS.Model.Applicability (validateTerms) -- Marlowe contract with risk factors known in advance. The contract therefore -- only consists of transactions, i.e. 'Deposit' and 'Pay' genStaticContract :: - (EventType -> LocalTime -> RiskFactors) -- ^ Risk factors per event and time - -> ContractTerms -- ^ ACTUS contract terms - -> Validation [TermValidationError] Contract -- ^ Marlowe contract or applicability errors + (EventType -> LocalTime -> RiskFactors) -- ^ Risk factors per event and time + -> ContractTerms -- ^ ACTUS contract terms + -> Validation [TermValidationError] (Contract PubKeyHash Token) -- ^ Marlowe contract or applicability errors genStaticContract rf = fmap (genStaticContract' rf) . validateTerms -- |Same as 'genStaticContract' without validation genStaticContract' :: (EventType -> LocalTime -> RiskFactors) -> ContractTerms - -> Contract + -> Contract PubKeyHash Token genStaticContract' rf ct = let cfs = genProjectedCashflows rf ct gen CashFlowPoly {..} diff --git a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/MarloweCompat.hs b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/MarloweCompat.hs index 55630fce59..dadb6305ee 100644 --- a/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/MarloweCompat.hs +++ b/marlowe-actus/src/Language/Marlowe/ACTUS/Generator/MarloweCompat.hs @@ -7,24 +7,24 @@ module Language.Marlowe.ACTUS.Generator.MarloweCompat where import Data.String (IsString (fromString)) import Data.Time (Day, LocalTime (..), UTCTime (UTCTime), timeOfDayToTime) import Data.Time.Clock.System (SystemTime (MkSystemTime), utcToSystemTime) -import Language.Marlowe (Contract (Let), Observation, Value (Constant, UseValue), ValueId (ValueId)) +import Language.Marlowe (Contract (Let), PubKeyHash, Token, Value, ValueId (ValueId), Value_ (Constant, UseValue)) import Language.Marlowe.ACTUS.Domain.ContractTerms import Language.Marlowe.ACTUS.Domain.Ops (marloweFixedPoint) -useval :: String -> Integer -> Value Observation +useval :: String -> Integer -> Value i t useval name t = UseValue $ ValueId $ fromString $ name ++ "_" ++ show t -letval :: String -> Integer -> Value Observation -> Contract -> Contract +letval :: String -> Integer -> Value i t -> Contract i t -> Contract i t letval name t = Let $ ValueId $ fromString $ name ++ "_" ++ show t -letval' :: String -> Integer -> Maybe (Value Observation) -> Contract -> Contract +letval' :: String -> Integer -> Maybe (Value i t) -> Contract i t -> Contract i t letval' name t (Just o) c = letval name t o c letval' _ _ Nothing c = c toMarloweFixedPoint :: Double -> Integer toMarloweFixedPoint = round <$> (fromIntegral marloweFixedPoint *) -constnt :: Double -> Value Observation +constnt :: Double -> Value i t constnt = Constant . toMarloweFixedPoint enum :: a -> a @@ -43,10 +43,10 @@ timeToSlotNumber LocalTime {..} = let (MkSystemTime secs _) = utcToSystemTime (UTCTime localDay (timeOfDayToTime localTimeOfDay)) in fromIntegral secs - cardanoEpochStart -marloweDate :: Day -> Value Observation +marloweDate :: Day -> Value i t marloweDate = Constant . fromInteger . dayToSlotNumber -marloweTime :: LocalTime -> Value Observation +marloweTime :: LocalTime -> Value i t marloweTime = Constant . fromInteger . timeToSlotNumber toMarlowe :: ContractTerms -> ContractTermsMarlowe @@ -130,7 +130,7 @@ toMarlowe ct = constraints = constraints ct } where - trans :: ContractStructure Double -> ContractStructure (Value Observation) + trans :: ContractStructure Double -> ContractStructure (Value PubKeyHash Token) trans cs = cs { reference = case reference cs of ReferenceId r -> ReferenceId r ReferenceTerms t -> ReferenceTerms $ toMarlowe t } diff --git a/marlowe-actus/test/Spec/Marlowe/ACTUS/Examples.hs b/marlowe-actus/test/Spec/Marlowe/ACTUS/Examples.hs index 5f21d4e220..7ee4761d88 100644 --- a/marlowe-actus/test/Spec/Marlowe/ACTUS/Examples.hs +++ b/marlowe-actus/test/Spec/Marlowe/ACTUS/Examples.hs @@ -375,8 +375,8 @@ defaultRiskFactors _ _ = } -- |totalPayments calculates the sum of the payments provided as argument -totalPayments :: Payee -> [Payment] -> Integer +totalPayments :: Payee PubKeyHash -> [Payment PubKeyHash Token] -> Integer totalPayments payee = sum . map m . filter f where - m (Payment _ _ mon) = Val.valueOf mon "" "" + m (Payment _ _ mon) = Val.valueOf (moneyToValue mon) "" "" f (Payment _ pay _) = pay == payee diff --git a/marlowe-cli/src/Language/Marlowe/CLI/ChainIndex.hs b/marlowe-cli/src/Language/Marlowe/CLI/ChainIndex.hs index 248f8f4d40..c95e8e15a4 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/ChainIndex.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/ChainIndex.hs @@ -42,8 +42,10 @@ import Language.Marlowe.CLI.IO (liftCli, maybeWriteJson) import Language.Marlowe.CLI.Types (CliError (..), OutputQuery (..)) import Language.Marlowe.Client.History (histories) import Language.Marlowe.Core.V1.Semantics (MarloweData (..), MarloweParams (..)) +import Language.Marlowe.Core.V1.Semantics.Token (Token) import Language.Marlowe.Scripts (smallUntypedValidator) import Ledger (ciTxOutDatum, ciTxOutValue, toTxOut) +import Ledger.Crypto (PubKeyHash) import Ledger.Scripts (validatorHash) import Ledger.TimeSlot (SlotConfig) import Ledger.Tx.CardanoAPI (fromCardanoAddress, fromCardanoTxId, fromCardanoValue) @@ -148,7 +150,7 @@ queryApp runApi params spent outputFile = let credential = ScriptCredential . validatorHash . validatorScript $ smallUntypedValidator params result <- runApi $ queryScript spent credential - maybeWriteJson outputFile (result :: [TxOutMarlowe MarloweData]) + maybeWriteJson outputFile (result :: [TxOutMarlowe (MarloweData PubKeyHash Token)]) -- | Query state of the Marlowe payout script. diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Command/Input.hs b/marlowe-cli/src/Language/Marlowe/CLI/Command/Input.hs index db4abf271c..9e07008156 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Command/Input.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Command/Input.hs @@ -25,7 +25,9 @@ module Language.Marlowe.CLI.Command.Input ( import Control.Monad.Except (MonadIO) import Language.Marlowe.CLI.Command.Parse (parseParty, parseToken) import Language.Marlowe.CLI.Run (makeChoice, makeDeposit, makeNotification) -import Language.Marlowe.Core.V1.Semantics.Types (AccountId, ChoiceName, ChosenNum, Party, Token) +import Language.Marlowe.Core.V1.Semantics.Token (Token) +import Language.Marlowe.Core.V1.Semantics.Types (AccountId, ChoiceName, ChosenNum, Party) +import Ledger.Crypto (PubKeyHash) import qualified Options.Applicative as O @@ -35,19 +37,19 @@ data InputCommand = -- | Input a deposit to a contract. InputDeposit { - account :: AccountId -- ^ The account for the deposit. - , party :: Party -- ^ The party making the deposit. - , token :: Maybe Token -- ^ The token being deposited, if not Ada. - , amount :: Integer -- ^ The amount of the token deposited. - , outputFile :: Maybe FilePath -- ^ The output JSON file representing the input. + account :: AccountId PubKeyHash -- ^ The account for the deposit. + , party :: Party PubKeyHash -- ^ The party making the deposit. + , token :: Maybe Token -- ^ The token being deposited, if not Ada. + , amount :: Integer -- ^ The amount of the token deposited. + , outputFile :: Maybe FilePath -- ^ The output JSON file representing the input. } -- | Input a choice to a contract. | InputChoice { - choiceName :: ChoiceName -- ^ The name of the choice made. - , choiceParty :: Party -- ^ The party making the choice. - , chosen :: ChosenNum -- ^ The number chosen. - , outputFile :: Maybe FilePath -- ^ The output JSON file representing the input. + choiceName :: ChoiceName -- ^ The name of the choice made. + , choiceParty :: Party PubKeyHash -- ^ The party making the choice. + , chosen :: ChosenNum -- ^ The number chosen. + , outputFile :: Maybe FilePath -- ^ The output JSON file representing the input. } -- | Input a notification to a contract. | InputNotify diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Command/Parse.hs b/marlowe-cli/src/Language/Marlowe/CLI/Command/Parse.hs index 4ab1485f18..0909339b18 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Command/Parse.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Command/Parse.hs @@ -52,7 +52,8 @@ import Control.Applicative ((<|>)) import Data.List.Split (splitOn) import Language.Marlowe.CLI.Types (OutputQuery (..)) import Language.Marlowe.Client (MarloweClientInput (..)) -import Language.Marlowe.Core.V1.Semantics.Types (ChoiceId (..), Input (..), InputContent (..), Party (..), Token (..)) +import Language.Marlowe.Core.V1.Semantics.Token (Token (..)) +import Language.Marlowe.Core.V1.Semantics.Types (ChoiceId (..), Input (..), InputContent (..), Party (..)) import Ledger (POSIXTime (..)) import Plutus.V1.Ledger.Ada (adaSymbol, adaToken) import Plutus.V1.Ledger.Api (BuiltinByteString, CurrencySymbol (..), PubKeyHash (..), TokenName (..), toBuiltin) @@ -227,7 +228,7 @@ readAddressAnyEither s = -- | Parser for `Party`. -parseParty :: O.ReadM Party +parseParty :: O.ReadM (Party PubKeyHash) parseParty = O.eitherReader readPartyPkEither <|> O.eitherReader readPartyRoleEither @@ -235,8 +236,8 @@ parseParty = -- | Reader for `Party` `PK`. -readPartyPkEither :: String -- ^ The string to be read. - -> Either String Party -- ^ Either the public key hash role or an error message. +readPartyPkEither :: String -- ^ The string to be read. + -> Either String (Party PubKeyHash) -- ^ Either the public key hash role or an error message. readPartyPkEither s = case s =~ "^PK=([[:xdigit:]]{56})$" of [[_, pubKeyHash]] -> PK <$> readPubKeyHashEither pubKeyHash @@ -244,8 +245,8 @@ readPartyPkEither s = -- | Reader for `Party` `Role`. -readPartyRoleEither :: String -- ^ The string to be read. - -> Either String Party -- ^ Either the party role or an error message. +readPartyRoleEither :: String -- ^ The string to be read. + -> Either String (Party PubKeyHash) -- ^ Either the party role or an error message. readPartyRoleEither s = case s =~ "^Role=(.+)$" of [[_, role]] -> Right . Role . TokenName . toBuiltin . BS8.pack $ role @@ -299,12 +300,12 @@ parseMarloweClientInput = ClientInput <$> parseInputContent -- | Parse input to a contract. -parseInput :: O.Parser Input +parseInput :: O.Parser (Input PubKeyHash Token) parseInput = NormalInput <$> parseInputContent -- | Parse input to a contract. -parseInputContent :: O.Parser InputContent +parseInputContent :: O.Parser (InputContent PubKeyHash Token) parseInputContent = parseDeposit <|> parseChoice <|> parseNotify where diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Command/Run.hs b/marlowe-cli/src/Language/Marlowe/CLI/Command/Run.hs index 3d35816ace..a8b14f5670 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Command/Run.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Command/Run.hs @@ -36,7 +36,9 @@ import Language.Marlowe.CLI.Run (initializeTransaction, prepareTransaction, runT import Language.Marlowe.CLI.Transaction (querySlotConfig) import Language.Marlowe.CLI.Types (CliError) import Language.Marlowe.Client (defaultMarloweParams, marloweParams) +import Language.Marlowe.Core.V1.Semantics.Token (Token) import Language.Marlowe.Core.V1.Semantics.Types (Input) +import Ledger.Crypto (PubKeyHash) import Plutus.V1.Ledger.Api (CurrencySymbol, POSIXTime (..), TokenName, defaultCostModelParams) import qualified Cardano.Api as Api (Value) @@ -61,12 +63,12 @@ data RunCommand = -- | Prepare a Marlowe transaction for execution. | Prepare { - marloweInFile :: FilePath -- ^ The JSON file with Marlowe initial state and initial contract. - , inputs' :: [Input] -- ^ The contract's inputs. - , minimumTime :: POSIXTime -- ^ The first valid time for the transaction. - , maximumTime :: POSIXTime -- ^ The last valid time for the transaction. - , outputFile :: Maybe FilePath -- ^ The output JSON file with the results of the computation. - , printStats :: Bool -- ^ Whether to print statistics about the redeemer. + marloweInFile :: FilePath -- ^ The JSON file with Marlowe initial state and initial contract. + , inputs' :: [Input PubKeyHash Token] -- ^ The contract's inputs. + , minimumTime :: POSIXTime -- ^ The first valid time for the transaction. + , maximumTime :: POSIXTime -- ^ The last valid time for the transaction. + , outputFile :: Maybe FilePath -- ^ The output JSON file with the results of the computation. + , printStats :: Bool -- ^ Whether to print statistics about the redeemer. } -- | Run a Marlowe transaction. | Run diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Command/Template.hs b/marlowe-cli/src/Language/Marlowe/CLI/Command/Template.hs index 3cb228640b..d4a003b85d 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Command/Template.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Command/Template.hs @@ -24,12 +24,16 @@ module Language.Marlowe.CLI.Command.Template ( import Control.Monad.Except (MonadIO) -import Language.Marlowe.CLI.Command.Parse (parseParty, parseTimeout, parseToken) +import Language.Marlowe.CLI.Command.Parse (parseTimeout, parseToken) +import qualified Language.Marlowe.CLI.Command.Parse as P import Language.Marlowe.CLI.Examples (makeExample) import Language.Marlowe.Core.V1.Semantics (MarloweData (..)) import Language.Marlowe.Core.V1.Semantics.Types as C (Contract, State (..)) -import Language.Marlowe.Extended.V1 as E (AccountId, Contract (..), Party, Timeout, Token, Value (..), toCore) +import qualified Language.Marlowe.Core.V1.Semantics.Types as C +import Language.Marlowe.Extended.V1 as E (AccountId, Contract (..), Party (..), Timeout, Token, Value (..), toCore, + toCore') import Language.Marlowe.Util (ada) +import Ledger.Crypto (PubKeyHash) import Marlowe.Contracts (coveredCall, escrow, swap, trivial, zeroCouponBond) import qualified Options.Applicative as O @@ -177,7 +181,7 @@ runTemplateCommand TemplateCoveredCall{..} = let marloweContract = makeContra -- | Conversion from Extended to Core Marlowe. -makeContract :: E.Contract -> C.Contract +makeContract :: E.Contract -> C.Contract PubKeyHash Token makeContract = errorHandling . toCore where errorHandling (Just contract) = contract @@ -185,11 +189,11 @@ makeContract = errorHandling . toCore -- | Build the initial Marlowe state. -initialMarloweState :: AccountId -> Integer -> State +initialMarloweState :: AccountId -> Integer -> State PubKeyHash Token initialMarloweState party minAda = State { - accounts = AM.singleton (party, ada) minAda + accounts = AM.singleton (toCore' party, ada) minAda , choices = AM.empty , boundValues = AM.empty , minTime = 1 @@ -327,3 +331,10 @@ templateCoveredCallOptions = <*> O.option parseTimeout (O.long "settlement-date" <> O.metavar "POSIX_TIME" <> O.help "The settlement date, in POSIX milliseconds." ) <*> O.strOption (O.long "out-contract-file" <> O.metavar "CONTRACT_FILE" <> O.help "JSON output file for the contract." ) <*> O.strOption (O.long "out-state-file" <> O.metavar "STATE_FILE" <> O.help "JSON output file for the contract's state." ) + +parseParty :: O.ReadM Party +parseParty = aux <$> P.parseParty + where + aux :: C.Party PubKeyHash -> Party + aux (C.PK pk) = PK pk + aux (C.Role name) = Role name diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Examples.hs b/marlowe-cli/src/Language/Marlowe/CLI/Examples.hs index b85de06d77..a5f3a8cbb3 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Examples.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Examples.hs @@ -23,16 +23,18 @@ module Language.Marlowe.CLI.Examples ( import Control.Monad.Except (MonadIO, liftIO) import Data.Aeson.Encode.Pretty (encodePretty) import Language.Marlowe.Core.V1.Semantics (MarloweData (..)) +import Language.Marlowe.Core.V1.Semantics.Token (Token) +import Ledger.Crypto (PubKeyHash) import qualified Data.ByteString.Lazy as LBS (writeFile) -- | Serialise an example contract to JSON. makeExample :: MonadIO m - => FilePath -- ^ The output JSON file for the Marlowe contract. - -> FilePath -- ^ The output JSON file for the Marlowe contract's state. - -> MarloweData -- ^ The contract and state data. - -> m () -- ^ Action to serialise the Marlowe data. + => FilePath -- ^ The output JSON file for the Marlowe contract. + -> FilePath -- ^ The output JSON file for the Marlowe contract's state. + -> MarloweData PubKeyHash Token -- ^ The contract and state data. + -> m () -- ^ Action to serialise the Marlowe data. makeExample contractFile stateFile MarloweData{..} = liftIO $ do diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Export.hs b/marlowe-cli/src/Language/Marlowe/CLI/Export.hs index 2199b40307..7eb10f48dd 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Export.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Export.hs @@ -60,8 +60,10 @@ import Language.Marlowe.CLI.IO (decodeFileStrict, maybeWriteJson, maybeWriteText import Language.Marlowe.CLI.Types (CliError (..), DatumInfo (..), MarloweInfo (..), RedeemerInfo (..), ValidatorInfo (..)) import Language.Marlowe.Core.V1.Semantics (MarloweData (..), MarloweParams) +import Language.Marlowe.Core.V1.Semantics.Token (Token) import Language.Marlowe.Core.V1.Semantics.Types (Contract (..), Input, State (..)) import Language.Marlowe.Scripts (marloweTxInputsFromInputs, rolePayoutScript, smallUntypedValidator) +import Ledger.Crypto (PubKeyHash) import Ledger.Scripts (datumHash, toCardanoApiScript, validatorHash) import Ledger.Typed.Scripts (validatorScript) import Plutus.V1.Ledger.Api (BuiltinData, CostModelParams, CurrencySymbol, Datum (..), Redeemer (..), TokenName, @@ -81,9 +83,9 @@ buildMarlowe :: IsShelleyBasedEra era -> CostModelParams -- ^ The cost model parameters. -> NetworkId -- ^ The network ID. -> StakeAddressReference -- ^ The stake address. - -> Contract -- ^ The contract. - -> State -- ^ The contract's state. - -> [Input] -- ^ The contract's input, + -> Contract PubKeyHash Token -- ^ The contract. + -> State PubKeyHash Token -- ^ The contract's state. + -> [Input PubKeyHash Token] -- ^ The contract's input, -> Either CliError (MarloweInfo era) -- ^ The contract and transaction information, or an error message. buildMarlowe marloweParams costModel network stake contract state inputs = do @@ -137,14 +139,14 @@ exportMarlowe marloweParams costModel network stake contractFile stateFile input -- | Print information about a Marlowe contract and transaction. printMarlowe :: MonadError CliError m => MonadIO m - => MarloweParams -- ^ The Marlowe contract parameters. - -> CostModelParams -- ^ The cost model parameters. - -> NetworkId -- ^ The network ID. - -> StakeAddressReference -- ^ The stake address. - -> Contract -- ^ The contract. - -> State -- ^ The contract's state. - -> [Input] -- ^ The contract's input, - -> m () -- ^ Action to print the contract and transaction information. + => MarloweParams -- ^ The Marlowe contract parameters. + -> CostModelParams -- ^ The cost model parameters. + -> NetworkId -- ^ The network ID. + -> StakeAddressReference -- ^ The stake address. + -> Contract PubKeyHash Token -- ^ The contract. + -> State PubKeyHash Token -- ^ The contract's state. + -> [Input PubKeyHash Token] -- ^ The contract's input, + -> m () -- ^ Action to print the contract and transaction information. printMarlowe marloweParams costModel network stake contract state inputs = do MarloweInfo{..} <- @@ -338,9 +340,9 @@ buildDatumImpl datum = -- | Build the datum information about a Marlowe transaction. -buildDatum :: Contract -- ^ The contract. - -> State -- ^ The contract's state. - -> DatumInfo -- ^ Information about the transaction datum. +buildDatum :: Contract PubKeyHash Token -- ^ The contract. + -> State PubKeyHash Token -- ^ The contract's state. + -> DatumInfo -- ^ Information about the transaction datum. buildDatum marloweContract marloweState = let marloweData = MarloweData{..} @@ -383,6 +385,7 @@ exportDatum contractFile stateFile outputFile printStats = marloweContract <- decodeFileStrict contractFile marloweState <- decodeFileStrict stateFile let + marloweData :: MarloweData PubKeyHash Token marloweData = MarloweData{..} marloweDatum = PlutusTx.toBuiltinData marloweData exportDatumImpl marloweDatum outputFile printStats @@ -405,8 +408,8 @@ buildRedeemerImpl redeemer = -- | Build the redeemer information about a Marlowe transaction. -buildRedeemer :: [Input] -- ^ The contract's input, - -> RedeemerInfo -- ^ Information about the transaction redeemer. +buildRedeemer :: [Input PubKeyHash Token] -- ^ The contract's input, + -> RedeemerInfo -- ^ Information about the transaction redeemer. buildRedeemer = buildRedeemerImpl . PlutusTx.toBuiltinData . marloweTxInputsFromInputs @@ -439,7 +442,7 @@ exportRedeemer :: MonadError CliError m exportRedeemer inputFiles outputFile printStats = do inputs <- mapM decodeFileStrict inputFiles - exportRedeemerImpl (PlutusTx.toBuiltinData (inputs :: [Input])) outputFile printStats + exportRedeemerImpl (PlutusTx.toBuiltinData (inputs :: [Input PubKeyHash Token])) outputFile printStats -- | Compute the role address of a Marlowe contract. diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Merkle.hs b/marlowe-cli/src/Language/Marlowe/CLI/Merkle.hs index 520a6bc5a8..efb344d515 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Merkle.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Merkle.hs @@ -43,10 +43,14 @@ import Language.Marlowe.CLI.Types (CliError (..), Continuations, MarloweTransact import Language.Marlowe.Core.V1.Semantics (ApplyResult (..), ReduceResult (..), TransactionInput (..), TransactionOutput (..), applyInput, computeTransaction, fixInterval, reduceContractUntilQuiescent) -import Language.Marlowe.Core.V1.Semantics.Types (Case (..), Contract (..), Input (..), IntervalResult (..), State, +import Language.Marlowe.Core.V1.Semantics.Token (Token) +import Language.Marlowe.Core.V1.Semantics.Types (Case_ (..), Contract (..), Input (..), IntervalResult (..), State, TimeInterval) +import Ledger.Crypto (PubKeyHash) import Ledger.Scripts (dataHash) import Plutus.V1.Ledger.Api (DatumHash (..), toBuiltinData) +import PlutusTx (ToData) +import qualified PlutusTx.Prelude as P import qualified Data.Map.Strict as M (lookup, singleton) @@ -82,21 +86,24 @@ merkleizeMarlowe marlowe = -- | Merkleize any top-level case statements in a contract. -shallowMerkleize :: Contract -- ^ The contract. - -> Writer Continuations Contract -- ^ Action for the merkleized contract. +shallowMerkleize :: (ToData i, ToData t) + => Contract i t -- ^ The contract. + -> Writer (Continuations i t) (Contract i t) -- ^ Action for the merkleized contract. shallowMerkleize = merkleize' pure -- | Merkleize all case statements in a contract. -deepMerkleize :: Contract -- ^ The contract. - -> Writer Continuations Contract -- ^ Action for the merkleized contract. +deepMerkleize :: (ToData i, ToData t) + => Contract i t -- ^ The contract. + -> Writer (Continuations i t) (Contract i t) -- ^ Action for the merkleized contract. deepMerkleize = fix merkleize' -- | Merkleize selected case statements in a contract. -merkleize' :: (Contract -> Writer Continuations Contract) -- ^ Action to continue merkleization. - -> Contract -- ^ The contract. - -> Writer Continuations Contract -- ^ Action for merkleizing the selected case statements. +merkleize' :: (ToData i, ToData t) + => (Contract i t -> Writer (Continuations i t) (Contract i t)) -- ^ Action to continue merkleization. + -> Contract i t -- ^ The contract. + -> Writer (Continuations i t) (Contract i t) -- ^ Action for merkleizing the selected case statements. merkleize' _ Close = pure Close merkleize' f (Pay accountId payee token value contract) = Pay accountId payee token value <$> merkleize' f contract merkleize' f (If observation thenContract elseContract) = If observation <$> merkleize' f thenContract <*> merkleize' f elseContract @@ -141,23 +148,23 @@ demerkleize contractFile outputFile = -- | Demerkleize any top-level case statements in a contract. shallowDemerkleize :: MonadError CliError m - => Contract -- ^ The contract. - -> ReaderT Continuations m Contract -- ^ Action for the demerkleized contract. + => Contract i t -- ^ The contract. + -> ReaderT (Continuations i t) m (Contract i t) -- ^ Action for the demerkleized contract. shallowDemerkleize = demerkleize' pure -- | Demerkleize all case statements in a contract. deepDemerkleize :: MonadError CliError m - => Contract -- ^ The contract. - -> ReaderT Continuations m Contract -- ^ Action for the demerkleized contract. + => Contract i t -- ^ The contract. + -> ReaderT (Continuations i t) m (Contract i t) -- ^ Action for the demerkleized contract. deepDemerkleize = fix demerkleize' -- | Demerkleize selected case statements in a contract. demerkleize' :: MonadError CliError m - => (Contract -> ReaderT Continuations m Contract) -- ^ Action to continue demerkleization. - -> Contract -- ^ The contract. - -> ReaderT Continuations m Contract -- ^ Action for demerkleized the selected case statements. + => (Contract i t -> ReaderT (Continuations i t) m (Contract i t)) -- ^ Action to continue demerkleization. + -> Contract i t -- ^ The contract. + -> ReaderT (Continuations i t) m (Contract i t) -- ^ Action for demerkleized the selected case statements. demerkleize' _ Close = pure Close demerkleize' f (Pay accountId payee token value contract) = Pay accountId payee token value <$> demerkleize' f contract demerkleize' f (If observation thenContract elseContract) = If observation <$> demerkleize' f thenContract <*> demerkleize' f elseContract @@ -175,9 +182,9 @@ demerkleize' f (When cases timeout contract) = When <$> mapM demerkleizeCase cas -- | Merkleize whatever inputs need merkleization before application to a contract. merkleizeInputs :: MonadError CliError m - => MarloweTransaction era -- ^ The transaction information. - -> TransactionInput -- ^ The input to the contract. - -> m TransactionInput -- ^ Action for the merkleized input to the contract. + => MarloweTransaction era -- ^ The transaction information. + -> TransactionInput PubKeyHash Token -- ^ The input to the contract. + -> m (TransactionInput PubKeyHash Token) -- ^ Action for the merkleized input to the contract. merkleizeInputs MarloweTransaction{..} TransactionInput{..} = TransactionInput txInterval . snd @@ -185,12 +192,12 @@ merkleizeInputs MarloweTransaction{..} TransactionInput{..} = -- | Merkleize an input if needed before application to a contract. -merkleizeInput :: MonadError CliError m - => TimeInterval -- ^ The validity interval. - -> Continuations -- ^ The available continuations. - -> ((State, Contract), [Input]) -- ^ The current state and contract, along with the prior inputs. - -> Input -- ^ The input. - -> m ((State, Contract), [Input]) -- ^ The new state and contract, along with the prior inputs. +merkleizeInput :: (MonadError CliError m, P.Eq i, P.Eq t, ToData i, ToData t) + => TimeInterval -- ^ The validity interval. + -> Continuations i t -- ^ The available continuations. + -> ((State i t, Contract i t), [Input i t]) -- ^ The current state and contract, along with the prior inputs. + -> Input i t -- ^ The input. + -> m ((State i t, Contract i t), [Input i t]) -- ^ The new state and contract, along with the prior inputs. merkleizeInput txInterval continuations ((state, contract), inputs) input = do -- Apply input as it is. @@ -223,11 +230,12 @@ merkleizeInput txInterval continuations ((state, contract), inputs) input = -- | Compute one step in a transaction without reducing the quiescent state after the input is applied. -computeTransaction' :: TimeInterval -- ^ The validity interval. - -> Input -- ^ The input to the contract. - -> State -- ^ The current state of the contract. - -> Contract -- ^ The current contract. - -> Maybe (State, Contract) -- ^ The new state and contract, if the input could be applied. +computeTransaction' :: (P.Eq i, P.Eq t) + => TimeInterval -- ^ The validity interval. + -> Input i t -- ^ The input to the contract. + -> State i t -- ^ The current state of the contract. + -> Contract i t -- ^ The current contract. + -> Maybe (State i t, Contract i t) -- ^ The new state and contract, if the input could be applied. computeTransaction' txInterval input state contract = case fixInterval txInterval state of IntervalTrimmed env fixState -> diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Orphans.hs b/marlowe-cli/src/Language/Marlowe/CLI/Orphans.hs index 5ab669f4c7..819205e449 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Orphans.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Orphans.hs @@ -27,6 +27,9 @@ import Cardano.Api (AddressAny (..), AsType (AsAddressAny), BlockHeader (..), Bl import Data.Aeson (FromJSON (..), ToJSON (..), Value (Null, String), object, withObject, withText, (.:), (.=)) import Data.ByteString.Short (ShortByteString, fromShort, toShort) import Language.Marlowe.Core.V1.Semantics (Payment (..), TransactionOutput (..)) +import Language.Marlowe.Core.V1.Semantics.Money (Money) +import Language.Marlowe.Core.V1.Semantics.Token (Token, moneyFromValue, moneyToValue) +import Ledger.Crypto (PubKeyHash) import qualified Data.ByteString.Base16 as Base16 (decode, encode) import qualified Data.ByteString.Char8 as BS8 (pack, unpack) @@ -45,7 +48,7 @@ instance FromJSON ShortByteString where Left message -> fail message -instance ToJSON TransactionOutput where +instance ToJSON (TransactionOutput PubKeyHash Token) where toJSON TransactionOutput{..} = object [ @@ -61,7 +64,7 @@ instance ToJSON TransactionOutput where ] -instance ToJSON Payment where +instance ToJSON (Payment PubKeyHash Token) where toJSON (Payment accountId payee money) = object [ @@ -71,7 +74,7 @@ instance ToJSON Payment where ] -instance FromJSON Payment where +instance FromJSON (Payment PubKeyHash Token) where parseJSON = withObject "Payment" $ \o -> @@ -80,6 +83,11 @@ instance FromJSON Payment where <*> (o .: "payee" ) <*> (o .: "money" ) +instance ToJSON (Money Token) where + toJSON = toJSON . moneyToValue + +instance FromJSON (Money Token) where + parseJSON = fmap moneyFromValue . parseJSON instance ToJSON AddressAny where toJSON = String . serialiseAddress diff --git a/marlowe-cli/src/Language/Marlowe/CLI/PAB.hs b/marlowe-cli/src/Language/Marlowe/CLI/PAB.hs index 1b2b3c16c9..1dec27f906 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/PAB.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/PAB.hs @@ -55,7 +55,9 @@ import Language.Marlowe.Client (ApplyInputsEndpointSchema, CompanionState, Creat MarloweEndpointResult (CreateResponse), MarloweError, RedeemEndpointSchema) import Language.Marlowe.Contract (MarloweContract (..)) import Language.Marlowe.Core.V1.Semantics (MarloweParams) +import Language.Marlowe.Core.V1.Semantics.Token (Token) import Language.Marlowe.Core.V1.Semantics.Types (Contract) +import Ledger.Crypto (PubKeyHash) import Network.WebSockets (Connection, receiveData) import Plutus.PAB.Events.Contract (ContractInstanceId (..)) import Plutus.PAB.Webserver.Client (InstanceClient (..), PabClient (..)) @@ -256,7 +258,7 @@ callCreate pabClient runApi instanceFile contractFile owners = call pabClient runApi instanceFile "create" (( , AM.fromList $ second anyAddressInShelleyBasedEra <$> owners :: AM.Map TokenName (AddressInEra ShelleyEra) - , contract :: Contract + , contract :: Contract PubKeyHash Token ) :: UUID -> CreateEndpointSchema) diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Run.hs b/marlowe-cli/src/Language/Marlowe/CLI/Run.hs index 823bfa25f6..53789bada8 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Run.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Run.hs @@ -62,9 +62,10 @@ import Language.Marlowe.CLI.Types (CliError (..), DatumInfo (..), MarloweTransac ValidatorInfo (..)) import Language.Marlowe.Core.V1.Semantics (MarloweParams (rolesCurrency), Payment (..), TransactionInput (..), TransactionOutput (..), TransactionWarning, computeTransaction) +import Language.Marlowe.Core.V1.Semantics.Token (Token (..), moneyToValue) import Language.Marlowe.Core.V1.Semantics.Types (AccountId, ChoiceId (..), ChoiceName, ChosenNum, Contract, Input (..), - InputContent (..), Party (..), Payee (..), State (accounts), - Token (..)) + InputContent (..), Party (..), Payee (..), State (accounts)) +import Ledger.Crypto (PubKeyHash) import Ledger.TimeSlot (SlotConfig, posixTimeToEnclosingSlot) import Ledger.Tx.CardanoAPI (toCardanoAddress, toCardanoScriptDataHash, toCardanoValue) import Plutus.V1.Ledger.Ada (adaSymbol, adaToken, fromValue, getAda) @@ -78,12 +79,12 @@ import System.IO (hPutStrLn, stderr) -- | Serialise a deposit input to a file. makeDeposit :: MonadIO m - => AccountId -- ^ The account for the deposit. - -> Party -- ^ The party making the deposit. - -> Maybe Token -- ^ The token being deposited. - -> Integer -- ^ The amount of the token deposited. - -> Maybe FilePath -- ^ The output JSON file representing the input. - -> m () -- ^ Action to write the input to the file. + => AccountId PubKeyHash -- ^ The account for the deposit. + -> Party PubKeyHash -- ^ The party making the deposit. + -> Maybe Token -- ^ The token being deposited. + -> Integer -- ^ The amount of the token deposited. + -> Maybe FilePath -- ^ The output JSON file representing the input. + -> m () -- ^ Action to write the input to the file. makeDeposit accountId party token amount outputFile = maybeWriteJson outputFile . NormalInput @@ -92,15 +93,18 @@ makeDeposit accountId party token amount outputFile = -- | Serialise a choice input to a file. makeChoice :: MonadIO m - => ChoiceName -- ^ The name of the choice made. - -> Party -- ^ The party making the choice. - -> ChosenNum -- ^ The number chosen. - -> Maybe FilePath -- ^ The output JSON file representing the input. - -> m () -- ^ Action to write the input to the file. + => ChoiceName -- ^ The name of the choice made. + -> Party PubKeyHash -- ^ The party making the choice. + -> ChosenNum -- ^ The number chosen. + -> Maybe FilePath -- ^ The output JSON file representing the input. + -> m () -- ^ Action to write the input to the file. makeChoice name party chosen outputFile = - maybeWriteJson outputFile - . NormalInput - $ IChoice (ChoiceId name party) chosen + maybeWriteJson outputFile input + where + input :: Input PubKeyHash Token + input = + NormalInput + $ IChoice (ChoiceId name party) chosen -- | Serialise a notification input to a file. @@ -108,8 +112,10 @@ makeNotification :: MonadIO m => Maybe FilePath -- ^ The output JSON file representing the input. -> m () -- ^ Action to write the input to the file. makeNotification outputFile = - maybeWriteJson outputFile - $ NormalInput INotify + maybeWriteJson outputFile input + where + input :: Input PubKeyHash Token + input = NormalInput INotify -- | Create an initial Marlowe transaction. @@ -141,17 +147,17 @@ initializeTransaction marloweParams slotConfig costModelParams network stake con -- | Create an initial Marlowe transaction. initializeTransactionImpl :: MonadError CliError m => MonadIO m - => MarloweParams -- ^ The Marlowe contract parameters. - -> SlotConfig -- ^ The POSIXTime-to-slot configuration. - -> CostModelParams -- ^ The cost model parameters. - -> NetworkId -- ^ The network ID. - -> StakeAddressReference -- ^ The stake address. - -> Contract -- ^ The initial Marlowe contract. - -> State -- ^ The initial Marlowe state. - -> Maybe FilePath -- ^ The output JSON file for the validator information. - -> Bool -- ^ Whether to deeply merkleize the contract. - -> Bool -- ^ Whether to print statistics about the validator. - -> m () -- ^ Action to export the validator information to a file. + => MarloweParams -- ^ The Marlowe contract parameters. + -> SlotConfig -- ^ The POSIXTime-to-slot configuration. + -> CostModelParams -- ^ The cost model parameters. + -> NetworkId -- ^ The network ID. + -> StakeAddressReference -- ^ The stake address. + -> Contract PubKeyHash Token -- ^ The initial Marlowe contract. + -> State PubKeyHash Token -- ^ The initial Marlowe state. + -> Maybe FilePath -- ^ The output JSON file for the validator information. + -> Bool -- ^ Whether to deeply merkleize the contract. + -> Bool -- ^ Whether to print statistics about the validator. + -> m () -- ^ Action to export the validator information to a file. initializeTransactionImpl marloweParams mtSlotConfig costModelParams network stake mtContract mtState outputFile merkleize printStats = do let @@ -178,13 +184,13 @@ initializeTransactionImpl marloweParams mtSlotConfig costModelParams network sta -- | Prepare the next step in a Marlowe contract. prepareTransaction :: MonadError CliError m => MonadIO m - => FilePath -- ^ The JSON file with the Marlowe initial state and initial contract. - -> [Input] -- ^ The contract's inputs. - -> POSIXTime -- ^ The first valid time for the transaction. - -> POSIXTime -- ^ The last valid time for the transaction. - -> Maybe FilePath -- ^ The output JSON file with the results of the computation. - -> Bool -- ^ Whether to print statistics about the result. - -> m () -- ^ Action to compute the next step in the contract. + => FilePath -- ^ The JSON file with the Marlowe initial state and initial contract. + -> [Input PubKeyHash Token] -- ^ The contract's inputs. + -> POSIXTime -- ^ The first valid time for the transaction. + -> POSIXTime -- ^ The last valid time for the transaction. + -> Maybe FilePath -- ^ The output JSON file with the results of the computation. + -> Bool -- ^ Whether to print statistics about the result. + -> m () -- ^ Action to compute the next step in the contract. prepareTransaction marloweFile txInputs minimumTime maximumTime outputFile printStats = do marloweIn <- decodeFileStrict marloweFile @@ -222,15 +228,16 @@ prepareTransaction marloweFile txInputs minimumTime maximumTime outputFile print , (token, amount) <- AM.toList tokenAmounts ] | - (i, Payment accountId payee money) <- zip [1..] mtPayments + (i, Payment accountId payee money_) <- zip [1..] mtPayments + , let money = moneyToValue money_ ] -- | Prepare the next step in a Marlowe contract. makeMarlowe :: MonadError CliError m - => MarloweTransaction era -- ^ The Marlowe initial state and initial contract. - -> TransactionInput -- ^ The transaction input. - -> m ([TransactionWarning], MarloweTransaction era) -- ^ Action to compute the next step in the contract. + => MarloweTransaction era -- ^ The Marlowe initial state and initial contract. + -> TransactionInput PubKeyHash Token -- ^ The transaction input. + -> m ([TransactionWarning PubKeyHash Token], MarloweTransaction era) -- ^ Action to compute the next step in the contract. makeMarlowe marloweIn@MarloweTransaction{..} transactionInput = do transactionInput'@TransactionInput{..} <- @@ -355,7 +362,7 @@ runTransaction connection marloweInBundle marloweOutFile inputs outputs changeAd (payee, money) <- bimap head mconcat . unzip <$> (groupBy ((==) `on` fst) . sortBy (compare `on` fst)) [ - (payee, money) + (payee, moneyToValue money) | Payment _ payee money <- mtPayments marloweOut ] ] diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Sync.hs b/marlowe-cli/src/Language/Marlowe/CLI/Sync.hs index e2385ebf0c..63c29fd12f 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Sync.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Sync.hs @@ -462,17 +462,17 @@ classifyInputs txBody@(TxBody TxBodyContent{..}) = -- | Classify a transaction input's Marlowe content. -classifyInput :: [(BuiltinByteString, Contract)] -- ^ Contract continuations and their hashes. - -> MarloweInput -- ^ The transaction input. - -> Maybe [Input] -- ^ The the Marlowe input, if any. +classifyInput :: [(BuiltinByteString, Contract i t)] -- ^ Contract continuations and their hashes. + -> MarloweInput i t -- ^ The transaction input. + -> Maybe [Input i t] -- ^ The the Marlowe input, if any. classifyInput continuations = mapM $ unmerkleize continuations -- | Restore a contract from its merkleization. -unmerkleize :: [(BuiltinByteString, Contract)] -- ^ Contract continuations and their hashes. - -> MarloweTxInput -- ^ The Marlowe transaction input. - -> Maybe Input -- ^ Marlowe input, if any. +unmerkleize :: [(BuiltinByteString, Contract i t)] -- ^ Contract continuations and their hashes. + -> MarloweTxInput i t -- ^ The Marlowe transaction input. + -> Maybe (Input i t) -- ^ Marlowe input, if any. unmerkleize _ (Input content) = pure $ NormalInput content unmerkleize continuations (MerkleizedTxInput content continuationHash) = diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Sync/Types.hs b/marlowe-cli/src/Language/Marlowe/CLI/Sync/Types.hs index 847da182ba..3c1efd4e1c 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Sync/Types.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Sync/Types.hs @@ -35,8 +35,10 @@ import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generic) import Language.Marlowe.CLI.Orphans () import Language.Marlowe.Core.V1.Semantics (MarloweData (..), MarloweParams (..)) +import Language.Marlowe.Core.V1.Semantics.Token (Token) import Language.Marlowe.Core.V1.Semantics.Types (Input, TimeInterval) import Ledger.Address (Address) +import Ledger.Crypto (PubKeyHash) import Plutus.V1.Ledger.Api (TokenName) import qualified Data.Aeson as A (Value) @@ -75,8 +77,8 @@ data MarloweIn = -- | Input to the Marlowe application script. | ApplicationIn { - miTxIn :: TxIn -- ^ The transaction input. - , miInputs :: [Input] -- ^ The Marlowe inputs. + miTxIn :: TxIn -- ^ The transaction input. + , miInputs :: [Input PubKeyHash Token] -- ^ The Marlowe inputs. } | PayoutIn { @@ -98,10 +100,10 @@ data MarloweOut = -- | Output to the Marlowe application script. | ApplicationOut { - moTxIn :: TxIn -- ^ The transaction input being produced. - , moAddress :: Address -- ^ The address receiving the output. - , moValue :: Value -- ^ The value output. - , moOutput :: MarloweData -- ^ The Marlowe data in the output. + moTxIn :: TxIn -- ^ The transaction input being produced. + , moAddress :: Address -- ^ The address receiving the output. + , moValue :: Value -- ^ The value output. + , moOutput :: MarloweData PubKeyHash Token -- ^ The Marlowe data in the output. } -- | Output to the Marlowe payout script. | PayoutOut diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Test/Types.hs b/marlowe-cli/src/Language/Marlowe/CLI/Test/Types.hs index 633ce1031c..be01814f24 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Test/Types.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Test/Types.hs @@ -67,6 +67,7 @@ import Language.Marlowe.CLI.Types (CliError, SomePaymentSigningKey) import Language.Marlowe.Client (MarloweClientInput, MarloweContractState) import Language.Marlowe.Contract (MarloweContract) import Language.Marlowe.Core.V1.Semantics (MarloweParams) +import Language.Marlowe.Core.V1.Semantics.Token (Token) import Language.Marlowe.Core.V1.Semantics.Types (Contract, State, TimeInterval) import Plutus.Contract (ContractInstanceId) import Plutus.PAB.Webserver.Client (PabClient) @@ -124,12 +125,12 @@ type InstanceNickname = String data ScriptTest = ScriptTest { - stTestName :: String -- ^ The name of the test. - , stSlotLength :: Integer -- ^ The slot length, in milliseconds. - , stSlotZeroOffset :: Integer -- ^ The effective POSIX time of slot zero, in milliseconds. - , stInitialContract :: Contract -- ^ The contract. - , stInitialState :: State -- ^ The the contract's initial state. - , stScriptOperations :: [ScriptOperation] -- ^ The sequence of test operations. + stTestName :: String -- ^ The name of the test. + , stSlotLength :: Integer -- ^ The slot length, in milliseconds. + , stSlotZeroOffset :: Integer -- ^ The effective POSIX time of slot zero, in milliseconds. + , stInitialContract :: Contract PubKeyHash Token -- ^ The contract. + , stInitialState :: State PubKeyHash Token -- ^ The the contract's initial state. + , stScriptOperations :: [ScriptOperation] -- ^ The sequence of test operations. } deriving stock (Eq, Generic, Show) deriving anyclass (FromJSON, ToJSON) @@ -238,9 +239,9 @@ data PabOperation = -- | Call the "create" endpoint of `WalletApp`. | CallCreate { - poInstance :: InstanceNickname -- ^ The nickname of the PAB contract instance. - , poOwners :: [RoleName] -- ^ The names of roles in the contract. - , poContract :: Contract -- ^ The Marlowe contract to be created. + poInstance :: InstanceNickname -- ^ The nickname of the PAB contract instance. + , poOwners :: [RoleName] -- ^ The names of roles in the contract. + , poContract :: Contract PubKeyHash Token -- ^ The Marlowe contract to be created. } -- | Wait for confirmation of a call to the "create" endpoint. | AwaitCreate diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Types.hs b/marlowe-cli/src/Language/Marlowe/CLI/Types.hs index 41ecc5a4d4..c5195d9c46 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Types.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Types.hs @@ -53,7 +53,9 @@ import Data.String (IsString) import GHC.Generics (Generic) import Language.Marlowe.CLI.Orphans () import Language.Marlowe.Core.V1.Semantics (Payment) +import Language.Marlowe.Core.V1.Semantics.Token (Token) import Language.Marlowe.Core.V1.Semantics.Types (Contract, Input, State) +import Ledger.Crypto (PubKeyHash) import Ledger.TimeSlot (SlotConfig) import Plutus.V1.Ledger.Api (CurrencySymbol, Datum, DatumHash, ExBudget, Redeemer, ValidatorHash) @@ -77,23 +79,23 @@ type SomePaymentSigningKey = Either (SigningKey PaymentKey) (SigningKey PaymentE -- | Continuations for contracts. -type Continuations = M.Map DatumHash Contract +type Continuations i t = M.Map DatumHash (Contract i t) -- | Complete description of a Marlowe transaction. data MarloweTransaction era = MarloweTransaction { - mtValidator :: ValidatorInfo era -- ^ The Marlowe validator. - , mtRoleValidator :: ValidatorInfo era -- ^ The roles validator. - , mtRoles :: CurrencySymbol -- ^ The roles currency. - , mtState :: State -- ^ The Marlowe state after the transaction. - , mtContract :: Contract -- ^ The Marlowe contract after the transaction. - , mtContinuations :: Continuations -- ^ The merkleized continuations for the contract. - , mtRange :: Maybe (SlotNo, SlotNo) -- ^ The slot range for the transaction, if any. - , mtInputs :: [Input] -- ^ The inputs to the transaction. - , mtPayments :: [Payment] -- ^ The payments from the transaction. - , mtSlotConfig :: SlotConfig -- ^ The POSIXTime-to-Slot configuration. + mtValidator :: ValidatorInfo era -- ^ The Marlowe validator. + , mtRoleValidator :: ValidatorInfo era -- ^ The roles validator. + , mtRoles :: CurrencySymbol -- ^ The roles currency. + , mtState :: State PubKeyHash Token -- ^ The Marlowe state after the transaction. + , mtContract :: Contract PubKeyHash Token -- ^ The Marlowe contract after the transaction. + , mtContinuations :: Continuations PubKeyHash Token -- ^ The merkleized continuations for the contract. + , mtRange :: Maybe (SlotNo, SlotNo) -- ^ The slot range for the transaction, if any. + , mtInputs :: [Input PubKeyHash Token] -- ^ The inputs to the transaction. + , mtPayments :: [Payment PubKeyHash Token] -- ^ The payments from the transaction. + , mtSlotConfig :: SlotConfig -- ^ The POSIXTime-to-Slot configuration. } deriving (Generic, Show) diff --git a/marlowe-contracts/test/Spec/Marlowe/Analysis.hs b/marlowe-contracts/test/Spec/Marlowe/Analysis.hs index 50a2958f5e..e0ae59ad14 100644 --- a/marlowe-contracts/test/Spec/Marlowe/Analysis.hs +++ b/marlowe-contracts/test/Spec/Marlowe/Analysis.hs @@ -29,7 +29,7 @@ tests = testGroup "Marlowe Contract" , testCase "Option test" optionTest ] -hasWarnings :: Maybe C.Contract -> IO Bool +hasWarnings :: Maybe (C.Contract C.PubKeyHash Token) -> IO Bool hasWarnings (Just contract) = do result <- warningsTrace contract case result of diff --git a/marlowe-contracts/test/Spec/Marlowe/Contracts.hs b/marlowe-contracts/test/Spec/Marlowe/Contracts.hs index e4f160b8c4..14b4831cb5 100644 --- a/marlowe-contracts/test/Spec/Marlowe/Contracts.hs +++ b/marlowe-contracts/test/Spec/Marlowe/Contracts.hs @@ -53,10 +53,10 @@ tokSymbol = "" tok :: Token tok = Token tokSymbol tokName -tokValueOf :: Integer -> C.Money -tokValueOf = singleton tokSymbol tokName +tokValueOf :: Integer -> C.Money Token +tokValueOf = C.moneyFromValue . singleton tokSymbol tokName -assertTotalPayments :: Party -> [C.Payment] -> C.Money -> Assertion +assertTotalPayments :: C.Party C.PubKeyHash -> [C.Payment C.PubKeyHash Token] -> C.Money Token -> Assertion assertTotalPayments p t x = assertBool "total payments to party" (totalPayments t == x) where totalPayments = mconcat . map (\(C.Payment _ _ a) -> a) . filter (\(C.Payment _ a _) -> a == C.Party p) @@ -65,7 +65,7 @@ assertNoWarnings :: [a] -> Assertion assertNoWarnings [] = pure () assertNoWarnings t = assertBool "Assert no warnings" $ null t -assertClose :: C.Contract -> Assertion +assertClose :: C.Contract C.PubKeyHash Token -> Assertion assertClose = assertBool "Contract is in Close" . (C.Close==) assertNoFailedTransactions :: C.TransactionError -> Assertion @@ -88,14 +88,14 @@ zeroCouponBondTest = ada Close txIn = - [ C.TransactionInput (toPOSIX "2021-12-31 00:00:00.000000 UTC", toPOSIX "2021-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit w1Pk w1Pk ada 75_000_000] - , C.TransactionInput (toPOSIX "2022-12-31 00:00:00.000000 UTC", toPOSIX "2022-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit w2Pk w2Pk ada 90_000_000] + [ C.TransactionInput (toPOSIX "2021-12-31 00:00:00.000000 UTC", toPOSIX "2021-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 75_000_000] + , C.TransactionInput (toPOSIX "2022-12-31 00:00:00.000000 UTC", toPOSIX "2022-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) ada 90_000_000] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (lovelaceValueOf 90_000_000) + assertTotalPayments (toCore' w1Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 90_000_000) C.Error err -> assertNoFailedTransactions err @@ -115,16 +115,16 @@ couponBondTest = ada Close txIn = - [ C.TransactionInput (toPOSIX "2021-12-31 00:00:00.000000 UTC", toPOSIX "2021-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit w1Pk w1Pk ada 75_000_000] - , C.TransactionInput (toPOSIX "2022-06-30 00:00:00.000000 UTC", toPOSIX "2022-06-30 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit w2Pk w2Pk ada 1_000_000] - , C.TransactionInput (toPOSIX "2022-12-31 00:00:00.000000 UTC", toPOSIX "2022-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit w2Pk w2Pk ada 1_000_000] - , C.TransactionInput (toPOSIX "2022-12-31 00:00:00.000000 UTC", toPOSIX "2022-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit w2Pk w2Pk ada 90_000_000] + [ C.TransactionInput (toPOSIX "2021-12-31 00:00:00.000000 UTC", toPOSIX "2021-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 75_000_000] + , C.TransactionInput (toPOSIX "2022-06-30 00:00:00.000000 UTC", toPOSIX "2022-06-30 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) ada 1_000_000] + , C.TransactionInput (toPOSIX "2022-12-31 00:00:00.000000 UTC", toPOSIX "2022-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) ada 1_000_000] + , C.TransactionInput (toPOSIX "2022-12-31 00:00:00.000000 UTC", toPOSIX "2022-12-31 23:59:59.999999 UTC") [C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) ada 90_000_000] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (lovelaceValueOf 92_000_000) + assertTotalPayments (toCore' w1Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 92_000_000) C.Error err -> assertNoFailedTransactions err @@ -138,18 +138,18 @@ swapContractTest = timestamp = read "2022-01-01 00:00:00.000000 UTC" txIn = [ C.TransactionInput (0, 0) - [ C.NormalInput $ C.IDeposit w1Pk w1Pk ada 10_000_000 - , C.NormalInput $ C.IDeposit w2Pk w2Pk tok 30 - , C.NormalInput $ C.IDeposit w2Pk w2Pk ada 10_000_000 - , C.NormalInput $ C.IDeposit w1Pk w1Pk tok 30 + [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 10_000_000 + , C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) tok 30 + , C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) ada 10_000_000 + , C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) tok 30 ] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (lovelaceValueOf 10_000_000 <> tokValueOf 30) - assertTotalPayments w2Pk txOutPayments (lovelaceValueOf 10_000_000 <> tokValueOf 30) + assertTotalPayments (toCore' w1Pk) txOutPayments (C.moneyFromValue (lovelaceValueOf 10_000_000) <> tokValueOf 30) + assertTotalPayments (toCore' w2Pk) txOutPayments (C.moneyFromValue (lovelaceValueOf 10_000_000) <> tokValueOf 30) C.Error err -> assertNoFailedTransactions err @@ -168,13 +168,13 @@ americanCallOptionTest = (read "2022-03-01 09:00:00.000000 UTC") (read "2022-03-31 17:30:00.000000 UTC") txIn = - [ C.TransactionInput (0, 0) [C.NormalInput $ C.IChoice (ChoiceId "Exercise Call" w1Pk) 0] ] + [ C.TransactionInput (0, 0) [C.NormalInput $ C.IChoice (C.ChoiceId "Exercise Call" (toCore' w1Pk)) 0] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments mempty - assertTotalPayments w2Pk txOutPayments mempty + assertTotalPayments (toCore' w1Pk) txOutPayments mempty + assertTotalPayments (toCore' w2Pk) txOutPayments mempty C.Error err -> assertNoFailedTransactions err @@ -206,16 +206,16 @@ americanCallOptionExercisedTest = t2 = toPOSIX "2022-03-15 08:00:00.000000 UTC" txIn = - [ C.TransactionInput (t0, t0) [C.NormalInput $ C.IDeposit w2Pk w2Pk tok 30] - , C.TransactionInput (t1, t1) [C.NormalInput $ C.IChoice (ChoiceId "Exercise Call" w1Pk) 1] - , C.TransactionInput (t2, t2) [C.NormalInput $ C.IDeposit w1Pk w1Pk ada 10_000_000] + [ C.TransactionInput (t0, t0) [C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) tok 30] + , C.TransactionInput (t1, t1) [C.NormalInput $ C.IChoice (C.ChoiceId "Exercise Call" (toCore' w1Pk)) 1] + , C.TransactionInput (t2, t2) [C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 10_000_000] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (tokValueOf 30) - assertTotalPayments w2Pk txOutPayments (lovelaceValueOf 10_000_000) + assertTotalPayments (toCore' w1Pk) txOutPayments (tokValueOf 30) + assertTotalPayments (toCore' w2Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 10_000_000) C.Error err -> assertNoFailedTransactions err @@ -235,13 +235,13 @@ europeanCallOptionTest = (read "2022-03-20 17:30:00.000000 UTC") exerciseTime = toPOSIX "2022-03-19 17:31:00.000000 UTC" txIn = - [ C.TransactionInput (exerciseTime, exerciseTime) [C.NormalInput $ C.IChoice (ChoiceId "Exercise Call" w1Pk) 0] ] + [ C.TransactionInput (exerciseTime, exerciseTime) [C.NormalInput $ C.IChoice (C.ChoiceId "Exercise Call" (toCore' w1Pk)) 0] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments mempty - assertTotalPayments w2Pk txOutPayments mempty + assertTotalPayments (toCore' w1Pk) txOutPayments mempty + assertTotalPayments (toCore' w2Pk) txOutPayments mempty C.Error err -> assertNoFailedTransactions err @@ -272,16 +272,16 @@ europeanCallOptionExercisedTest = exerciseTime = toPOSIX "2022-03-19 17:31:00.000000 UTC" depositTime = toPOSIX "2022-03-19 17:32:00.000000 UTC" txIn = - [ C.TransactionInput (0, 0) [C.NormalInput $ C.IDeposit w2Pk w2Pk tok 30] - , C.TransactionInput (exerciseTime, exerciseTime) [C.NormalInput $ C.IChoice (ChoiceId "Exercise Call" w1Pk) 1] - , C.TransactionInput (depositTime, depositTime) [C.NormalInput $ C.IDeposit w1Pk w1Pk ada 10_000_000] + [ C.TransactionInput (0, 0) [C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) tok 30] + , C.TransactionInput (exerciseTime, exerciseTime) [C.NormalInput $ C.IChoice (C.ChoiceId "Exercise Call" (toCore' w1Pk)) 1] + , C.TransactionInput (depositTime, depositTime) [C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 10_000_000] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (tokValueOf 30) - assertTotalPayments w2Pk txOutPayments (lovelaceValueOf 10_000_000) + assertTotalPayments (toCore' w1Pk) txOutPayments (tokValueOf 30) + assertTotalPayments (toCore' w2Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 10_000_000) C.Error err -> assertNoFailedTransactions err @@ -309,18 +309,18 @@ futureNoChange = txIn = [ C.TransactionInput (t0, t0) - [ C.NormalInput $ C.IDeposit w1Pk w1Pk ada 8_000_000 - , C.NormalInput $ C.IDeposit w2Pk w2Pk ada 8_000_000 ] + [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 8_000_000 + , C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) ada 8_000_000 ] , C.TransactionInput (t1, t1) - [ C.NormalInput $ C.IChoice dirRate 125_000_000 - , C.NormalInput $ C.IChoice invRate 80_000_000 ] + [ C.NormalInput $ C.IChoice (toCore' dirRate) 125_000_000 + , C.NormalInput $ C.IChoice (toCore' invRate) 80_000_000 ] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings $ filter nonZeroPay txOutWarnings - assertTotalPayments w1Pk txOutPayments (lovelaceValueOf 8_000_000) - assertTotalPayments w2Pk txOutPayments (lovelaceValueOf 8_000_000) + assertTotalPayments (toCore' w1Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 8_000_000) + assertTotalPayments (toCore' w2Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 8_000_000) C.Error err -> assertNoFailedTransactions err where @@ -345,18 +345,18 @@ futureNoMarginCall = txIn = [ C.TransactionInput (t0, t0) - [ C.NormalInput $ C.IDeposit w1Pk w1Pk ada 8_000_000 - , C.NormalInput $ C.IDeposit w2Pk w2Pk ada 8_000_000 ] + [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 8_000_000 + , C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) ada 8_000_000 ] , C.TransactionInput (t1, t1) - [ C.NormalInput $ C.IChoice dirRate 133_333_333 - , C.NormalInput $ C.IChoice invRate 75_000_000 ] + [ C.NormalInput $ C.IChoice (toCore' dirRate) 133_333_333 + , C.NormalInput $ C.IChoice (toCore' invRate) 75_000_000 ] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (lovelaceValueOf 1_333_333) - assertTotalPayments w2Pk txOutPayments (lovelaceValueOf 14_666_667) + assertTotalPayments (toCore' w1Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 1_333_333) + assertTotalPayments (toCore' w2Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 14_666_667) C.Error err -> assertNoFailedTransactions err @@ -380,23 +380,23 @@ futureWithMarginCall = txIn = [ C.TransactionInput (t0, t0) - [ C.NormalInput $ C.IDeposit w1Pk w1Pk ada 8_000_000 - , C.NormalInput $ C.IDeposit w2Pk w2Pk ada 8_000_000 ] + [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 8_000_000 + , C.NormalInput $ C.IDeposit (toCore' w2Pk) (toCore' w2Pk) ada 8_000_000 ] , C.TransactionInput (t1, t1) - [ C.NormalInput $ C.IChoice dirRate 200_000_000 - , C.NormalInput $ C.IChoice invRate 50_000_000 ] + [ C.NormalInput $ C.IChoice (toCore' dirRate) 200_000_000 + , C.NormalInput $ C.IChoice (toCore' invRate) 50_000_000 ] , C.TransactionInput (t2, t2) - [ C.NormalInput $ C.IDeposit w1Pk w1Pk ada 60_000_000 ] + [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 60_000_000 ] , C.TransactionInput (t3, t3) - [ C.NormalInput $ C.IChoice dirRate 133_333_333 - , C.NormalInput $ C.IChoice invRate 75_000_000 ] + [ C.NormalInput $ C.IChoice (toCore' dirRate) 133_333_333 + , C.NormalInput $ C.IChoice (toCore' invRate) 75_000_000 ] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (lovelaceValueOf 61_333_333) - assertTotalPayments w2Pk txOutPayments (lovelaceValueOf 14_666_667) + assertTotalPayments (toCore' w1Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 61_333_333) + assertTotalPayments (toCore' w2Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 14_666_667) C.Error err -> assertNoFailedTransactions err @@ -418,17 +418,17 @@ reverseConvertibleExercisedTest = repaymentTime = toPOSIX "2022-03-19 17:29:59.000000 UTC" exerciseTime = toPOSIX "2022-03-19 17:30:00.000000 UTC" txIn = - [ C.TransactionInput (0, 0) [ C.NormalInput $ C.IDeposit w1Pk w1Pk ada 9_000_000 ] - , C.TransactionInput (repaymentTime, repaymentTime) [ C.NormalInput $ C.IDeposit w1Pk (Role "BondProvider") ada 10_000_000 ] + [ C.TransactionInput (0, 0) [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 9_000_000 ] + , C.TransactionInput (repaymentTime, repaymentTime) [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (C.Role "BondProvider") ada 10_000_000 ] , C.TransactionInput (exerciseTime, exerciseTime) - [ C.NormalInput $ C.IChoice (ChoiceId "Exercise Put" (Role "OptionCounterparty")) 1 - , C.NormalInput $ C.IDeposit (Role "OptionCounterparty") (Role "OptionCounterparty") tok 30 ] + [ C.NormalInput $ C.IChoice (C.ChoiceId "Exercise Put" (C.Role "OptionCounterparty")) 1 + , C.NormalInput $ C.IDeposit (C.Role "OptionCounterparty") (C.Role "OptionCounterparty") tok 30 ] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (tokValueOf 30) + assertTotalPayments (toCore' w1Pk) txOutPayments (tokValueOf 30) C.Error err -> assertNoFailedTransactions err @@ -450,14 +450,14 @@ reverseConvertibleTest = repaymentTime = toPOSIX "2022-03-19 17:29:59.000000 UTC" exerciseTime = toPOSIX "2022-03-19 17:30:00.000000 UTC" txIn = - [ C.TransactionInput (0, 0) [ C.NormalInput $ C.IDeposit w1Pk w1Pk ada 9_000_000 ] - , C.TransactionInput (repaymentTime, repaymentTime) [ C.NormalInput $ C.IDeposit w1Pk (Role "BondProvider") ada 10_000_000 ] - , C.TransactionInput (exerciseTime, exerciseTime) [ C.NormalInput $ C.IChoice (ChoiceId "Exercise Put" (Role "OptionCounterparty")) 0 ] + [ C.TransactionInput (0, 0) [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (toCore' w1Pk) ada 9_000_000 ] + , C.TransactionInput (repaymentTime, repaymentTime) [ C.NormalInput $ C.IDeposit (toCore' w1Pk) (C.Role "BondProvider") ada 10_000_000 ] + , C.TransactionInput (exerciseTime, exerciseTime) [ C.NormalInput $ C.IChoice (C.ChoiceId "Exercise Put" (C.Role "OptionCounterparty")) 0 ] ] in case C.playTrace 0 contract txIn of C.TransactionOutput {..} -> do assertClose txOutContract assertNoWarnings txOutWarnings - assertTotalPayments w1Pk txOutPayments (lovelaceValueOf 10_000_000) + assertTotalPayments (toCore' w1Pk) txOutPayments (C.moneyFromValue $ lovelaceValueOf 10_000_000) C.Error err -> assertNoFailedTransactions err diff --git a/marlowe-playground-server/app/PSGenerator.hs b/marlowe-playground-server/app/PSGenerator.hs index 5ef81470b1..204c439a0e 100644 --- a/marlowe-playground-server/app/PSGenerator.hs +++ b/marlowe-playground-server/app/PSGenerator.hs @@ -307,6 +307,8 @@ writePangramJson outputDir = do S.Close ) encodedPangram = BS8.pack . Char8.unpack $ encode pangram + + state :: State S.PubKeyHash Token state = State { accounts = Map.singleton (alicePk, token) 12 diff --git a/marlowe-symbolic/src/Marlowe/Symbolic/Server.hs b/marlowe-symbolic/src/Marlowe/Symbolic/Server.hs index 104a7a3205..e1c34f3bbc 100644 --- a/marlowe-symbolic/src/Marlowe/Symbolic/Server.hs +++ b/marlowe-symbolic/src/Marlowe/Symbolic/Server.hs @@ -20,7 +20,7 @@ import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) import Formatting (fprint, (%)) import Formatting.Clock (timeSpecs) -import Language.Marlowe (Contract, POSIXTime (..), State, TransactionInput, TransactionWarning) +import Language.Marlowe (Contract, POSIXTime (..), PubKeyHash, State, Token, TransactionInput, TransactionWarning) import Language.Marlowe.Analysis.FSSemantics (warningsTraceCustom) import Marlowe.Symbolic.Types.Request (Request (..)) import Marlowe.Symbolic.Types.Response (Response (..), Result (..)) @@ -33,7 +33,7 @@ import Text.PrettyPrint.Leijen (displayS, renderCompact) type API = "api" :> "marlowe-analysis" :> ReqBody '[JSON] Request :> Post '[JSON] Response makeResult :: - Either String (Maybe (POSIXTime, [TransactionInput], [TransactionWarning])) -> + Either String (Maybe (POSIXTime, [TransactionInput PubKeyHash Token], [TransactionWarning PubKeyHash Token])) -> Result makeResult (Left err) = Error (show err) makeResult (Right res) = diff --git a/marlowe-symbolic/src/Marlowe/Symbolic/Types/Request.hs b/marlowe-symbolic/src/Marlowe/Symbolic/Types/Request.hs index 34fc1e2ab0..d15eef4412 100644 --- a/marlowe-symbolic/src/Marlowe/Symbolic/Types/Request.hs +++ b/marlowe-symbolic/src/Marlowe/Symbolic/Types/Request.hs @@ -3,12 +3,12 @@ module Marlowe.Symbolic.Types.Request where import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generic) -import Language.Marlowe (Contract, State) +import Language.Marlowe (Contract, PubKeyHash, State, Token) data Request = Request { onlyAssertions :: Bool - , contract :: Contract - , state :: State + , contract :: Contract PubKeyHash Token + , state :: State PubKeyHash Token } deriving (Generic) instance FromJSON Request instance ToJSON Request diff --git a/marlowe-symbolic/src/Marlowe/Symbolic/Types/Response.hs b/marlowe-symbolic/src/Marlowe/Symbolic/Types/Response.hs index d2bdbb2874..f7a0459819 100644 --- a/marlowe-symbolic/src/Marlowe/Symbolic/Types/Response.hs +++ b/marlowe-symbolic/src/Marlowe/Symbolic/Types/Response.hs @@ -4,12 +4,14 @@ module Marlowe.Symbolic.Types.Response where import Data.Aeson (FromJSON, ToJSON) import GHC.Generics import Language.Marlowe.Core.V1.Semantics (TransactionInput, TransactionWarning) +import Language.Marlowe.Core.V1.Semantics.Token (Token) +import Ledger (PubKeyHash) data Result = Valid | CounterExample { initialSlot :: Integer - , transactionList :: [TransactionInput] - , transactionWarning :: [TransactionWarning] + , transactionList :: [TransactionInput PubKeyHash Token] + , transactionWarning :: [TransactionWarning PubKeyHash Token] } | Error String deriving (Generic) diff --git a/marlowe/marlowe.cabal b/marlowe/marlowe.cabal index 7630e9fa56..0f9654f050 100644 --- a/marlowe/marlowe.cabal +++ b/marlowe/marlowe.cabal @@ -85,6 +85,8 @@ library Language.Marlowe Language.Marlowe.Extended.V1 Language.Marlowe.Core.V1.Semantics + Language.Marlowe.Core.V1.Semantics.Money + Language.Marlowe.Core.V1.Semantics.Token Language.Marlowe.Core.V1.Semantics.Types Language.Marlowe.FindInputs Language.Marlowe.Client diff --git a/marlowe/src/Language/Marlowe.hs b/marlowe/src/Language/Marlowe.hs index d03da454e5..829a936771 100644 --- a/marlowe/src/Language/Marlowe.hs +++ b/marlowe/src/Language/Marlowe.hs @@ -1,10 +1,13 @@ module Language.Marlowe ( module Language.Marlowe.Core.V1.Semantics + ,module Language.Marlowe.Core.V1.Semantics.Money + , module Language.Marlowe.Core.V1.Semantics.Token , module Language.Marlowe.Core.V1.Semantics.Types , module Language.Marlowe.Client , module Language.Marlowe.Util , module Language.Marlowe.Pretty , POSIXTime (..) + , PubKeyHash (..) , adaSymbol , adaToken , (%) @@ -13,10 +16,12 @@ where import Language.Marlowe.Client import Language.Marlowe.Core.V1.Semantics +import Language.Marlowe.Core.V1.Semantics.Money +import Language.Marlowe.Core.V1.Semantics.Token import Language.Marlowe.Core.V1.Semantics.Types hiding (getAction) import Language.Marlowe.Pretty import Language.Marlowe.Util -import Ledger (POSIXTime (..)) +import Ledger (POSIXTime (..), PubKeyHash (..)) import Ledger.Ada (adaSymbol, adaToken) import PlutusTx.Ratio as P diff --git a/marlowe/src/Language/Marlowe/Analysis/FSSemantics.hs b/marlowe/src/Language/Marlowe/Analysis/FSSemantics.hs index 89b11b5202..1336b2d441 100644 --- a/marlowe/src/Language/Marlowe/Analysis/FSSemantics.hs +++ b/marlowe/src/Language/Marlowe/Analysis/FSSemantics.hs @@ -29,9 +29,9 @@ import qualified PlutusTx.Ratio as P --------------------------------------------------- -- Symbolic version of Input (with symbolic value but concrete identifiers) -data SymInput = SymDeposit AccountId Party Token SInteger - | SymChoice ChoiceId SInteger - | SymNotify +data SymInput i t = SymDeposit (AccountId i) (Party i) t SInteger + | SymChoice (ChoiceId i) SInteger + | SymNotify -- Symbolic version of State: -- We keep as much things concrete as possible. @@ -65,16 +65,16 @@ data SymInput = SymDeposit AccountId Party Token SInteger -- -- minTime just corresponds to lowTime, because it is just a lower bound for the minimum -- time, and it gets updated with the minimum time. -data SymState = SymState { lowTime :: SInteger - , highTime :: SInteger - , traces :: [(SInteger, SInteger, Maybe SymInput, Integer)] - , paramTrace :: [(SInteger, SInteger, SInteger, SInteger)] - , symInput :: Maybe SymInput - , whenPos :: Integer - , symAccounts :: Map (AccountId, Token) SInteger - , symChoices :: Map ChoiceId SInteger - , symBoundValues :: Map ValueId SInteger - } +data SymState i t = SymState { lowTime :: SInteger + , highTime :: SInteger + , traces :: [(SInteger, SInteger, Maybe (SymInput i t), Integer)] + , paramTrace :: [(SInteger, SInteger, SInteger, SInteger)] + , symInput :: Maybe (SymInput i t) + , whenPos :: Integer + , symAccounts :: Map (AccountId i, t) SInteger + , symChoices :: Map (ChoiceId i) SInteger + , symBoundValues :: Map ValueId SInteger + } -- It generates a valid symbolic interval with lower bound ms (if provided) generateSymbolicInterval :: Maybe Integer -> Symbolic (SInteger, SInteger) @@ -105,8 +105,9 @@ toSymMap = foldAssocMapWithKey toSymItem mempty -- First parameter (pt) is the input parameter trace, which is just a fixed length -- list of symbolic integers that are matched to trace. -- When Nothing is passed as second parameter it acts like emptyState. -mkInitialSymState :: [(SInteger, SInteger, SInteger, SInteger)] -> Maybe State - -> Symbolic SymState +mkInitialSymState :: (Ord i, Ord t) + => [(SInteger, SInteger, SInteger, SInteger)] -> Maybe (State i t) + -> Symbolic (SymState i t) mkInitialSymState pt Nothing = do (ls, hs) <- generateSymbolicInterval Nothing return $ SymState { lowTime = ls , highTime = hs @@ -147,14 +148,14 @@ mkInitialSymState pt (Just State { accounts = accs -- The identifiers for Deposit and Choice are calculated using the When clause and -- the contract (which is concrete), and using the semantics after a counter example is -- found. -convertRestToSymbolicTrace :: [(SInteger, SInteger, Maybe SymInput, Integer)] -> +convertRestToSymbolicTrace :: [(SInteger, SInteger, Maybe (SymInput i t), Integer)] -> [(SInteger, SInteger, SInteger, SInteger)] -> SBool convertRestToSymbolicTrace [] [] = sTrue convertRestToSymbolicTrace ((lowS, highS, inp, pos):t) ((a, b, c, d):t2) = (lowS .== a) .&& (highS .== b) .&& (getSymValFrom inp .== c) .&& (literal pos .== d) .&& convertRestToSymbolicTrace t t2 where - getSymValFrom :: Maybe SymInput -> SInteger + getSymValFrom :: Maybe (SymInput i t) -> SInteger getSymValFrom Nothing = 0 getSymValFrom (Just (SymDeposit _ _ _ val)) = val getSymValFrom (Just (SymChoice _ val)) = val @@ -166,7 +167,7 @@ isPadding ((a, b, c, d):t) = (a .== -1) .&& (b .== -1) .&& (c .== -1) .&& (d .== -1) .&& isPadding t isPadding [] = sTrue -convertToSymbolicTrace :: [(SInteger, SInteger, Maybe SymInput, Integer)] -> +convertToSymbolicTrace :: [(SInteger, SInteger, Maybe (SymInput i t), Integer)] -> [(SInteger, SInteger, SInteger, SInteger)] -> SBool convertToSymbolicTrace refL symL = let lenRefL = length refL @@ -177,7 +178,7 @@ convertToSymbolicTrace refL symL = else error "Provided symbolic trace is not long enough" -- Symbolic version evalValue -symEvalVal :: Value Observation -> SymState -> SInteger +symEvalVal :: (Ord i, Ord t) => Value i t -> SymState i t -> SInteger symEvalVal (AvailableMoney accId tok) symState = M.findWithDefault (literal 0) (accId, tok) (symAccounts symState) symEvalVal (Constant inte) symState = literal inte @@ -211,7 +212,7 @@ symEvalVal (Cond cond v1 v2) symState = ite (symEvalObs cond symState) (symEvalVal v2 symState) -- Symbolic version evalObservation -symEvalObs :: Observation -> SymState -> SBool +symEvalObs :: (Ord i, Ord t) => Observation i t -> SymState i t -> SBool symEvalObs (AndObs obs1 obs2) symState = symEvalObs obs1 symState .&& symEvalObs obs2 symState symEvalObs (OrObs obs1 obs2) symState = symEvalObs obs1 symState .|| @@ -233,7 +234,7 @@ symEvalObs TrueObs _ = sTrue symEvalObs FalseObs _ = sFalse -- Update the symbolic state given a symbolic input (just the maps) -updateSymInput :: Maybe SymInput -> SymState -> Symbolic SymState +updateSymInput :: (Ord i, Ord t) => Maybe (SymInput i t) -> SymState i t -> Symbolic (SymState i t) updateSymInput Nothing symState = return symState updateSymInput (Just (SymDeposit accId _ tok val)) symState = let resultVal = M.findWithDefault 0 (accId, tok) (symAccounts symState) @@ -259,8 +260,9 @@ updateSymInput (Just SymNotify) symState = return symState -- time to be equal to the ones of the previous transaction. That will typically make one -- of the transactions useless, but we discard useless transactions by the end so that -- is fine. -addTransaction :: SInteger -> SInteger -> Maybe SymInput -> Timeout -> SymState -> Integer - -> Symbolic (SBool, SymState) +addTransaction :: (Ord i, Ord t) + => SInteger -> SInteger -> Maybe (SymInput i t) -> Timeout -> SymState i t -> Integer + -> Symbolic (SBool, SymState i t) addTransaction newLowSlot newHighSlot Nothing slotTim symState@SymState { lowTime = oldLowSlot , highTime = oldHighSlot @@ -319,7 +321,8 @@ onlyAssertionsPatch b p1 p2 -- The result of this function is a boolean that indicates whether: -- 1. The transaction is valid (according to the semantics) -- 2. It has issued a warning (as indicated by hasErr) -isValidAndFailsAux :: Bool -> SBool -> Contract -> SymState +isValidAndFailsAux :: (Ord i, Ord t) + => Bool -> SBool -> Contract i t -> SymState i t -> Symbolic SBool isValidAndFailsAux oa hasErr Close sState = return (hasErr .&& convertToSymbolicTrace ((lowTime sState, highTime sState, @@ -370,8 +373,9 @@ ensureBounds cho (Bound lowBnd hiBnd:t) = ((cho .>= literal lowBnd) .&& (cho .<= literal hiBnd)) .|| ensureBounds cho t -- Just combines addTransaction and isValidAndFailsAux -applyInputConditions :: Bool -> SInteger -> SInteger -> SBool -> Maybe SymInput -> Timeout - -> SymState -> Integer -> Contract +applyInputConditions :: (Ord i, Ord t) + => Bool -> SInteger -> SInteger -> SBool -> Maybe (SymInput i t) -> Timeout + -> SymState i t -> Integer -> Contract i t -> Symbolic (SBool, SBool) applyInputConditions oa ls hs hasErr maybeSymInput timeout sState pos cont = do (newCond, newSState) <- addTransaction ls hs maybeSymInput timeout sState pos @@ -379,7 +383,7 @@ applyInputConditions oa ls hs hasErr maybeSymInput timeout sState pos cont = return (newCond, newTrace) -- Generates two new slot numbers and puts them in the symbolic state -addFreshSlotsToState :: SymState -> Symbolic (SInteger, SInteger, SymState) +addFreshSlotsToState :: SymState i t -> Symbolic (SInteger, SInteger, SymState i t) addFreshSlotsToState sState = do newLowSlot <- sInteger_ newHighSlot <- sInteger_ @@ -392,8 +396,9 @@ addFreshSlotsToState sState = -- that happened then the current case would never be reached, we keep adding conditions -- to the function and pass it to the next iteration of isValidAndFailsWhen. -- - pos - Is the position of the current Case clause [1..], 0 means timeout branch. -isValidAndFailsWhen :: Bool -> SBool -> [Case Contract] -> Timeout -> Contract -> (SymInput -> SymState -> SBool) - -> SymState -> Integer -> Symbolic SBool +isValidAndFailsWhen :: (Ord i, Ord t) + => Bool -> SBool -> [Case i t] -> Timeout -> Contract i t -> (SymInput i t -> SymState i t -> SBool) + -> SymState i t -> Integer -> Symbolic SBool isValidAndFailsWhen oa hasErr [] timeout cont previousMatch sState pos = do newLowSlot <- sInteger_ newHighSlot <- sInteger_ @@ -504,7 +509,7 @@ isValidAndFailsWhen oa hasErr (MerkleizedCase (Notify obs) _:rest) -- Counts the maximum number of nested Whens. This acts as a bound for the maximum -- necessary number of transactions for exploring the whole contract. This bound -- has been proven in TransactionBound.thy -countWhens :: Contract -> Integer +countWhens :: Contract i t -> Integer countWhens Close = 0 countWhens (Pay uv uw ux uy c) = countWhens c countWhens (If uz c c2) = max (countWhens c) (countWhens c2) @@ -513,7 +518,7 @@ countWhens (Let va vb c) = countWhens c countWhens (Assert o c) = countWhens c -- Same as countWhens but it starts with a Case list -countWhensCaseList :: [Case Contract] -> Integer +countWhensCaseList :: [Case i t] -> Integer countWhensCaseList (Case uu c : tail) = max (countWhens c) (countWhensCaseList tail) countWhensCaseList (MerkleizedCase uu c : tail) = countWhensCaseList tail countWhensCaseList [] = 0 @@ -524,7 +529,8 @@ countWhensCaseList [] = 0 -- this function because then we would have to return a symbolic list that would make -- the whole process slower. It is meant to be used just with SBV, with a symbolic -- paramTrace, and we use the symbolic paramTrace to know which is the counterexample. -wrapper :: Bool -> Contract -> [(SInteger, SInteger, SInteger, SInteger)] -> Maybe State +wrapper :: (Ord i, Ord t) + => Bool -> Contract i t -> [(SInteger, SInteger, SInteger, SInteger)] -> Maybe (State i t) -> Symbolic SBool wrapper oa c st maybeState = do ess <- mkInitialSymState st maybeState isValidAndFailsAux oa sFalse c ess @@ -572,7 +578,7 @@ groupResult _ _ = error "Wrong number of labels generated" -- Reconstructs an input from a Case list a Case position and a value (deposit amount or -- chosen value) -caseToInput :: [Case a] -> Integer -> Integer -> Input +caseToInput :: [Case i t] -> Integer -> Integer -> Input i t caseToInput [] _ _ = error "Wrong number of cases interpreting result" caseToInput (Case h _:t) c v | c > 1 = caseToInput t (c - 1) v @@ -593,9 +599,10 @@ caseToInput (MerkleizedCase _ _:t) c v -- Input is passed as a combination and function from input list to transaction input and -- input list for convenience. The list of 4-uples is passed through because it is used -- to recursively call executeAndInterpret (co-recursive funtion). -computeAndContinue :: ([Input] -> TransactionInput) -> [Input] -> State -> Contract +computeAndContinue :: (P.Eq i, P.Eq t) + => ([Input i t] -> TransactionInput i t) -> [Input i t] -> State i t -> Contract i t -> [(Integer, Integer, Integer, Integer)] - -> [([TransactionInput], [TransactionWarning])] + -> [([TransactionInput i t], [TransactionWarning i t])] computeAndContinue transaction inps sta cont t = case computeTransaction (transaction inps) sta cont of Error TEUselessTransaction -> executeAndInterpret sta t cont @@ -607,8 +614,9 @@ computeAndContinue transaction inps sta cont t = -- Takes a list of 4-uples (and state and contract) and interprets it as a list of -- transactions and also computes the resulting list of warnings. -executeAndInterpret :: State -> [(Integer, Integer, Integer, Integer)] -> Contract - -> [([TransactionInput], [TransactionWarning])] +executeAndInterpret :: (P.Eq i, P.Eq t) + => State i t -> [(Integer, Integer, Integer, Integer)] -> Contract i t + -> [([TransactionInput i t], [TransactionWarning i t])] executeAndInterpret _ [] _ = [] executeAndInterpret sta ((l, h, v, b):t) cont | b == 0 = computeAndContinue transaction [] sta cont t @@ -628,8 +636,9 @@ executeAndInterpret sta ((l, h, v, b):t) cont -- It wraps executeAndInterpret so that it takes an optional State, and also -- combines the results of executeAndInterpret in one single tuple. -interpretResult :: [(Integer, Integer, Integer, Integer)] -> Contract -> Maybe State - -> (POSIXTime, [TransactionInput], [TransactionWarning]) +interpretResult :: (P.Eq i, P.Eq t) + => [(Integer, Integer, Integer, Integer)] -> Contract i t -> Maybe (State i t) + -> (POSIXTime, [TransactionInput i t], [TransactionWarning i t]) interpretResult [] _ _ = error "Empty result" interpretResult t@((l, _, _, _):_) c maybeState = (POSIXTime l, tin, twa) where (tin, twa) = foldl' (\(accInp, accWarn) (elemInp, elemWarn) -> @@ -641,8 +650,9 @@ interpretResult t@((l, _, _, _):_) c maybeState = (POSIXTime l, tin, twa) -- It interprets the counter example found by SBV (SMTModel), given the contract, -- and initial state (optional), and the list of variables used. -extractCounterExample :: SMTModel -> Contract -> Maybe State -> [String] - -> (POSIXTime, [TransactionInput], [TransactionWarning]) +extractCounterExample :: (P.Eq i, P.Eq t) + => SMTModel -> Contract i t -> Maybe (State i t) -> [String] + -> (POSIXTime, [TransactionInput i t], [TransactionWarning i t]) extractCounterExample smtModel cont maybeState maps = interpretedResult where assocs = map (\(a, b) -> (a, fromCV b :: Integer)) $ modelAssocs smtModel counterExample = groupResult maps (M.fromList assocs) @@ -650,11 +660,12 @@ extractCounterExample smtModel cont maybeState maps = interpretedResult -- Wrapper function that carries the static analysis and interprets the result. -- It generates variables, runs SBV, and it interprets the result in Marlow terms. -warningsTraceCustom :: Bool - -> Contract - -> Maybe State +warningsTraceCustom :: (P.Eq i, P.Eq t, Ord i, Ord t) + => Bool + -> Contract i t + -> Maybe (State i t) -> IO (Either ThmResult - (Maybe (POSIXTime, [TransactionInput], [TransactionWarning]))) + (Maybe (POSIXTime, [TransactionInput i t], [TransactionWarning i t]))) warningsTraceCustom onlyAssertions con maybeState = do thmRes@(ThmResult result) <- satCommand return (case result of @@ -670,23 +681,26 @@ warningsTraceCustom onlyAssertions con maybeState = satCommand = proveWith z3 property -- Like warningsTraceCustom but checks all warnings (including assertions) -warningsTraceWithState :: Contract - -> Maybe State +warningsTraceWithState :: (P.Eq i, P.Eq t, Ord i, Ord t) + => Contract i t + -> Maybe (State i t) -> IO (Either ThmResult - (Maybe (POSIXTime, [TransactionInput], [TransactionWarning]))) + (Maybe (POSIXTime, [TransactionInput i t], [TransactionWarning i t]))) warningsTraceWithState = warningsTraceCustom False -- Like warningsTraceCustom but only checks assertions. -onlyAssertionsWithState :: Contract - -> Maybe State +onlyAssertionsWithState :: (P.Eq i, P.Eq t, Ord i, Ord t) + => Contract i t + -> Maybe (State i t) -> IO (Either ThmResult - (Maybe (POSIXTime, [TransactionInput], [TransactionWarning]))) + (Maybe (POSIXTime, [TransactionInput i t], [TransactionWarning i t]))) onlyAssertionsWithState = warningsTraceCustom True -- Like warningsTraceWithState but without initialState. -warningsTrace :: Contract +warningsTrace :: (P.Eq i, P.Eq t, Ord i, Ord t) + => Contract i t -> IO (Either ThmResult - (Maybe (POSIXTime, [TransactionInput], [TransactionWarning]))) + (Maybe (POSIXTime, [TransactionInput i t], [TransactionWarning i t]))) warningsTrace con = warningsTraceWithState con Nothing diff --git a/marlowe/src/Language/Marlowe/Client.hs b/marlowe/src/Language/Marlowe/Client.hs index 307b5a10b7..72d272554e 100644 --- a/marlowe/src/Language/Marlowe/Client.hs +++ b/marlowe/src/Language/Marlowe/Client.hs @@ -62,6 +62,7 @@ import Language.Marlowe.Client.History (History (..), IncludePkhTxns (IncludePkh txRoleData) import Language.Marlowe.Core.V1.Semantics import qualified Language.Marlowe.Core.V1.Semantics as Marlowe +import Language.Marlowe.Core.V1.Semantics.Token import Language.Marlowe.Core.V1.Semantics.Types hiding (Contract, getAction) import qualified Language.Marlowe.Core.V1.Semantics.Types as Marlowe import Language.Marlowe.Scripts @@ -106,8 +107,8 @@ import PlutusTx.Traversable (for) -data MarloweClientInput = ClientInput InputContent - | ClientMerkleizedInput InputContent Marlowe.Contract +data MarloweClientInput = ClientInput (InputContent PubKeyHash Token) + | ClientMerkleizedInput (InputContent PubKeyHash Token) (Marlowe.Contract PubKeyHash Token) deriving stock (Eq, Show, Generic) instance FromJSON MarloweClientInput where @@ -118,10 +119,10 @@ instance ToJSON MarloweClientInput where toJSON (ClientMerkleizedInput content contract) = toJSON (content, contract) -type CreateEndpointSchema = (UUID, AssocMap.Map Val.TokenName (AddressInEra ShelleyEra), Marlowe.Contract) +type CreateEndpointSchema = (UUID, AssocMap.Map Val.TokenName (AddressInEra ShelleyEra), Marlowe.Contract PubKeyHash Token) type ApplyInputsEndpointSchema = (UUID, MarloweParams, Maybe TimeInterval, [MarloweClientInput]) -type ApplyInputsNonMerkleizedEndpointSchema = (UUID, MarloweParams, Maybe TimeInterval, [InputContent]) -type AutoEndpointSchema = (UUID, MarloweParams, Party, POSIXTime) +type ApplyInputsNonMerkleizedEndpointSchema = (UUID, MarloweParams, Maybe TimeInterval, [InputContent PubKeyHash Token]) +type AutoEndpointSchema = (UUID, MarloweParams, Party PubKeyHash, POSIXTime) type RedeemEndpointSchema = (UUID, MarloweParams, TokenName, AddressInEra ShelleyEra) type CloseEndpointSchema = UUID @@ -167,7 +168,7 @@ instance AsCheckpointError MarloweError where _CheckpointError = _OtherContractError . _CheckpointError data PartyAction - = PayDeposit AccountId Party Token Integer + = PayDeposit (AccountId PubKeyHash) (Party PubKeyHash) Token Integer | WaitForTimeout POSIXTime | WaitOtherActionUntil POSIXTime | NotSure @@ -182,16 +183,16 @@ type RoleOwners = AssocMap.Map Val.TokenName (AddressInEra ShelleyEra) -- Now we are not able to notify about role payouts before the contract is on the chain. data ContractHistory = ContractHistory - { chParams :: MarloweParams -- ^ The "instance id" of the contract - , chInitialData :: MarloweData -- ^ The initial Contract + State - , chHistory :: [TransactionInput] -- ^ All the transaction that affected the contract. - -- The current state and intermediate states can - -- be recalculated by using computeTransaction - -- of each TransactionInput to the initial state - , chAddress :: Address -- ^ The script address of the marlowe contract - , chUnspentPayouts :: UnspentPayouts -- ^ All UTxOs associated with our payout script. - -- Please note that in theory we include here outpus - -- which possible were created by an "external" transactions. + { chParams :: MarloweParams -- ^ The "instance id" of the contract + , chInitialData :: MarloweData PubKeyHash Token -- ^ The initial Contract + State + , chHistory :: [TransactionInput PubKeyHash Token] -- ^ All the transaction that affected the contract. + -- The current state and intermediate states can + -- be recalculated by using computeTransaction + -- of each TransactionInput to the initial state + , chAddress :: Address -- ^ The script address of the marlowe contract + , chUnspentPayouts :: UnspentPayouts -- ^ All UTxOs associated with our payout script. + -- Please note that in theory we include here outpus + -- which possible were created by an "external" transactions. } deriving stock (Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -789,7 +790,7 @@ marlowePlutusContract = selectList [create, apply, applyNonmerkleized, auto, red marlowePlutusContract auto = endpoint @"auto" $ \(reqId, params, party, untilTime) -> catchError reqId "auto" $ do let typedValidator = mkMarloweTypedValidator params - let continueWith :: MarloweData -> Contract MarloweContractState MarloweSchema MarloweError () + let continueWith :: MarloweData PubKeyHash Token -> Contract MarloweContractState MarloweSchema MarloweError () continueWith md@MarloweData{marloweContract} = if canAutoExecuteContractForParty party marloweContract then autoExecuteContract reqId params typedValidator party md @@ -821,13 +822,14 @@ marlowePlutusContract = selectList [create, apply, applyNonmerkleized, auto, red autoExecuteContract :: UUID -> MarloweParams -> SmallTypedValidator - -> Party - -> MarloweData + -> Party PubKeyHash + -> MarloweData PubKeyHash Token -> Contract MarloweContractState MarloweSchema MarloweError () autoExecuteContract reqId params typedValidator party marloweData = do time <- currentTime let timeRange = (time, time + defaultTxValidationRange) - let action = getAction timeRange party marloweData + let (warnings, action) = getAction timeRange party marloweData + forM_ warnings $ \w -> logWarn $ "Warning: " <> show w case action of PayDeposit acc p token amount -> do logInfo $ "PayDeposit " <> show amount <> " at within time " <> show timeRange @@ -959,11 +961,11 @@ shelleyAddressToKeys (AddressInEra _ (Shelley.ShelleyAddress _ paymentCredential pure (ppkh, Just . StakePubKeyHash . PubKeyHash . toBuiltin $ serialiseToRawBytes stakeHash) shelleyAddressToKeys _ = throwError $ OtherContractError $ Contract.OtherContractError "Byron Addresses not supported" -getAction :: MarloweTimeRange -> Party -> MarloweData -> PartyAction +getAction :: MarloweTimeRange -> Party PubKeyHash -> MarloweData PubKeyHash Token -> ([TransactionWarning PubKeyHash Token], PartyAction) getAction timeRange party MarloweData{marloweContract,marloweState} = let env = Environment timeRange in case reduceContractUntilQuiescent env marloweState marloweContract of - ContractQuiescent _reduced _warnings _payments state contract -> + ContractQuiescent _reduced warnings _payments state contract -> (convertReduceWarnings warnings, -- here the contract is either When or Close case contract of When [Case (Deposit acc depositParty tok value) _] _ _ @@ -976,6 +978,7 @@ getAction timeRange party MarloweData{marloweContract,marloweState} = let When [] timeout _ -> WaitForTimeout timeout Close -> CloseContract _ -> NotSure + ) -- When timeout is in the time range RRAmbiguousTimeIntervalError -> {- FIXME @@ -991,11 +994,11 @@ getAction timeRange party MarloweData{marloweContract,marloweState} = let Then we'd rather wait until time 100 instead and would make the Deposit. I propose to modify RRAmbiguousTimeIntervalError to include the expected timeout. -} - WaitForTimeout (snd timeRange) + ([], WaitForTimeout (snd timeRange)) -canAutoExecuteContractForParty :: Party -> Marlowe.Contract -> Bool +canAutoExecuteContractForParty :: Party PubKeyHash -> Marlowe.Contract PubKeyHash Token -> Bool canAutoExecuteContractForParty party = check where check cont = @@ -1019,7 +1022,7 @@ applyInputs :: AsMarloweError e -> SmallTypedValidator -> Maybe TimeInterval -> [MarloweClientInput] - -> Contract MarloweContractState MarloweSchema e MarloweData + -> Contract MarloweContractState MarloweSchema e (MarloweData PubKeyHash Token) applyInputs params typedValidator timeInterval inputs = mapError (review _MarloweError) $ do let debug' = debug "applyInputs" -- Wait until a block is produced, so we have an accurate current time and slot. @@ -1063,9 +1066,9 @@ defaultMarloweParams :: MarloweParams defaultMarloweParams = marloweParams adaSymbol -newtype CompanionState = CompanionState (Map MarloweParams MarloweData) +newtype CompanionState = CompanionState (Map MarloweParams (MarloweData PubKeyHash Token)) deriving (Eq, Show) - deriving (Semigroup,Monoid) via (Map MarloweParams MarloweData) + deriving (Semigroup,Monoid) via (Map MarloweParams (MarloweData PubKeyHash Token)) instance ToJSON CompanionState where toJSON (CompanionState m) = toJSON $ Map.toList m @@ -1146,7 +1149,7 @@ findMarloweContractsOnChainByRoleCurrency -> Contract CompanionState MarloweCompanionSchema MarloweError - (Maybe (MarloweParams, MarloweData)) + (Maybe (MarloweParams, MarloweData PubKeyHash Token)) findMarloweContractsOnChainByRoleCurrency curSym = do let params = marloweParams curSym let typedValidator = mkMarloweTypedValidator params @@ -1185,7 +1188,7 @@ mkStep :: -> SmallTypedValidator -> TimeInterval -> [MarloweClientInput] - -> Contract w MarloweSchema MarloweError MarloweData + -> Contract w MarloweSchema MarloweError (MarloweData PubKeyHash Token) mkStep MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientInputs = do debug "mkStep" $ "clientInputs = " <> show clientInputs slotConfig <- getSlotConfig @@ -1248,10 +1251,10 @@ mkStep MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientIn debug "mkStep" $ "tx confirmation failed txId = " <> show txId throwError $ OtherContractError $ Contract.OtherContractError "mkStep failed to confirm the transaction" where - evaluateTxContstraints :: MarloweData + evaluateTxContstraints :: MarloweData PubKeyHash Token -> Ledger.POSIXTimeRange -> Tx.TxOutRef - -> Contract w MarloweSchema MarloweError (TxConstraints [MarloweTxInput] MarloweData, MarloweData) + -> Contract w MarloweSchema MarloweError (TxConstraints [MarloweTxInput PubKeyHash Token] (MarloweData PubKeyHash Token), MarloweData PubKeyHash Token) evaluateTxContstraints MarloweData{..} times marloweTxOutRef = do let (inputs, inputsConstraints) = foldMap clientInputToInputAndConstraints clientInputs let txInput = TransactionInput { @@ -1281,7 +1284,8 @@ mkStep MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientIn Close -> txConstraints _ -> let finalBalance = let - contractBalance = totalBalance (accounts marloweState) + contractBalance, totalIncome, totalPayouts :: Val.Value + contractBalance = moneyToValue $ totalBalance (accounts marloweState) totalIncome = P.foldMap (collectDeposits . getInputContent) inputs totalPayouts = P.foldMap snd payoutsByParty in contractBalance P.+ totalIncome P.- totalPayouts @@ -1296,7 +1300,7 @@ mkStep MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientIn Error e -> throwError $ MarloweEvaluationError e - clientInputToInputAndConstraints :: MarloweClientInput -> ([Input], TxConstraints Void Void) + clientInputToInputAndConstraints :: MarloweClientInput -> ([Input PubKeyHash Token], TxConstraints Void Void) clientInputToInputAndConstraints = \case ClientInput input -> ([NormalInput input], inputContentConstraints input) ClientMerkleizedInput input continuation -> let @@ -1305,7 +1309,7 @@ mkStep MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientIn constraints = inputContentConstraints input <> mustIncludeDatum (Datum builtin) in ([MerkleizedInput input hash continuation], constraints) where - inputContentConstraints :: InputContent -> TxConstraints Void Void + inputContentConstraints :: InputContent PubKeyHash Token -> TxConstraints Void Void inputContentConstraints input = case input of IDeposit _ party _ _ -> partyWitnessConstraint party @@ -1319,15 +1323,15 @@ mkStep MarloweParams{..} typedValidator timeInterval@(minTime, maxTime) clientIn mustSpendRoleToken role = mustSpendAtLeast $ Val.singleton rolesCurrency role 1 - collectDeposits :: InputContent -> Val.Value + collectDeposits :: InputContent PubKeyHash Token -> Val.Value collectDeposits (IDeposit _ _ (Token cur tok) amount) = Val.singleton cur tok amount collectDeposits _ = P.zero - payoutByParty :: Payment -> AssocMap.Map Party Val.Value - payoutByParty (Payment _ (Party party) money) = AssocMap.singleton party money + payoutByParty :: Payment PubKeyHash Token -> AssocMap.Map (Party PubKeyHash) Val.Value + payoutByParty (Payment _ (Party party) money) = AssocMap.singleton party (moneyToValue money) payoutByParty (Payment _ (Account _) _) = AssocMap.empty - payoutConstraints :: [(Party, Val.Value)] -> TxConstraints i0 o0 + payoutConstraints :: [(Party PubKeyHash, Val.Value)] -> TxConstraints i0 o0 payoutConstraints payoutsByParty = foldMap payoutToTxOut payoutsByParty where payoutToTxOut (party, value) = case party of diff --git a/marlowe/src/Language/Marlowe/Client/History.hs b/marlowe/src/Language/Marlowe/Client/History.hs index 8113ae54e7..893922f756 100644 --- a/marlowe/src/Language/Marlowe/Client/History.hs +++ b/marlowe/src/Language/Marlowe/Client/History.hs @@ -56,9 +56,10 @@ import Data.Maybe (catMaybes, isJust, isNothing, mapMaybe) import Data.Tuple.Extra (secondM) import GHC.Generics (Generic) import Language.Marlowe.Core.V1.Semantics (MarloweData, MarloweParams (..), TransactionInput (TransactionInput)) +import Language.Marlowe.Core.V1.Semantics.Token (Token) import Language.Marlowe.Scripts (SmallTypedValidator, TypedMarloweValidator, TypedRolePayoutValidator, smallUntypedValidator) -import Ledger (ChainIndexTxOut (..), ciTxOutAddress, toTxOut) +import Ledger (ChainIndexTxOut (..), PubKeyHash, ciTxOutAddress, toTxOut) import Ledger.TimeSlot (SlotConfig, slotRangeToPOSIXTimeRange) import Ledger.Tx.CardanoAPI (SomeCardanoApiTx (SomeTx)) import Ledger.Typed.Scripts (DatumType, validatorAddress) @@ -102,23 +103,23 @@ data History = -- | The contract was created. Created { - historyTxOutRef :: TxOutRef -- ^ The UTxO that created the contract. - , historyData :: MarloweData -- ^ The Marlowe data attached to the UTxO. - , historyNext :: Maybe History -- ^ The next step in the history, if known. + historyTxOutRef :: TxOutRef -- ^ The UTxO that created the contract. + , historyData :: MarloweData PubKeyHash Token -- ^ The Marlowe data attached to the UTxO. + , historyNext :: Maybe History -- ^ The next step in the history, if known. } -- | Input was applied to the contract. | InputApplied { - historyInput :: TransactionInput -- ^ The Marlowe input that was applied. - , historyTxOutRef :: TxOutRef -- ^ The UTxO that resulted from the input being applied. - , historyData :: MarloweData -- ^ The Marlowe data attached to the UTxO. - , historyNext :: Maybe History -- ^ The next step in the history, if known. + historyInput :: TransactionInput PubKeyHash Token -- ^ The Marlowe input that was applied. + , historyTxOutRef :: TxOutRef -- ^ The UTxO that resulted from the input being applied. + , historyData :: MarloweData PubKeyHash Token -- ^ The Marlowe data attached to the UTxO. + , historyNext :: Maybe History -- ^ The next step in the history, if known. } -- | The contract was closed. | Closed { - historyInput :: TransactionInput -- ^ The Marlowe input that was applied. - , historyTxId :: TxId -- ^ The transaction that resulted from the input being applied. + historyInput :: TransactionInput PubKeyHash Token -- ^ The Marlowe input that was applied. + , historyTxId :: TxId -- ^ The transaction that resulted from the input being applied. } deriving stock (Eq, Generic, Show) deriving anyclass (ToJSON, FromJSON) @@ -333,8 +334,8 @@ marloweStatesFrom validator citx = -- | Extract the Marlowe state from a Marlowe-specific output. -toMarloweState :: MarloweTxOutRef -- ^ The Marlowe-specific output. - -> MarloweData -- ^ The Marlowe data. +toMarloweState :: MarloweTxOutRef -- ^ The Marlowe-specific output. + -> MarloweData PubKeyHash Token -- ^ The Marlowe data. toMarloweState = tyTxOutData . tyTxOutRefOut toRolePayout :: RolePayoutTxOutRef -- ^ Role payout specific output @@ -429,9 +430,9 @@ txDatums citx = -- | Extract Marlowe input from a transaction. -txInputs :: SlotConfig -- ^ The slot configuration. - -> ChainIndexTx -- ^ The transaction. - -> [(TxOutRef, TransactionInput)] -- ^ The inputs that have Marlowe inputs. +txInputs :: SlotConfig -- ^ The slot configuration. + -> ChainIndexTx -- ^ The transaction. + -> [(TxOutRef, TransactionInput PubKeyHash Token)] -- ^ The inputs that have Marlowe inputs. txInputs slotConfig citx = case slotRangeToPOSIXTimeRange slotConfig $ citx ^. citxValidRange of Interval (LowerBound (Finite l) True) (UpperBound (Finite h) False) -> diff --git a/marlowe/src/Language/Marlowe/Core/V1/Semantics.hs b/marlowe/src/Language/Marlowe/Core/V1/Semantics.hs index 7d2a6d8480..6f6a449f30 100644 --- a/marlowe/src/Language/Marlowe/Core/V1/Semantics.hs +++ b/marlowe/src/Language/Marlowe/Core/V1/Semantics.hs @@ -13,6 +13,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + -- Big hammer, but helps {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -50,16 +52,17 @@ import qualified Data.Foldable as F import Data.Scientific (Scientific) import Data.Text (pack) import Deriving.Aeson -import Language.Marlowe.Core.V1.Semantics.Types (AccountId, Accounts, Action (..), Case (..), Contract (..), +import Language.Marlowe.Core.V1.Semantics.Money (Money) +import qualified Language.Marlowe.Core.V1.Semantics.Money as Money +import Language.Marlowe.Core.V1.Semantics.Types (AccountId, Accounts, Action (..), Case, Case_ (..), Contract (..), Environment (..), Input (..), InputContent (..), IntervalError (..), - IntervalResult (..), Money, Observation (..), Party, Payee (..), - State (..), TimeInterval, Token (..), Value (..), ValueId, emptyState, - getAction, getInputContent, inBounds) + IntervalResult (..), Observation (..), Party, Payee (..), State (..), + TimeInterval, Value, ValueId, Value_ (..), emptyState, getAction, + getInputContent, inBounds) import Language.Marlowe.ParserUtil (getInteger, withInteger) import Language.Marlowe.Pretty (Pretty (..)) import Ledger (POSIXTime (..), ValidatorHash) import Ledger.Value (CurrencySymbol (..)) -import qualified Ledger.Value as Val import PlutusTx (makeIsDataIndexed) import qualified PlutusTx.AssocMap as Map import qualified PlutusTx.Builtins as Builtins @@ -97,69 +100,69 @@ import Text.PrettyPrint.Leijen (comma, hang, lbrace, line, rbrace, space, text, {-| Payment occurs during 'Pay' contract evaluation, and when positive balances are payed out on contract closure. -} -data Payment = Payment AccountId Payee Money +data Payment i t = Payment (AccountId i) (Payee i) (Money t) deriving stock (Haskell.Show) -- | Effect of 'reduceContractStep' computation -data ReduceEffect = ReduceWithPayment Payment - | ReduceNoPayment +data ReduceEffect i t = ReduceWithPayment (Payment i t) + | ReduceNoPayment deriving stock (Haskell.Show) -- | Warning during 'reduceContractStep' -data ReduceWarning = ReduceNoWarning - | ReduceNonPositivePay AccountId Payee Token Integer - | ReducePartialPay AccountId Payee Token Integer Integer --- ^ src ^ dest ^ paid ^ expected - | ReduceShadowing ValueId Integer Integer --- oldVal ^ newVal ^ - | ReduceAssertionFailed +data ReduceWarning i t = ReduceNoWarning + | ReduceNonPositivePay (AccountId i) (Payee i) t Integer + | ReducePartialPay (AccountId i) (Payee i) t Integer Integer +-- ^ src ^ dest ^ paid ^ expected + | ReduceShadowing ValueId Integer Integer +-- oldVal ^ newVal ^ + | ReduceAssertionFailed deriving stock (Haskell.Show) -- | Result of 'reduceContractStep' -data ReduceStepResult = Reduced ReduceWarning ReduceEffect State Contract - | NotReduced - | AmbiguousTimeIntervalReductionError +data ReduceStepResult i t = Reduced (ReduceWarning i t) (ReduceEffect i t) (State i t) (Contract i t) + | NotReduced + | AmbiguousTimeIntervalReductionError deriving stock (Haskell.Show) -- | Result of 'reduceContractUntilQuiescent' -data ReduceResult = ContractQuiescent Bool [ReduceWarning] [Payment] State Contract - | RRAmbiguousTimeIntervalError +data ReduceResult i t = ContractQuiescent Bool [ReduceWarning i t] [Payment i t] (State i t) (Contract i t) + | RRAmbiguousTimeIntervalError deriving stock (Haskell.Show) -- | Warning of 'applyCases' -data ApplyWarning = ApplyNoWarning - | ApplyNonPositiveDeposit Party AccountId Token Integer +data ApplyWarning i t = ApplyNoWarning + | ApplyNonPositiveDeposit (Party i) (AccountId i) t Integer deriving stock (Haskell.Show) -- | Result of 'applyCases' -data ApplyResult = Applied ApplyWarning State Contract - | ApplyNoMatchError - | ApplyHashMismatch +data ApplyResult i t = Applied (ApplyWarning i t) (State i t) (Contract i t) + | ApplyNoMatchError + | ApplyHashMismatch deriving stock (Haskell.Show) -- | Result of 'applyAllInputs' -data ApplyAllResult = ApplyAllSuccess Bool [TransactionWarning] [Payment] State Contract - | ApplyAllNoMatchError - | ApplyAllAmbiguousTimeIntervalError - | ApplyAllHashMismatch +data ApplyAllResult i t = ApplyAllSuccess Bool [TransactionWarning i t] [Payment i t] (State i t) (Contract i t) + | ApplyAllNoMatchError + | ApplyAllAmbiguousTimeIntervalError + | ApplyAllHashMismatch deriving stock (Haskell.Show) -- | Warnings during transaction computation -data TransactionWarning = TransactionNonPositiveDeposit Party AccountId Token Integer - | TransactionNonPositivePay AccountId Payee Token Integer - | TransactionPartialPay AccountId Payee Token Integer Integer --- ^ src ^ dest ^ paid ^ expected - | TransactionShadowing ValueId Integer Integer --- oldVal ^ newVal ^ - | TransactionAssertionFailed +data TransactionWarning i t = TransactionNonPositiveDeposit (Party i) (AccountId i) t Integer + | TransactionNonPositivePay (AccountId i) (Payee i) t Integer + | TransactionPartialPay (AccountId i) (Payee i) t Integer Integer +-- ^ src ^ dest ^ paid ^ expected + | TransactionShadowing ValueId Integer Integer +-- oldVal ^ newVal ^ + | TransactionAssertionFailed deriving stock (Haskell.Show, Generic, Haskell.Eq) deriving anyclass (Pretty) @@ -176,12 +179,12 @@ data TransactionError = TEAmbiguousTimeIntervalError {-| Marlowe transaction input. -} -data TransactionInput = TransactionInput +data TransactionInput i t = TransactionInput { txInterval :: TimeInterval - , txInputs :: [Input] } + , txInputs :: [Input i t] } deriving stock (Haskell.Show, Haskell.Eq) -instance Pretty TransactionInput where +instance (Pretty i, Pretty t) => Pretty (TransactionInput i t) where prettyFragment tInp = text "TransactionInput" <> space <> lbrace <> line <> txIntLine <> line <> txInpLine where txIntLine = hang 2 $ text "txInterval = " <> prettyFragment (txInterval tInp) <> comma @@ -190,12 +193,12 @@ instance Pretty TransactionInput where {-| Marlowe transaction output. -} -data TransactionOutput = +data TransactionOutput i t = TransactionOutput - { txOutWarnings :: [TransactionWarning] - , txOutPayments :: [Payment] - , txOutState :: State - , txOutContract :: Contract } + { txOutWarnings :: [TransactionWarning i t] + , txOutPayments :: [Payment i t] + , txOutState :: State i t + , txOutContract :: Contract i t } | Error TransactionError deriving stock (Haskell.Show) @@ -203,12 +206,13 @@ data TransactionOutput = {-| This data type is a content of a contract's /Datum/ -} -data MarloweData = MarloweData { - marloweState :: State, - marloweContract :: Contract +data MarloweData i t = MarloweData { + marloweState :: State i t, + marloweContract :: Contract i t } deriving stock (Haskell.Show, Haskell.Eq, Generic) - deriving anyclass (ToJSON, FromJSON) +deriving anyclass instance (ToJSON (Party i), ToJSON t) => ToJSON (MarloweData i t) +deriving anyclass instance (FromJSON (Party i), FromJSON t) => FromJSON (MarloweData i t) data MarloweParams = MarloweParams { rolePayoutValidatorHash :: ValidatorHash, @@ -217,9 +221,8 @@ data MarloweParams = MarloweParams { deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (FromJSON,ToJSON) - {- Checks 'interval' and trim it if necessary. -} -fixInterval :: TimeInterval -> State -> IntervalResult +fixInterval :: TimeInterval -> State i t -> IntervalResult i t fixInterval interval state = case interval of (low, high) @@ -239,7 +242,7 @@ fixInterval interval state = {-| Evaluates @Value@ given current @State@ and @Environment@ -} -evalValue :: Environment -> State -> Value Observation -> Integer +evalValue :: (Eq i, Eq t) => Environment -> State i t -> Value i t -> Integer evalValue env state value = let eval = evalValue env state in case value of @@ -284,7 +287,7 @@ evalValue env state value = let -- | Evaluate 'Observation' to 'Bool'. -evalObservation :: Environment -> State -> Observation -> Bool +evalObservation :: (Eq i, Eq t) => Environment -> State i t -> Observation i t -> Bool evalObservation env state obs = let evalObs = evalObservation env state evalVal = evalValue env state @@ -303,31 +306,31 @@ evalObservation env state obs = let -- | Pick the first account with money in it -refundOne :: Accounts -> Maybe ((Party, Money), Accounts) +refundOne :: Accounts i t -> Maybe ((Party i, Money t), Accounts i t) refundOne accounts = case Map.toList accounts of [] -> Nothing - ((accId, Token cur tok), balance) : rest -> + ((accId, t), balance) : rest -> if balance > 0 - then Just ((accId, Val.singleton cur tok balance), Map.fromList rest) + then Just ((accId, Money.singleton t balance), Map.fromList rest) else refundOne (Map.fromList rest) -- | Obtains the amount of money available an account -moneyInAccount :: AccountId -> Token -> Accounts -> Integer +moneyInAccount :: (Eq i, Eq t) => AccountId i -> t -> Accounts i t -> Integer moneyInAccount accId token accounts = case Map.lookup (accId, token) accounts of Just x -> x Nothing -> 0 -- | Sets the amount of money available in an account -updateMoneyInAccount :: AccountId -> Token -> Integer -> Accounts -> Accounts +updateMoneyInAccount :: (Eq i, Eq t) => AccountId i -> t -> Integer -> Accounts i t -> Accounts i t updateMoneyInAccount accId token amount = if amount <= 0 then Map.delete (accId, token) else Map.insert (accId, token) amount -- Add the given amount of money to an accoun (only if it is positive) -- Return the updated Map -addMoneyToAccount :: AccountId -> Token -> Integer -> Accounts -> Accounts +addMoneyToAccount :: (Eq i, Eq t) => AccountId i -> t -> Integer -> Accounts i t -> Accounts i t addMoneyToAccount accId token amount accounts = let balance = moneyInAccount accId token accounts newBalance = balance + amount @@ -338,16 +341,16 @@ addMoneyToAccount accId token amount accounts = let {-| Gives the given amount of money to the given payee. Returns the appropriate effect and updated accounts -} -giveMoney :: AccountId -> Payee -> Token -> Integer -> Accounts -> (ReduceEffect, Accounts) -giveMoney accountId payee (Token cur tok) amount accounts = let +giveMoney :: (Eq i, Eq t) => AccountId i -> Payee i -> t -> Integer -> Accounts i t -> (ReduceEffect i t, Accounts i t) +giveMoney accountId payee t amount accounts = let newAccounts = case payee of Party _ -> accounts - Account accId -> addMoneyToAccount accId (Token cur tok) amount accounts - in (ReduceWithPayment (Payment accountId payee (Val.singleton cur tok amount)), newAccounts) + Account accId -> addMoneyToAccount accId t amount accounts + in (ReduceWithPayment (Payment accountId payee (Money.singleton t amount)), newAccounts) -- | Carry a step of the contract with no inputs -reduceContractStep :: Environment -> State -> Contract -> ReduceStepResult +reduceContractStep :: (Eq i, Eq t) => Environment -> State i t -> Contract i t -> ReduceStepResult i t reduceContractStep env state contract = case contract of Close -> case refundOne (accounts state) of @@ -404,10 +407,10 @@ reduceContractStep env state contract = case contract of in Reduced warning ReduceNoPayment state cont -- | Reduce a contract until it cannot be reduced more -reduceContractUntilQuiescent :: Environment -> State -> Contract -> ReduceResult +reduceContractUntilQuiescent :: forall i t. (Eq i, Eq t) => Environment -> State i t -> Contract i t -> ReduceResult i t reduceContractUntilQuiescent env state contract = let reductionLoop - :: Bool -> Environment -> State -> Contract -> [ReduceWarning] -> [Payment] -> ReduceResult + :: Bool -> Environment -> State i t -> Contract i t -> [ReduceWarning i t] -> [Payment i t] -> ReduceResult i t reductionLoop reduced env state contract warnings payments = case reduceContractStep env state contract of Reduced warning effect newState cont -> let @@ -424,12 +427,12 @@ reduceContractUntilQuiescent env state contract = let in reductionLoop False env state contract [] [] -data ApplyAction = AppliedAction ApplyWarning State - | NotAppliedAction +data ApplyAction i t = AppliedAction (ApplyWarning i t) (State i t) + | NotAppliedAction deriving stock (Haskell.Show) -- | Try to apply a single input content to a single action -applyAction :: Environment -> State -> InputContent -> Action -> ApplyAction +applyAction :: (Eq i, Eq t) => Environment -> State i t -> InputContent i t -> Action i t -> ApplyAction i t applyAction env state (IDeposit accId1 party1 tok1 amount) (Deposit accId2 party2 tok2 val) = if accId1 == accId2 && party1 == party2 && tok1 == tok2 && amount == evalValue env state val then let warning = if amount > 0 then ApplyNoWarning @@ -448,7 +451,7 @@ applyAction env state INotify (Notify obs) applyAction _ _ _ _ = NotAppliedAction -- | Try to get a continuation from a pair of Input and Case -getContinuation :: Input -> Case Contract -> Maybe Contract +getContinuation :: Input i t -> Case i t -> Maybe (Contract i t) getContinuation (NormalInput _) (Case _ continuation) = Just continuation getContinuation (MerkleizedInput _ inputContinuationHash continuation) (MerkleizedCase _ continuationHash) = if inputContinuationHash == continuationHash @@ -456,11 +459,11 @@ getContinuation (MerkleizedInput _ inputContinuationHash continuation) (Merkleiz else Nothing getContinuation _ _ = Nothing -applyCases :: Environment -> State -> Input -> [Case Contract] -> ApplyResult +applyCases :: forall i t. (Eq i, Eq t) => Environment -> State i t -> Input i t -> [Case i t] -> ApplyResult i t applyCases env state input (headCase : tailCase) = - let inputContent = getInputContent input :: InputContent - action = getAction headCase :: Action - maybeContinuation = getContinuation input headCase :: Maybe Contract + let inputContent = getInputContent input :: InputContent i t + action = getAction headCase :: Action i t + maybeContinuation = getContinuation input headCase :: Maybe (Contract i t) in case applyAction env state inputContent action of AppliedAction warning newState -> case maybeContinuation of @@ -470,12 +473,12 @@ applyCases env state input (headCase : tailCase) = applyCases _ _ _ [] = ApplyNoMatchError -- | Apply a single @Input@ to a current contract -applyInput :: Environment -> State -> Input -> Contract -> ApplyResult +applyInput :: (Eq i, Eq t) => Environment -> State i t -> Input i t -> Contract i t -> ApplyResult i t applyInput env state input (When cases _ _) = applyCases env state input cases applyInput _ _ _ _ = ApplyNoMatchError -- | Propagate 'ReduceWarning' to 'TransactionWarning' -convertReduceWarnings :: [ReduceWarning] -> [TransactionWarning] +convertReduceWarnings :: [ReduceWarning i t] -> [TransactionWarning i t] convertReduceWarnings = foldr (\warn acc -> case warn of ReduceNoWarning -> acc ReduceNonPositivePay accId payee tok amount -> @@ -489,17 +492,17 @@ convertReduceWarnings = foldr (\warn acc -> case warn of ) [] -- | Apply a list of Inputs to the contract -applyAllInputs :: Environment -> State -> Contract -> [Input] -> ApplyAllResult +applyAllInputs :: forall i t. (Eq i, Eq t) => Environment -> State i t -> Contract i t -> [Input i t] -> ApplyAllResult i t applyAllInputs env state contract inputs = let applyAllLoop :: Bool -> Environment - -> State - -> Contract - -> [Input] - -> [TransactionWarning] - -> [Payment] - -> ApplyAllResult + -> State i t + -> Contract i t + -> [Input i t] + -> [TransactionWarning i t] + -> [Payment i t] + -> ApplyAllResult i t applyAllLoop contractChanged env state contract inputs warnings payments = case reduceContractUntilQuiescent env state contract of RRAmbiguousTimeIntervalError -> ApplyAllAmbiguousTimeIntervalError @@ -526,19 +529,19 @@ applyAllInputs env state contract inputs = let ApplyHashMismatch -> ApplyAllHashMismatch in applyAllLoop False env state contract inputs [] [] where - convertApplyWarning :: ApplyWarning -> [TransactionWarning] + convertApplyWarning :: ApplyWarning i t -> [TransactionWarning i t] convertApplyWarning warn = case warn of ApplyNoWarning -> [] ApplyNonPositiveDeposit party accId tok amount -> [TransactionNonPositiveDeposit party accId tok amount] -isClose :: Contract -> Bool +isClose :: Contract i t -> Bool isClose Close = True isClose _ = False -- | Try to compute outputs of a transaction given its inputs, a contract, and it's @State@ -computeTransaction :: TransactionInput -> State -> Contract -> TransactionOutput +computeTransaction :: (Eq i, Eq t) => TransactionInput i t -> State i t -> Contract i t -> TransactionOutput i t computeTransaction tx state contract = let inputs = txInputs tx in case fixInterval (txInterval tx) state of @@ -555,7 +558,7 @@ computeTransaction tx state contract = let ApplyAllHashMismatch -> Error TEHashMismatch IntervalError error -> Error (TEIntervalError error) -playTraceAux :: TransactionOutput -> [TransactionInput] -> TransactionOutput +playTraceAux :: (Eq i, Eq t) => TransactionOutput i t -> [TransactionInput i t] -> TransactionOutput i t playTraceAux res [] = res playTraceAux TransactionOutput { txOutWarnings = warnings @@ -574,7 +577,7 @@ playTraceAux TransactionOutput Error _ -> transRes playTraceAux err@(Error _) _ = err -playTrace :: POSIXTime -> Contract -> [TransactionInput] -> TransactionOutput +playTrace :: (Eq i, Eq t) => POSIXTime -> Contract i t -> [TransactionInput i t] -> TransactionOutput i t playTrace minTime c = playTraceAux TransactionOutput { txOutWarnings = [] , txOutPayments = [] @@ -584,7 +587,7 @@ playTrace minTime c = playTraceAux TransactionOutput -- | Calculates an upper bound for the maximum lifespan of a contract (assuming is not merkleized) -contractLifespanUpperBound :: Contract -> POSIXTime +contractLifespanUpperBound :: Contract i t -> POSIXTime contractLifespanUpperBound contract = case contract of Close -> 0 Pay _ _ _ _ cont -> contractLifespanUpperBound cont @@ -597,22 +600,22 @@ contractLifespanUpperBound contract = case contract of Assert _ cont -> contractLifespanUpperBound cont -totalBalance :: Accounts -> Money +totalBalance :: Ord t => Accounts i t -> Money t totalBalance accounts = foldMap - (\((_, Token cur tok), balance) -> Val.singleton cur tok balance) + (\((_, t), balance) -> Money.singleton t balance) (Map.toList accounts) {-| Check that all accounts have positive balance. -} -validateBalances :: State -> Bool +validateBalances :: State i t -> Bool validateBalances State{..} = all (\(_, balance) -> balance > 0) (Map.toList accounts) -- Typeclass instances -instance FromJSON TransactionInput where +instance (FromJSON (Party i), FromJSON t) => FromJSON (TransactionInput i t) where parseJSON (Object v) = TransactionInput <$> (parseTimeInterval =<< (v .: "tx_interval")) <*> ((v .: "tx_inputs") >>= @@ -626,7 +629,7 @@ instance FromJSON TransactionInput where ) parseJSON _ = Haskell.fail "TransactionInput must be an object" -instance ToJSON TransactionInput where +instance (ToJSON (Party i), ToJSON t) => ToJSON (TransactionInput i t) where toJSON (TransactionInput (POSIXTime from, POSIXTime to) txInps) = object [ "tx_interval" .= timeIntervalJSON , "tx_inputs" .= toJSONList (map toJSON txInps) @@ -635,7 +638,7 @@ instance ToJSON TransactionInput where , "to" .= to ] -instance FromJSON TransactionWarning where +instance (FromJSON (Party i), FromJSON t) => FromJSON (TransactionWarning i t) where parseJSON (String "assertion_failed") = return TransactionAssertionFailed parseJSON (Object v) = (TransactionNonPositiveDeposit <$> (v .: "party") @@ -658,7 +661,7 @@ instance FromJSON TransactionWarning where <*> (v .: "is_now_assigned")) parseJSON _ = Haskell.fail "Contract must be either an object or a the string \"close\"" -instance ToJSON TransactionWarning where +instance (ToJSON (Party i), ToJSON t) => ToJSON (TransactionWarning i t) where toJSON (TransactionNonPositiveDeposit party accId tok amount) = object [ "party" .= party , "asked_to_deposit" .= amount @@ -686,12 +689,12 @@ instance ToJSON TransactionWarning where toJSON TransactionAssertionFailed = JSON.String $ pack "assertion_failed" -instance Eq Payment where +instance (Eq i, Ord t) => Eq (Payment i t) where {-# INLINABLE (==) #-} Payment a1 p1 m1 == Payment a2 p2 m2 = a1 == a2 && p1 == p2 && m1 == m2 -instance Eq ReduceWarning where +instance (Eq i, Eq t) => Eq (ReduceWarning i t) where {-# INLINABLE (==) #-} ReduceNoWarning == ReduceNoWarning = True (ReduceNonPositivePay acc1 p1 tn1 a1) == (ReduceNonPositivePay acc2 p2 tn2 a2) = @@ -703,7 +706,7 @@ instance Eq ReduceWarning where _ == _ = False -instance Eq ReduceEffect where +instance (Eq i, Ord t) => Eq (ReduceEffect i t) where {-# INLINABLE (==) #-} ReduceNoPayment == ReduceNoPayment = True ReduceWithPayment p1 == ReduceWithPayment p2 = p1 == p2 diff --git a/marlowe/src/Language/Marlowe/Core/V1/Semantics/Money.hs b/marlowe/src/Language/Marlowe/Core/V1/Semantics/Money.hs new file mode 100644 index 0000000000..004cc2594e --- /dev/null +++ b/marlowe/src/Language/Marlowe/Core/V1/Semantics/Money.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Big hammer, but helps +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +-- | Ledger independent representation of Money +-- +-- Intended for qualified import +-- +-- > import Language.Marlowe.Core.V1.Semantics.Money (Money) +-- > import qualified Language.Marlowe.Core.V1.Semantics.Money as Money +module Language.Marlowe.Core.V1.Semantics.Money ( + Money(..) + , singleton + , toList + ) where + +import PlutusTx.Prelude hiding (toList, zero) +import qualified Prelude as Haskell + +import qualified Data.List as Haskell +import GHC.Generics (Generic) +import PlutusTx.AssocMap (Map) +import PlutusTx.Lift (makeLift) + +import qualified PlutusTx.AssocMap as Map + +{------------------------------------------------------------------------------- + Basic API +-------------------------------------------------------------------------------} + +-- | Ledger-independent representation of money +newtype Money t = Money (Map t Integer) + deriving stock (Haskell.Show,Generic) + +singleton :: t -> Integer -> Money t +{-# INLINEABLE singleton #-} +singleton t v = Money (Map.singleton t v) + +toList :: Money t -> [(t, Integer)] +{-# INLINEABLE toList #-} +toList (Money m) = Map.toList m + +{------------------------------------------------------------------------------- + Haskell Prelude instances + + We jump through a few hoops to make sure that the Haskell instances only + have Haskell superclass constraints. +-------------------------------------------------------------------------------} + +normalizeHaskell :: forall t. Haskell.Ord t => Map t Integer -> Map t Integer +normalizeHaskell = Map.fromList . go . Map.toList + where + go :: [(t, Integer)] -> [(t, Integer)] + go = Haskell.sort . Haskell.filter ((/= 0) . snd) + +instance Haskell.Ord t => Haskell.Eq (Money t) where + Money m == Money m' = normalizeHaskell m Haskell.== normalizeHaskell m' + +instance Haskell.Ord t => Haskell.Semigroup (Money t) where + Money m <> Money m' = Money $ + Map.fromList $ + go (Map.toList $ normalizeHaskell m) + (Map.toList $ normalizeHaskell m') + where + go :: [(t, Integer)] -> [(t, Integer)] -> [(t, Integer)] + go [] ys = ys + go xs [] = xs + go ((x,v):xs) ((y,v'):ys) + | x Haskell.< y = (x,v) : go xs ((y,v'):ys ) + | x Haskell.> y = (y,v') : go ((x,v):xs) ys + | otherwise = (x,v+v') : go xs ys + +instance Haskell.Ord t => Haskell.Monoid (Money t) where + mempty = Money Map.empty + +{------------------------------------------------------------------------------- + Plutus Prelude instances +-------------------------------------------------------------------------------} + +normalizePlutus :: forall t. Ord t => Map t Integer -> Map t Integer +{-# INLINEABLE normalizePlutus #-} +normalizePlutus = Map.fromList . go . Map.toList + where + go :: [(t, Integer)] -> [(t, Integer)] + go = sort . filter ((/= 0) . snd) + +instance Ord t => Eq (Money t) where + {-# INLINEABLE (==) #-} + Money m == Money m' = normalizePlutus m == normalizePlutus m' + +instance Ord t => Semigroup (Money t) where + {-# INLINEABLE (<>) #-} + Money m <> Money m' = Money $ + Map.fromList $ + go (Map.toList $ normalizePlutus m) + (Map.toList $ normalizePlutus m') + where + go :: [(t, Integer)] -> [(t, Integer)] -> [(t, Integer)] + go [] ys = ys + go xs [] = xs + go ((x,v):xs) ((y,v'):ys) + | x < y = (x,v) : go xs ((y,v'):ys ) + | x > y = (y,v') : go ((x,v):xs) ys + | otherwise = (x,v+v') : go xs ys + +instance Ord t => Monoid (Money t) where + {-# INLINEABLE mempty #-} + mempty = Money Map.empty + +makeLift ''Money diff --git a/marlowe/src/Language/Marlowe/Core/V1/Semantics/Token.hs b/marlowe/src/Language/Marlowe/Core/V1/Semantics/Token.hs new file mode 100644 index 0000000000..0924d9acef --- /dev/null +++ b/marlowe/src/Language/Marlowe/Core/V1/Semantics/Token.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Tokens as used on the Cardano blockchain +-- +-- Intended for unqualified import. +module Language.Marlowe.Core.V1.Semantics.Token ( + Token(..) + , moneyToValue + , moneyFromValue + ) where + +import PlutusTx.Prelude hiding ((<$>), (<*>)) +import Prelude ((<$>), (<*>)) +import qualified Prelude as Haskell + +import Data.Aeson.Types hiding (Error, Value) +import Data.Text.Encoding as Text (decodeUtf8, encodeUtf8) +import GHC.Generics +import Language.Marlowe.Core.V1.Semantics.Money +import Language.Marlowe.Pretty (Pretty (..)) +import Ledger (Value) +import Ledger.Value (CurrencySymbol (..), TokenName (..)) +import PlutusTx (makeIsDataIndexed) +import PlutusTx.Lift (makeLift) + +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Extras as JSON +import qualified Ledger.Value as Val +import qualified PlutusTx.AssocMap as Map + +{-| Token - represents a currency or token, it groups + a pair of a currency symbol and token name. +-} +data Token = Token CurrencySymbol TokenName + deriving stock (Generic,Haskell.Eq,Haskell.Ord) + deriving anyclass (Pretty) + +instance Haskell.Show Token where + showsPrec p (Token cs tn) = + Haskell.showParen (p Haskell.>= 11) (Haskell.showString $ "Token \"" Haskell.++ Haskell.show cs Haskell.++ "\" " Haskell.++ Haskell.show tn) + +instance FromJSON Token where + parseJSON = withObject "Token" (\v -> + Token <$> (Val.currencySymbol <$> (JSON.decodeByteString =<< (v .: "currency_symbol"))) + <*> (Val.tokenName . Text.encodeUtf8 <$> (v .: "token_name")) + ) + +instance ToJSON Token where + toJSON (Token currSym tokName) = object + [ "currency_symbol" .= (JSON.String $ JSON.encodeByteString $ fromBuiltin $ unCurrencySymbol currSym) + , "token_name" .= (JSON.String $ Text.decodeUtf8 $ fromBuiltin $ unTokenName tokName) + ] + +instance Eq Token where + {-# INLINABLE (==) #-} + (Token n1 p1) == (Token n2 p2) = (n1, p1) == (n2, p2) + +instance Ord Token where + {-# INLINABLE compare #-} + (Token n1 p1) `compare` (Token n2 p2) = (n1, p1) `compare` (n2, p2) + +moneyToValue :: Money Token -> Value +moneyToValue (Money m) = + mconcat $ map aux $ Map.toList m + where + aux :: (Token, Integer) -> Value + aux (Token symbol name, n) = Val.singleton symbol name n + +moneyFromValue :: Value -> Money Token +moneyFromValue = Money . Map.fromList . map aux . Val.flattenValue + where + aux :: (CurrencySymbol, TokenName, Integer) -> (Token, Integer) + aux (symbol, name, n) = (Token symbol name, n) + +makeLift ''Token +makeIsDataIndexed ''Token [('Token,0)] + diff --git a/marlowe/src/Language/Marlowe/Core/V1/Semantics/Types.hs b/marlowe/src/Language/Marlowe/Core/V1/Semantics/Types.hs index db0ffe069a..45eb065d3f 100644 --- a/marlowe/src/Language/Marlowe/Core/V1/Semantics/Types.hs +++ b/marlowe/src/Language/Marlowe/Core/V1/Semantics/Types.hs @@ -13,6 +13,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} -- Big hammer, but helps {-# OPTIONS_GHC -fno-specialise #-} @@ -39,7 +40,7 @@ import Deriving.Aeson import Language.Marlowe.ParserUtil (getInteger, withInteger) import Language.Marlowe.Pretty (Pretty (..)) import Ledger (POSIXTime (..), PubKeyHash (..)) -import Ledger.Value (CurrencySymbol (..), TokenName (..)) +import Ledger.Value (TokenName (..)) import qualified Ledger.Value as Val import PlutusTx (makeIsDataIndexed) import PlutusTx.AssocMap (Map) @@ -60,11 +61,11 @@ import qualified Prelude as Haskell {-| = Type definitions for Marlowe's seamntics -} -data Party = PK PubKeyHash | Role TokenName +data Party i = PK i | Role TokenName deriving stock (Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (Pretty) -instance Haskell.Show Party where +instance Haskell.Show i => Haskell.Show (Party i) where showsPrec p (PK pk) = Haskell.showParen (p Haskell.>= 11) $ Haskell.showString "PK \"" . Haskell.showsPrec 11 pk . Haskell.showString "\"" @@ -72,31 +73,20 @@ instance Haskell.Show Party where type AccountId = Party type Timeout = POSIXTime -type Money = Val.Value type ChoiceName = BuiltinByteString type ChosenNum = Integer type TimeInterval = (POSIXTime, POSIXTime) -type Accounts = Map (AccountId, Token) Integer +type Accounts i t = Map (AccountId i, t) Integer -- * Data Types {-| Choices – of integers – are identified by ChoiceId which combines a name for the choice with the Party who had made the choice. -} -data ChoiceId = ChoiceId BuiltinByteString Party +data ChoiceId i = ChoiceId BuiltinByteString (Party i) deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (Pretty) -{-| Token - represents a currency or token, it groups - a pair of a currency symbol and token name. --} -data Token = Token CurrencySymbol TokenName - deriving stock (Generic,Haskell.Eq,Haskell.Ord) - deriving anyclass (Pretty) - -instance Haskell.Show Token where - showsPrec p (Token cs tn) = - Haskell.showParen (p Haskell.>= 11) (Haskell.showString $ "Token \"" Haskell.++ Haskell.show cs Haskell.++ "\" " Haskell.++ Haskell.show tn) {-| Values, as defined using Let ar e identified by name, and can be used by 'UseValue' construct. @@ -112,21 +102,22 @@ newtype ValueId = ValueId BuiltinByteString Values can also be scaled, and combined using addition, subtraction, and negation. -} -data Value a = AvailableMoney AccountId Token - | Constant Integer - | NegValue (Value a) - | AddValue (Value a) (Value a) - | SubValue (Value a) (Value a) - | MulValue (Value a) (Value a) - | DivValue (Value a) (Value a) - | ChoiceValue ChoiceId - | TimeIntervalStart - | TimeIntervalEnd - | UseValue ValueId - | Cond a (Value a) (Value a) +data Value_ a i t = AvailableMoney (AccountId i) t + | Constant Integer + | NegValue (Value_ a i t) + | AddValue (Value_ a i t) (Value_ a i t) + | SubValue (Value_ a i t) (Value_ a i t) + | MulValue (Value_ a i t) (Value_ a i t) + | DivValue (Value_ a i t) (Value_ a i t) + | ChoiceValue (ChoiceId i) + | TimeIntervalStart + | TimeIntervalEnd + | UseValue ValueId + | Cond a (Value_ a i t) (Value_ a i t) deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (Pretty) +type Value i t = Value_ (Observation i t) i t {-| Observations are Boolean values derived by comparing values, and can be combined using the standard Boolean operators. @@ -134,17 +125,17 @@ data Value a = AvailableMoney AccountId Token It is also possible to observe whether any choice has been made (for a particular identified choice). -} -data Observation = AndObs Observation Observation - | OrObs Observation Observation - | NotObs Observation - | ChoseSomething ChoiceId - | ValueGE (Value Observation) (Value Observation) - | ValueGT (Value Observation) (Value Observation) - | ValueLT (Value Observation) (Value Observation) - | ValueLE (Value Observation) (Value Observation) - | ValueEQ (Value Observation) (Value Observation) - | TrueObs - | FalseObs +data Observation i t = AndObs (Observation i t) (Observation i t) + | OrObs (Observation i t) (Observation i t) + | NotObs (Observation i t) + | ChoseSomething (ChoiceId i) + | ValueGE (Value i t) (Value i t) + | ValueGT (Value i t) (Value i t) + | ValueLT (Value i t) (Value i t) + | ValueLE (Value i t) (Value i t) + | ValueEQ (Value i t) (Value i t) + | TrueObs + | FalseObs deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (Pretty) @@ -166,9 +157,9 @@ data Bound = Bound Integer Integer Typically this would be done by one of the parties, or one of their wallets acting automatically. -} -data Action = Deposit AccountId Party Token (Value Observation) - | Choice ChoiceId [Bound] - | Notify Observation +data Action i t = Deposit (AccountId i) (Party i) t (Value i t) + | Choice (ChoiceId i) [Bound] + | Notify (Observation i t) deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (Pretty) @@ -177,8 +168,8 @@ data Action = Deposit AccountId Party Token (Value Observation) or to one of the accounts of the contract, and this is reflected in the definition. -} -data Payee = Account AccountId - | Party Party +data Payee i = Account (AccountId i) + | Party (Party i) deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (Pretty) @@ -186,12 +177,14 @@ data Payee = Account AccountId {- Plutus doesn't support mutually recursive data types yet. datatype Case is mutually recurvive with @Contract@ -} -data Case a = Case Action a - | MerkleizedCase Action BuiltinByteString +data Case_ a i t = Case (Action i t) a + | MerkleizedCase (Action i t) BuiltinByteString deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (Pretty) -getAction :: Case a -> Action +type Case i t = Case_ (Contract i t) i t + +getAction :: Case i t -> Action i t getAction (Case action _) = action getAction (MerkleizedCase action _) = action @@ -202,21 +195,21 @@ getAction (MerkleizedCase action _) = action At each step of execution, as well as returning a new state and continuation contract, it is possible that effects – payments – and warnings can be generated too. -} -data Contract = Close - | Pay AccountId Payee Token (Value Observation) Contract - | If Observation Contract Contract - | When [Case Contract] Timeout Contract - | Let ValueId (Value Observation) Contract - | Assert Observation Contract +data Contract i t = Close + | Pay (AccountId i) (Payee i) t (Value i t) (Contract i t) + | If (Observation i t) (Contract i t) (Contract i t) + | When [Case i t] Timeout (Contract i t) + | Let ValueId (Value i t) (Contract i t) + | Assert (Observation i t) (Contract i t) deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord) deriving anyclass (Pretty) {-| Marlowe contract internal state. Stored in a /Datum/ of a transaction output. -} -data State = State { accounts :: Accounts - , choices :: Map ChoiceId ChosenNum - , boundValues :: Map ValueId Integer - , minTime :: POSIXTime } +data State i t = State { accounts :: Accounts i t + , choices :: Map (ChoiceId i) ChosenNum + , boundValues :: Map ValueId Integer + , minTime :: POSIXTime } deriving stock (Haskell.Show,Haskell.Eq,Generic) {-| Execution environment. Contains a time interval of a transaction. @@ -227,13 +220,13 @@ newtype Environment = Environment { timeInterval :: TimeInterval } {-| Input for a Marlowe contract. Correspond to expected 'Action's. -} -data InputContent = IDeposit AccountId Party Token Integer - | IChoice ChoiceId ChosenNum - | INotify +data InputContent i t = IDeposit (AccountId i) (Party i) t Integer + | IChoice (ChoiceId i) ChosenNum + | INotify deriving stock (Haskell.Show,Haskell.Eq,Generic) deriving anyclass (Pretty) -instance FromJSON InputContent where +instance (FromJSON (Party i), FromJSON t) => FromJSON (InputContent i t) where parseJSON (String "input_notify") = return INotify parseJSON (Object v) = IChoice <$> v .: "for_choice_id" @@ -244,7 +237,7 @@ instance FromJSON InputContent where <*> v .: "that_deposits" parseJSON _ = Haskell.fail "Input must be either an object or the string \"input_notify\"" -instance ToJSON InputContent where +instance (ToJSON (Party i), ToJSON t) => ToJSON (InputContent i t) where toJSON (IDeposit accId party tok amount) = object [ "input_from_party" .= party , "that_deposits" .= amount @@ -257,12 +250,12 @@ instance ToJSON InputContent where ] toJSON INotify = JSON.String $ pack "input_notify" -data Input = NormalInput InputContent - | MerkleizedInput InputContent BuiltinByteString Contract +data Input i t = NormalInput (InputContent i t) + | MerkleizedInput (InputContent i t) BuiltinByteString (Contract i t) deriving stock (Haskell.Show,Haskell.Eq,Generic) deriving anyclass (Pretty) -instance FromJSON Input where +instance (FromJSON (Party i), FromJSON t) => FromJSON (Input i t) where parseJSON (String s) = NormalInput <$> parseJSON (String s) parseJSON (Object v) = do MerkleizedInput <$> parseJSON (Object v) <*> v .: "continuation_hash" <*> v .: "merkleized_continuation" @@ -270,7 +263,7 @@ instance FromJSON Input where <|> NormalInput <$> parseJSON (Object v) parseJSON _ = Haskell.fail "Input must be either an object or the string \"input_notify\"" -instance ToJSON Input where +instance (ToJSON (Party i), ToJSON t) => ToJSON (Input i t) where toJSON (NormalInput content) = toJSON content toJSON (MerkleizedInput content hash continuation) = let @@ -284,7 +277,7 @@ instance ToJSON Input where ] -getInputContent :: Input -> InputContent +getInputContent :: Input i t -> InputContent i t getInputContent (NormalInput inputContent) = inputContent getInputContent (MerkleizedInput inputContent _ _) = inputContent @@ -301,13 +294,13 @@ data IntervalError = InvalidInterval TimeInterval -- | Result of 'fixInterval' -data IntervalResult = IntervalTrimmed Environment State - | IntervalError IntervalError +data IntervalResult i t = IntervalTrimmed Environment (State i t) + | IntervalError IntervalError deriving stock (Haskell.Show) -- | Empty State for a given minimal 'POSIXTime' -emptyState :: POSIXTime -> State +emptyState :: POSIXTime -> State i t emptyState sn = State { accounts = Map.empty , choices = Map.empty @@ -320,7 +313,7 @@ inBounds :: ChosenNum -> [Bound] -> Bool inBounds num = any (\(Bound l u) -> num >= l && num <= u) -instance FromJSON State where +instance (FromJSON (Party i), FromJSON t) => FromJSON (State i t) where parseJSON = withObject "State" (\v -> State <$> (v .: "accounts") <*> (v .: "choices") @@ -328,7 +321,7 @@ instance FromJSON State where <*> (POSIXTime <$> (withInteger =<< (v .: "minTime"))) ) -instance ToJSON State where +instance (ToJSON (Party i), ToJSON t) => ToJSON (State i t) where toJSON State { accounts = a , choices = c , boundValues = bv @@ -338,49 +331,39 @@ instance ToJSON State where , "boundValues" .= bv , "minTime" .= ms ] -instance FromJSON Party where +instance FromJSON (Party PubKeyHash) where parseJSON = withObject "Party" (\v -> (PK . PubKeyHash . toBuiltin <$> (JSON.decodeByteString =<< (v .: "pk_hash"))) <|> (Role . Val.tokenName . Text.encodeUtf8 <$> (v .: "role_token")) ) -instance ToJSON Party where + +-- | ToJSON instance for 'Party' refers specifically to @pk_hash@ so not generalized +instance ToJSON (Party PubKeyHash) where toJSON (PK pkh) = object [ "pk_hash" .= (JSON.String $ JSON.encodeByteString $ fromBuiltin $ getPubKeyHash pkh) ] toJSON (Role (Val.TokenName name)) = object [ "role_token" .= (JSON.String $ Text.decodeUtf8 $ fromBuiltin name) ] -instance FromJSON ChoiceId where +instance FromJSON (Party i) => FromJSON (ChoiceId i) where parseJSON = withObject "ChoiceId" (\v -> ChoiceId <$> (toBuiltin . Text.encodeUtf8 <$> (v .: "choice_name")) <*> (v .: "choice_owner") ) -instance ToJSON ChoiceId where +instance ToJSON (Party i) => ToJSON (ChoiceId i) where toJSON (ChoiceId name party) = object [ "choice_name" .= (JSON.String $ Text.decodeUtf8 $ fromBuiltin name) , "choice_owner" .= party ] -instance FromJSON Token where - parseJSON = withObject "Token" (\v -> - Token <$> (Val.currencySymbol <$> (JSON.decodeByteString =<< (v .: "currency_symbol"))) - <*> (Val.tokenName . Text.encodeUtf8 <$> (v .: "token_name")) - ) - -instance ToJSON Token where - toJSON (Token currSym tokName) = object - [ "currency_symbol" .= (JSON.String $ JSON.encodeByteString $ fromBuiltin $ unCurrencySymbol currSym) - , "token_name" .= (JSON.String $ Text.decodeUtf8 $ fromBuiltin $ unTokenName tokName) - ] - instance FromJSON ValueId where parseJSON = withText "ValueId" $ return . ValueId . toBuiltin . Text.encodeUtf8 instance ToJSON ValueId where toJSON (ValueId x) = JSON.String (Text.decodeUtf8 $ fromBuiltin x) -instance FromJSON (Value Observation) where +instance (FromJSON (Party i), FromJSON t) => FromJSON (Value i t) where parseJSON (Object v) = (AvailableMoney <$> (v .: "in_account") <*> (v .: "amount_of_token")) @@ -401,7 +384,8 @@ instance FromJSON (Value Observation) where parseJSON (String "time_interval_end") = return TimeIntervalEnd parseJSON (Number n) = Constant <$> getInteger n parseJSON _ = Haskell.fail "Value must be either an object or an integer" -instance ToJSON (Value Observation) where + +instance (ToJSON (Party i), ToJSON t) => ToJSON (Value i t) where toJSON (AvailableMoney accountId token) = object [ "amount_of_token" .= token , "in_account" .= accountId @@ -438,7 +422,7 @@ instance ToJSON (Value Observation) where ] -instance FromJSON Observation where +instance (FromJSON (Party i), FromJSON t) => FromJSON (Observation i t) where parseJSON (Bool True) = return TrueObs parseJSON (Bool False) = return FalseObs parseJSON (Object v) = @@ -460,7 +444,7 @@ instance FromJSON Observation where <*> (v .: "equal_to")) parseJSON _ = Haskell.fail "Observation must be either an object or a boolean" -instance ToJSON Observation where +instance (ToJSON (Party i), ToJSON t) => ToJSON (Observation i t) where toJSON (AndObs lhs rhs) = object [ "both" .= lhs , "and" .= rhs @@ -508,7 +492,7 @@ instance ToJSON Bound where , "to" .= to ] -instance FromJSON Action where +instance (FromJSON (Party i), FromJSON t) => FromJSON (Action i t) where parseJSON = withObject "Action" (\v -> (Deposit <$> (v .: "into_account") <*> (v .: "party") @@ -521,7 +505,7 @@ instance FromJSON Action where ))) <|> (Notify <$> (v .: "notify_if")) ) -instance ToJSON Action where +instance (ToJSON (Party i), ToJSON t) => ToJSON (Action i t) where toJSON (Deposit accountId party token val) = object [ "into_account" .= accountId , "party" .= party @@ -536,24 +520,24 @@ instance ToJSON Action where [ "notify_if" .= obs ] -instance FromJSON Payee where +instance FromJSON (Party i) => FromJSON (Payee i) where parseJSON = withObject "Payee" (\v -> (Account <$> (v .: "account")) <|> (Party <$> (v .: "party"))) -instance ToJSON Payee where +instance ToJSON (Party i) => ToJSON (Payee i) where toJSON (Account acc) = object ["account" .= acc] toJSON (Party party) = object ["party" .= party] -instance FromJSON a => FromJSON (Case a) where +instance (FromJSON (Party i), FromJSON t) => FromJSON (Case i t) where parseJSON = withObject "Case" (\v -> (Case <$> (v .: "case") <*> (v .: "then")) <|> (MerkleizedCase <$> (v .: "case") <*> (toBuiltin <$> (JSON.decodeByteString =<< v .: "merkleized_then"))) ) -instance ToJSON a => ToJSON (Case a) where +instance (ToJSON (Party i), ToJSON t) => ToJSON (Case i t) where toJSON (Case act cont) = object [ "case" .= act , "then" .= cont @@ -564,7 +548,7 @@ instance ToJSON a => ToJSON (Case a) where ] -instance FromJSON Contract where +instance (FromJSON (Party i), FromJSON t) => FromJSON (Contract i t) where parseJSON (String "close") = return Close parseJSON (Object v) = (Pay <$> (v .: "from_account") @@ -588,7 +572,7 @@ instance FromJSON Contract where <*> (v .: "then")) parseJSON _ = Haskell.fail "Contract must be either an object or a the string \"close\"" -instance ToJSON Contract where +instance (ToJSON (Party i), ToJSON t) => ToJSON (Contract i t) where toJSON Close = JSON.String $ pack "close" toJSON (Pay accountId payee token value contract) = object [ "from_account" .= accountId @@ -617,22 +601,17 @@ instance ToJSON Contract where , "then" .= cont ] - -instance Eq Party where +instance Eq i => Eq (Party i) where {-# INLINABLE (==) #-} (PK p1) == (PK p2) = p1 == p2 (Role r1) == (Role r2) = r1 == r2 _ == _ = False -instance Eq ChoiceId where +instance Eq i => Eq (ChoiceId i) where {-# INLINABLE (==) #-} (ChoiceId n1 p1) == (ChoiceId n2 p2) = n1 == n2 && p1 == p2 -instance Eq Token where - {-# INLINABLE (==) #-} - (Token n1 p1) == (Token n2 p2) = n1 == n2 && p1 == p2 - instance Eq ValueId where {-# INLINABLE (==) #-} (ValueId n1) == (ValueId n2) = n1 == n2 @@ -641,13 +620,13 @@ instance Eq ValueId where instance Pretty ValueId where prettyFragment (ValueId n) = prettyFragment n -instance Eq Payee where +instance Eq i => Eq (Payee i) where {-# INLINABLE (==) #-} Account acc1 == Account acc2 = acc1 == acc2 Party p1 == Party p2 = p1 == p2 _ == _ = False -instance Eq a => Eq (Value a) where +instance (Eq i, Eq t) => Eq (Value i t) where {-# INLINABLE (==) #-} AvailableMoney acc1 tok1 == AvailableMoney acc2 tok2 = acc1 == acc2 && tok1 == tok2 @@ -664,7 +643,7 @@ instance Eq a => Eq (Value a) where Cond obs1 thn1 els1 == Cond obs2 thn2 els2 = obs1 == obs2 && thn1 == thn2 && els1 == els2 _ == _ = False -instance Eq Observation where +instance (Eq i, Eq t) => Eq (Observation i t) where {-# INLINABLE (==) #-} AndObs o1l o2l == AndObs o1r o2r = o1l == o1r && o2l == o2r OrObs o1l o2l == OrObs o1r o2r = o1l == o1r && o2l == o2r @@ -679,7 +658,7 @@ instance Eq Observation where FalseObs == FalseObs = True _ == _ = False -instance Eq Action where +instance (Eq i, Eq t) => Eq (Action i t) where {-# INLINABLE (==) #-} Deposit acc1 party1 tok1 val1 == Deposit acc2 party2 tok2 val2 = acc1 == acc2 && party1 == party2 && tok1 == tok2 && val1 == val2 @@ -691,13 +670,13 @@ instance Eq Action where Notify obs1 == Notify obs2 = obs1 == obs2 _ == _ = False -instance Eq a => Eq (Case a) where +instance (Eq i, Eq t) => Eq (Case i t) where {-# INLINABLE (==) #-} Case acl cl == Case acr cr = acl == acr && cl == cr MerkleizedCase acl bsl == MerkleizedCase acr bsr = acl == acr && bsl == bsr _ == _ = False -instance Eq Contract where +instance (Eq i, Eq t) => Eq (Contract i t) where {-# INLINABLE (==) #-} Close == Close = True Pay acc1 payee1 tok1 value1 cont1 == Pay acc2 payee2 tok2 value2 cont2 = @@ -713,7 +692,7 @@ instance Eq Contract where Assert obs1 cont1 == Assert obs2 cont2 = obs1 == obs2 && cont1 == cont2 _ == _ = False -instance Eq State where +instance (Eq i, Eq t) => Eq (State i t) where {-# INLINABLE (==) #-} l == r = minTime l == minTime r && accounts l == accounts r @@ -725,12 +704,10 @@ makeLift ''Party makeIsDataIndexed ''Party [('PK,0),('Role,1)] makeLift ''ChoiceId makeIsDataIndexed ''ChoiceId [('ChoiceId,0)] -makeLift ''Token -makeIsDataIndexed ''Token [('Token,0)] makeLift ''ValueId makeIsDataIndexed ''ValueId [('ValueId,0)] -makeLift ''Value -makeIsDataIndexed ''Value [ +makeLift ''Value_ +makeIsDataIndexed ''Value_ [ ('AvailableMoney,0), ('Constant,1), ('NegValue,2), @@ -762,8 +739,8 @@ makeLift ''Bound makeIsDataIndexed ''Bound [('Bound,0)] makeLift ''Action makeIsDataIndexed ''Action [('Deposit,0),('Choice,1),('Notify,2)] -makeLift ''Case -makeIsDataIndexed ''Case [('Case,0),('MerkleizedCase,1)] +makeLift ''Case_ +makeIsDataIndexed ''Case_ [('Case,0),('MerkleizedCase,1)] makeLift ''Payee makeIsDataIndexed ''Payee [('Account,0),('Party,1)] makeLift ''Contract diff --git a/marlowe/src/Language/Marlowe/Extended/V1.hs b/marlowe/src/Language/Marlowe/Extended/V1.hs index 9ddbd55686..134064701b 100644 --- a/marlowe/src/Language/Marlowe/Extended/V1.hs +++ b/marlowe/src/Language/Marlowe/Extended/V1.hs @@ -18,8 +18,8 @@ in different situations without cluttering the code that goes on-chain module Language.Marlowe.Extended.V1 ( module Language.Marlowe.Extended.V1 , module Language.Marlowe.Pretty , ada, adaSymbol, adaToken - , S.AccountId, S.Bound(..), S.ChoiceId(..) - , S.ChoiceName, S.ChosenNum, S.Party(..) + , S.Bound(..) + , S.ChoiceName, S.ChosenNum , S.TimeInterval, S.Token(..), S.ValueId(..) , ToCore (..) , (%) @@ -27,18 +27,24 @@ module Language.Marlowe.Extended.V1 ( module Language.Marlowe.Extended.V1 import Control.Applicative ((<|>)) import qualified Data.Aeson as JSON +import qualified Data.Aeson.Extras as JSON import Data.Aeson.Types hiding (Error, Value) import Data.ByteString.Lazy.Char8 as C (putStr) import qualified Data.Foldable as F import Data.Ratio ((%)) import Data.Text (pack) +import qualified Data.Text.Encoding as Text import GHC.Generics +import qualified Language.Marlowe.Core.V1.Semantics.Token as S import qualified Language.Marlowe.Core.V1.Semantics.Types as S import Language.Marlowe.ParserUtil (getInteger, withInteger) import Language.Marlowe.Pretty (Pretty (..), pretty) import Language.Marlowe.Util (ada) +import Ledger (PubKeyHash (..), TokenName) import qualified Ledger as L (POSIXTime (..)) import Ledger.Ada (adaSymbol, adaToken) +import qualified Ledger.Value as Val +import PlutusTx.Prelude (BuiltinByteString, fromBuiltin, toBuiltin) import Text.PrettyPrint.Leijen (parens, text) @@ -68,7 +74,17 @@ instance Num Timeout where instance Pretty Rational where prettyFragment r = text $ "(" ++ show r ++ ")" -data Value = AvailableMoney S.AccountId S.Token +type AccountId = Party + +data Party = PK PubKeyHash | Role TokenName + deriving stock (Show,Generic) + deriving anyclass (Pretty) + +data ChoiceId = ChoiceId BuiltinByteString Party + deriving stock (Show,Generic) + deriving anyclass (Pretty) + +data Value = AvailableMoney AccountId S.Token | Constant Integer | ConstantParam String | NegValue Value @@ -76,7 +92,7 @@ data Value = AvailableMoney S.AccountId S.Token | SubValue Value Value | MulValue Value Value | DivValue Value Value - | ChoiceValue S.ChoiceId + | ChoiceValue ChoiceId | TimeIntervalStart | TimeIntervalEnd | UseValue S.ValueId @@ -87,7 +103,7 @@ data Value = AvailableMoney S.AccountId S.Token data Observation = AndObs Observation Observation | OrObs Observation Observation | NotObs Observation - | ChoseSomething S.ChoiceId + | ChoseSomething ChoiceId | ValueGE Value Value | ValueGT Value Value | ValueLT Value Value @@ -98,14 +114,14 @@ data Observation = AndObs Observation Observation deriving stock (Show,Generic) deriving anyclass (Pretty) -data Action = Deposit S.AccountId S.Party S.Token Value - | Choice S.ChoiceId [S.Bound] +data Action = Deposit AccountId Party S.Token Value + | Choice ChoiceId [S.Bound] | Notify Observation deriving stock (Show,Generic) deriving anyclass (Pretty) -data Payee = Account S.AccountId - | Party S.Party +data Payee = Account AccountId + | Party Party deriving stock (Show,Generic) deriving anyclass (Pretty) @@ -114,7 +130,7 @@ data Case = Case Action Contract deriving anyclass (Pretty) data Contract = Close - | Pay S.AccountId Payee S.Token Value Contract + | Pay AccountId Payee S.Token Value Contract | If Observation Contract Contract | When [Case] Timeout Contract | Let S.ValueId Value Contract @@ -125,34 +141,38 @@ data Contract = Close class ToCore a b where toCore :: a -> Maybe b -instance ToCore Contract S.Contract where - toCore Close = Just S.Close - toCore (Pay accId payee tok val cont) = pure (S.Pay accId) <*> toCore payee <*> pure tok <*> toCore val <*> toCore cont - toCore (If obs cont1 cont2) = S.If <$> toCore obs <*> toCore cont1 <*> toCore cont2 - toCore (When cases tim cont) = S.When <$> traverse toCore cases <*> toCore tim <*> toCore cont - toCore (Let varId val cont) = pure (S.Let varId) <*> toCore val <*> toCore cont - toCore (Assert obs cont) = S.Assert <$> toCore obs <*> toCore cont +-- | Injection for types where this is total +class ToCore' a b where + toCore' :: a -> b -instance ToCore Value (S.Value S.Observation) where +instance ToCore Contract (S.Contract PubKeyHash S.Token) where + toCore Close = Just S.Close + toCore (Pay accId payee tok val cont) = S.Pay (toCore' accId) (toCore' payee) tok <$> toCore val <*> toCore cont + toCore (If obs cont1 cont2) = S.If <$> toCore obs <*> toCore cont1 <*> toCore cont2 + toCore (When cases tim cont) = S.When <$> traverse toCore cases <*> toCore tim <*> toCore cont + toCore (Let varId val cont) = pure (S.Let varId) <*> toCore val <*> toCore cont + toCore (Assert obs cont) = S.Assert <$> toCore obs <*> toCore cont + +instance ToCore Value (S.Value PubKeyHash S.Token) where toCore (Constant c) = Just $ S.Constant c toCore (ConstantParam _) = Nothing - toCore (AvailableMoney accId tok) = Just $ S.AvailableMoney accId tok + toCore (AvailableMoney accId tok) = Just $ S.AvailableMoney (toCore' accId) tok toCore (NegValue v) = S.NegValue <$> toCore v toCore (AddValue lhs rhs) = S.AddValue <$> toCore lhs <*> toCore rhs toCore (SubValue lhs rhs) = S.SubValue <$> toCore lhs <*> toCore rhs toCore (MulValue lhs rhs) = S.MulValue <$> toCore lhs <*> toCore rhs toCore (DivValue lhs rhs) = S.DivValue <$> toCore lhs <*> toCore rhs - toCore (ChoiceValue choId) = Just $ S.ChoiceValue choId + toCore (ChoiceValue choId) = Just $ S.ChoiceValue (toCore' choId) toCore TimeIntervalStart = Just S.TimeIntervalStart toCore TimeIntervalEnd = Just S.TimeIntervalEnd toCore (UseValue vId) = Just $ S.UseValue vId toCore (Cond obs lhs rhs) = S.Cond <$> toCore obs <*> toCore lhs <*> toCore rhs -instance ToCore Observation S.Observation where +instance ToCore Observation (S.Observation PubKeyHash S.Token) where toCore (AndObs lhs rhs) = S.AndObs <$> toCore lhs <*> toCore rhs toCore (OrObs lhs rhs) = S.OrObs <$> toCore lhs <*> toCore rhs toCore (NotObs v) = S.NotObs <$> toCore v - toCore (ChoseSomething choId) = Just $ S.ChoseSomething choId + toCore (ChoseSomething choId) = Just $ S.ChoseSomething (toCore' choId) toCore (ValueGE lhs rhs) = S.ValueGE <$> toCore lhs <*> toCore rhs toCore (ValueGT lhs rhs) = S.ValueGT <$> toCore lhs <*> toCore rhs toCore (ValueLT lhs rhs) = S.ValueLT <$> toCore lhs <*> toCore rhs @@ -161,20 +181,27 @@ instance ToCore Observation S.Observation where toCore TrueObs = Just S.TrueObs toCore FalseObs = Just S.FalseObs -instance ToCore Action S.Action where - toCore (Deposit accId party tok val) = pure (S.Deposit accId party tok) <*> toCore val - toCore (Choice choId bounds) = Just $ S.Choice choId bounds +instance ToCore Action (S.Action PubKeyHash S.Token) where + toCore (Deposit accId party tok val) = S.Deposit (toCore' accId) (toCore' party) tok <$> toCore val + toCore (Choice choId bounds) = Just $ S.Choice (toCore' choId) bounds toCore (Notify obs) = S.Notify <$> toCore obs instance ToCore Timeout L.POSIXTime where toCore (TimeParam _) = Nothing toCore (POSIXTime x) = Just (L.POSIXTime x) -instance ToCore Payee S.Payee where - toCore (Account accId) = Just $ S.Account accId - toCore (Party roleName) = Just $ S.Party roleName +instance ToCore' Party (S.Party PubKeyHash) where + toCore' (PK pk) = S.PK pk + toCore' (Role name) = S.Role name + +instance ToCore' ChoiceId (S.ChoiceId PubKeyHash) where + toCore' (ChoiceId bs party) = S.ChoiceId bs $ toCore' party + +instance ToCore' Payee (S.Payee PubKeyHash) where + toCore' (Account accId) = S.Account (toCore' accId) + toCore' (Party roleName) = S.Party (toCore' roleName) -instance ToCore Case (S.Case S.Contract) where +instance ToCore Case (S.Case PubKeyHash S.Token) where toCore (Case act c) = S.Case <$> toCore act <*> toCore c instance FromJSON Value where @@ -199,6 +226,7 @@ instance FromJSON Value where parseJSON (String "time_interval_end") = return TimeIntervalEnd parseJSON (Number n) = Constant <$> getInteger n parseJSON _ = fail "Value must be either an object or an integer" + instance ToJSON Value where toJSON (AvailableMoney accountId token) = object [ "amount_of_token" .= token @@ -237,7 +265,6 @@ instance ToJSON Value where , "else" .= ev ] - instance FromJSON Observation where parseJSON (Bool True) = return TrueObs parseJSON (Bool False) = return FalseObs @@ -333,6 +360,27 @@ instance ToJSON Case where , "then" .= cont ] +instance FromJSON Party where + parseJSON = withObject "Party" (\v -> + (PK . PubKeyHash . toBuiltin <$> (JSON.decodeByteString =<< (v .: "pk_hash"))) + <|> (Role . Val.tokenName . Text.encodeUtf8 <$> (v .: "role_token")) + ) +instance ToJSON Party where + toJSON (PK pkh) = object + [ "pk_hash" .= (JSON.String $ JSON.encodeByteString $ fromBuiltin $ getPubKeyHash pkh) ] + toJSON (Role (Val.TokenName name)) = object + [ "role_token" .= (JSON.String $ Text.decodeUtf8 $ fromBuiltin name) ] + +instance FromJSON ChoiceId where + parseJSON = withObject "ChoiceId" (\v -> + ChoiceId <$> (toBuiltin . Text.encodeUtf8 <$> (v .: "choice_name")) + <*> (v .: "choice_owner") + ) +instance ToJSON ChoiceId where + toJSON (ChoiceId name party) = object [ "choice_name" .= (JSON.String $ Text.decodeUtf8 $ fromBuiltin name) + , "choice_owner" .= party + ] + instance FromJSON Payee where parseJSON = withObject "Payee" (\v -> (Account <$> (v .: "account")) diff --git a/marlowe/src/Language/Marlowe/FindInputs.hs b/marlowe/src/Language/Marlowe/FindInputs.hs index 4f13963c94..48cfd0ceb2 100644 --- a/marlowe/src/Language/Marlowe/FindInputs.hs +++ b/marlowe/src/Language/Marlowe/FindInputs.hs @@ -5,13 +5,14 @@ import Data.Maybe (catMaybes) import Data.SBV (ThmResult) import Language.Marlowe.Analysis.FSSemantics (onlyAssertionsWithState) import Language.Marlowe.Core.V1.Semantics (TransactionInput) -import Language.Marlowe.Core.V1.Semantics.Types (Case (..), Contract (..), Observation (..)) +import Language.Marlowe.Core.V1.Semantics.Types (Case, Case_ (..), Contract (..), Observation (..)) import Plutus.V1.Ledger.Api (POSIXTime) +import qualified PlutusTx.Prelude as P -- | Removes all the assertions from a contract -removeAsserts :: Contract -> Contract +removeAsserts :: Contract i t -> Contract i t removeAsserts = go - where go :: Contract -> Contract + where go :: Contract i t -> Contract i t go Close = Close go (Pay pa pa' to va con) = Pay pa pa' to va (go con) go (If ob con con') = If ob (go con) (go con') @@ -19,21 +20,21 @@ removeAsserts = go go (Let vi va con) = Let vi va (go con) go (Assert _ con) = con - goCase :: Case Contract -> Case Contract + goCase :: Case i t -> Case i t goCase (Case ac con) = Case ac (go con) goCase mc@(MerkleizedCase _ _) = mc -expandCase :: Case Contract -> [Case Contract] +expandCase :: Case i t -> [Case i t] expandCase (Case ac con) = [Case ac c | c <- expandContract con] expandCase (MerkleizedCase _ _) = [] -expandCases :: [Case Contract] -> [[Case Contract]] +expandCases :: [Case i t] -> [[Case i t]] expandCases [] = [] expandCases (firstCase:restOfCases) = [c:restOfCases | c <- expandCase firstCase] ++ [firstCase:ec | ec <- expandCases restOfCases] -expandContract :: Contract -> [Contract] +expandContract :: Contract i t -> [Contract i t] expandContract Close = [Assert FalseObs Close] expandContract (Pay pa pa' to va con) = [Pay pa pa' to va c | c <- expandContract con] expandContract (If ob con con') = [If ob c con' | c <- expandContract con] @@ -43,13 +44,13 @@ expandContract (When cas sl con) = [When cas sl c | c <- expandContract con] expandContract (Let vi va con) = [Let vi va c | c <- expandContract con] expandContract (Assert _ con) = expandContract con -getInputs :: Contract -> IO (Either (ThmResult, Contract) (Maybe (POSIXTime, [TransactionInput]))) +getInputs :: (P.Eq i, P.Eq t, Ord i, Ord t) => Contract i t -> IO (Either (ThmResult, Contract i t) (Maybe (POSIXTime, [TransactionInput i t]))) getInputs c = bimap (\tr -> (tr, c)) (fmap (\(s, t, _) -> (s, t))) <$> onlyAssertionsWithState c Nothing -- | Uses static analysis to obtain a list of "unit tests" (lists of transactions) that -- | cover the different branches of the given contract. If static analysis fails -- | it returns a tuple that includes the error by the solver and the offending -- | extension of the contract -getAllInputs :: Contract -> IO (Either (ThmResult, Contract) [(POSIXTime, [TransactionInput])]) +getAllInputs :: (P.Eq i, P.Eq t, Ord i, Ord t) => Contract i t -> IO (Either (ThmResult, Contract i t) [(POSIXTime, [TransactionInput i t])]) getAllInputs c = second catMaybes . sequence <$> mapM getInputs (expandContract (removeAsserts c)) diff --git a/marlowe/src/Language/Marlowe/Scripts.hs b/marlowe/src/Language/Marlowe/Scripts.hs index 324e6ca2f9..6d4b64efe4 100644 --- a/marlowe/src/Language/Marlowe/Scripts.hs +++ b/marlowe/src/Language/Marlowe/Scripts.hs @@ -18,6 +18,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} @@ -29,6 +30,7 @@ module Language.Marlowe.Scripts where import GHC.Generics import Language.Marlowe.Core.V1.Semantics +import Language.Marlowe.Core.V1.Semantics.Token import Language.Marlowe.Core.V1.Semantics.Types import Language.Marlowe.Pretty (Pretty (..)) import Ledger @@ -45,7 +47,7 @@ import qualified Prelude as Haskell import Unsafe.Coerce type MarloweTimeRange = (POSIXTime, POSIXTime) -type MarloweInput = [MarloweTxInput] +type MarloweInput i t = [MarloweTxInput i t] -- Yeah, I know type SmallUntypedTypedValidator = Scripts.TypedValidator Scripts.Any @@ -55,8 +57,8 @@ data TypedMarloweValidator {- Type instances for small typed Marlowe validator -} instance Scripts.ValidatorTypes TypedMarloweValidator where - type instance RedeemerType TypedMarloweValidator = MarloweInput - type instance DatumType TypedMarloweValidator = MarloweData + type instance RedeemerType TypedMarloweValidator = MarloweInput PubKeyHash Token + type instance DatumType TypedMarloweValidator = MarloweData PubKeyHash Token data TypedRolePayoutValidator @@ -65,8 +67,8 @@ instance Scripts.ValidatorTypes TypedRolePayoutValidator where type instance DatumType TypedRolePayoutValidator = TokenName -data MarloweTxInput = Input InputContent - | MerkleizedTxInput InputContent BuiltinByteString +data MarloweTxInput i t = Input (InputContent i t) + | MerkleizedTxInput (InputContent i t) BuiltinByteString deriving stock (Haskell.Show,Haskell.Eq,Generic) deriving anyclass (Pretty) @@ -94,8 +96,8 @@ defaultRolePayoutValidatorHash = mkRolePayoutValidatorHash adaSymbol {-# INLINABLE smallMarloweValidator #-} smallMarloweValidator :: MarloweParams - -> MarloweData - -> MarloweInput + -> MarloweData PubKeyHash Token + -> MarloweInput PubKeyHash Token -> ScriptContext -> Bool smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} @@ -125,7 +127,7 @@ smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} -- total balance of all accounts in State -- accounts must be positive, and we checked it above - let inputBalance = totalBalance (accounts marloweState) + let inputBalance = moneyToValue $ totalBalance (accounts marloweState) -- ensure that a contract TxOut has what it suppose to have let balancesOk = traceIfFalse "B1" $ inputBalance == scriptInValue @@ -186,7 +188,7 @@ smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} findDatumHash' :: PlutusTx.ToData o => o -> Maybe DatumHash findDatumHash' datum = findDatumHash (Datum $ PlutusTx.toBuiltinData datum) scriptContextTxInfo - checkOwnOutputConstraint :: MarloweData -> Val.Value -> Bool + checkOwnOutputConstraint :: MarloweData PubKeyHash Token -> Val.Value -> Bool checkOwnOutputConstraint ocDatum ocValue = let hsh = findDatumHash' ocDatum in traceIfFalse "L1" -- "Output constraint" @@ -208,7 +210,7 @@ smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} allOutputs :: [TxOut] allOutputs = txInfoOutputs scriptContextTxInfo - marloweTxInputToInput :: MarloweTxInput -> Input + marloweTxInputToInput :: MarloweTxInput PubKeyHash Token -> Input PubKeyHash Token marloweTxInputToInput (MerkleizedTxInput input hash) = case findDatum (DatumHash hash) scriptContextTxInfo of Just (Datum d) -> let @@ -217,10 +219,10 @@ smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} Nothing -> traceError "H" marloweTxInputToInput (Input input) = NormalInput input - validateInputs :: [Input] -> Bool + validateInputs :: [Input PubKeyHash Token] -> Bool validateInputs inputs = all (validateInputWitness . getInputContent) inputs where - validateInputWitness :: InputContent -> Bool + validateInputWitness :: InputContent PubKeyHash Token -> Bool validateInputWitness input = case input of IDeposit _ party _ _ -> validatePartyWitness party @@ -231,15 +233,15 @@ smallMarloweValidator MarloweParams{rolesCurrency, rolePayoutValidatorHash} validatePartyWitness (Role role) = traceIfFalse "T" -- "Spent value not OK" $ Val.singleton rolesCurrency role 1 `Val.leq` valueSpent scriptContextTxInfo - collectDeposits :: InputContent -> Val.Value + collectDeposits :: InputContent PubKeyHash Token -> Val.Value collectDeposits (IDeposit _ _ (Token cur tok) amount) = Val.singleton cur tok amount collectDeposits _ = zero - payoutByParty :: Payment -> AssocMap.Map Party Val.Value - payoutByParty (Payment _ (Party party) money) = AssocMap.singleton party money + payoutByParty :: Payment PubKeyHash Token -> AssocMap.Map (Party PubKeyHash) Val.Value + payoutByParty (Payment _ (Party party) money) = AssocMap.singleton party (moneyToValue money) payoutByParty (Payment _ (Account _) _) = AssocMap.empty - payoutConstraints :: [(Party, Val.Value)] -> Bool + payoutConstraints :: [(Party PubKeyHash, Val.Value)] -> Bool payoutConstraints payoutsByParty = all payoutToTxOut payoutsByParty where payoutToTxOut (party, value) = case party of @@ -270,11 +272,11 @@ smallUntypedValidator params = let defaultTxValidationRange :: POSIXTime defaultTxValidationRange = 10000 -marloweTxInputFromInput :: Input -> MarloweTxInput +marloweTxInputFromInput :: Input i t -> MarloweTxInput i t marloweTxInputFromInput (NormalInput i) = Input i marloweTxInputFromInput (MerkleizedInput i h _) = MerkleizedTxInput i h -marloweTxInputsFromInputs :: [Input] -> [MarloweTxInput] +marloweTxInputsFromInputs :: [Input i t] -> [MarloweTxInput i t] marloweTxInputsFromInputs = fmap marloweTxInputFromInput makeLift ''MarloweTxInput diff --git a/marlowe/src/Language/Marlowe/Util.hs b/marlowe/src/Language/Marlowe/Util.hs index a7a7114764..d1c74f0c55 100644 --- a/marlowe/src/Language/Marlowe/Util.hs +++ b/marlowe/src/Language/Marlowe/Util.hs @@ -1,15 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Language.Marlowe.Util (ada, addAccountsDiff, emptyAccountsDiff, extractNonMerkleizedContractRoles, - foldMapNonMerkleizedContract, foldMapContract, getAccountsDiff, isEmptyAccountsDiff, +module Language.Marlowe.Util (ada, {- addAccountsDiff, emptyAccountsDiff, -} extractNonMerkleizedContractRoles, + foldMapNonMerkleizedContract, foldMapContract, {- getAccountsDiff, isEmptyAccountsDiff, -} merkleizedCase) where -import Data.List (foldl') -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +-- import Data.List (foldl') +-- import Data.Map.Strict (Map) +-- import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set import Data.String -import Language.Marlowe.Core.V1.Semantics +-- import Language.Marlowe.Core.V1.Semantics +import Language.Marlowe.Core.V1.Semantics.Token import Language.Marlowe.Core.V1.Semantics.Types import Ledger.Ada (adaSymbol, adaToken) import Ledger.Scripts (dataHash) @@ -17,16 +18,16 @@ import qualified Ledger.Value as Val import qualified PlutusTx import qualified PlutusTx.Prelude as P -instance IsString Party where +instance IsString (Party i) where fromString s = Role (fromString s) ada :: Token ada = Token adaSymbol adaToken +{- type AccountsDiff = Map Party Money - emptyAccountsDiff :: AccountsDiff emptyAccountsDiff = Map.empty @@ -36,7 +37,7 @@ isEmptyAccountsDiff = all Val.isZero -- Adds a value to the map of outcomes -addAccountsDiff :: Party -> Money -> AccountsDiff -> AccountsDiff +addAccountsDiff :: Party -> Money Token -> AccountsDiff -> AccountsDiff addAccountsDiff party diffValue trOut = let newValue = case Map.lookup party trOut of Just value -> value P.+ diffValue @@ -45,21 +46,22 @@ addAccountsDiff party diffValue trOut = let -- | Extract total outcomes from transaction inputs and outputs -getAccountsDiff :: [Payment] -> [Input] -> AccountsDiff +getAccountsDiff :: [Payment] -> [Input Token] -> AccountsDiff getAccountsDiff payments inputs = foldl' (\acc (p, m) -> addAccountsDiff p m acc) emptyAccountsDiff (incomes ++ outcomes) where incomes = [ (p, Val.singleton cur tok m) | IDeposit _ p (Token cur tok) m <- map getInputContent inputs ] outcomes = [ (p, P.negate m) | Payment _ (Party p) m <- payments ] +-} foldMapContract :: Monoid m - => (P.BuiltinByteString -> Maybe Contract) - -> (Contract -> m) - -> (Case Contract -> m) - -> (Observation -> m) - -> (Value Observation -> m) - -> Contract -> m + => (P.BuiltinByteString -> Maybe (Contract i t)) + -> (Contract i t -> m) + -> (Case i t -> m) + -> (Observation i t -> m) + -> (Value i t -> m) + -> Contract i t -> m foldMapContract funmerk fcont fcase fobs fvalue contract = fcont contract <> case contract of Close -> mempty @@ -94,15 +96,15 @@ foldMapContract funmerk fcont fcase fobs fvalue contract = foldMapNonMerkleizedContract :: Monoid m - => (Contract -> m) - -> (Case Contract -> m) - -> (Observation -> m) - -> (Value Observation -> m) - -> Contract -> m + => (Contract i t -> m) + -> (Case i t -> m) + -> (Observation i t -> m) + -> (Value i t -> m) + -> Contract i t -> m foldMapNonMerkleizedContract = foldMapContract (const Nothing) -extractNonMerkleizedContractRoles :: Contract -> Set Val.TokenName +extractNonMerkleizedContractRoles :: Contract i t -> Set Val.TokenName extractNonMerkleizedContractRoles = foldMapNonMerkleizedContract extract extractCase (const mempty) (const mempty) where extract (Pay from payee _ _ _) = fromParty from <> fromPayee payee @@ -119,7 +121,7 @@ extractNonMerkleizedContractRoles = foldMapNonMerkleizedContract extract extract fromPayee (Account party) = fromParty party -merkleizedCase :: Action -> Contract -> Case Contract +merkleizedCase :: (PlutusTx.ToData t, PlutusTx.ToData i) => Action i t -> Contract i t -> Case i t merkleizedCase action continuation = let hash = dataHash (PlutusTx.toBuiltinData continuation) in MerkleizedCase action hash diff --git a/marlowe/test/Spec/Marlowe/Arbitrary.hs b/marlowe/test/Spec/Marlowe/Arbitrary.hs index 323bc5f270..a6a9c9a673 100644 --- a/marlowe/test/Spec/Marlowe/Arbitrary.hs +++ b/marlowe/test/Spec/Marlowe/Arbitrary.hs @@ -1,4 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -35,9 +36,10 @@ module Spec.Marlowe.Arbitrary ( import Control.Monad (replicateM) import Data.Function (on) import Data.List (nub, nubBy) +import Language.Marlowe.Core.V1.Semantics.Token (Token (..)) import Language.Marlowe.Core.V1.Semantics.Types (AccountId, Accounts, Bound (..), Case, ChoiceId (..), ChoiceName, - ChosenNum, Contract, Environment (..), Party (..), Payee (..), - State (..), TimeInterval, Token (..), ValueId (..)) + ChosenNum, Environment (..), Party (..), Payee (..), State (..), + TimeInterval, ValueId (..)) import Plutus.V1.Ledger.Api (CurrencySymbol (..), POSIXTime (..), PubKeyHash (..), TokenName (..), adaSymbol, adaToken) import PlutusTx.Builtins (BuiltinByteString, lengthOfByteString) import Spec.Marlowe.Common (caseRelGenSized, simpleIntegerGen) @@ -184,7 +186,7 @@ randomRoleNames = , "Urbanus Roland Alison Ty Ryoichi" ] -instance Arbitrary Party where +instance Arbitrary (Party PubKeyHash) where arbitrary = do isPubKeyHash <- frequency [(2, pure True), (8, pure False)] @@ -195,7 +197,7 @@ instance Arbitrary Party where shrink (Role x) = Role <$> shrinkByteString (\(TokenName y) -> y) randomRoleNames x -instance Arbitrary Payee where +instance Arbitrary (Payee PubKeyHash) where arbitrary = do isParty <- arbitrary @@ -234,7 +236,7 @@ shrinkChoiceName :: ChoiceName -> [ChoiceName] shrinkChoiceName = shrinkByteString id randomChoiceNames -instance Arbitrary ChoiceId where +instance Arbitrary (ChoiceId PubKeyHash) where arbitrary = ChoiceId <$> arbitraryChoiceName <*> arbitrary shrink (ChoiceId n p) = [ChoiceId n' p' | n' <- shrinkChoiceName n, p' <- shrink p] @@ -327,16 +329,16 @@ shrinkAssocMap am = ] -arbitraryAccounts :: Gen Accounts +arbitraryAccounts :: Gen (Accounts PubKeyHash Token) arbitraryAccounts = arbitraryAssocMap ((,) <$> arbitrary <*> arbitrary) arbitraryPositiveAmount -shrinkAccounts :: Accounts -> [Accounts] +shrinkAccounts :: Accounts PubKeyHash Token -> [Accounts PubKeyHash Token] shrinkAccounts = shrinkAssocMap -arbitraryFromAccounts :: Accounts -> Gen ((AccountId, Token), Integer) +arbitraryFromAccounts :: Accounts PubKeyHash Token -> Gen ((AccountId PubKeyHash, Token), Integer) arbitraryFromAccounts accounts' | AM.null accounts' = (,) <$> ((,) <$> arbitrary <*> arbitrary) <*> arbitrary | otherwise = @@ -357,13 +359,13 @@ arbitraryFromAccounts accounts' (False, False) -> (,) <$> ((,) <$> chooseAccountId <*> chooseToken) <*> chooseAmount -arbitraryChoices :: Gen (AM.Map ChoiceId ChosenNum) +arbitraryChoices :: Gen (AM.Map (ChoiceId PubKeyHash) ChosenNum) arbitraryChoices = arbitraryAssocMap arbitrary arbitrary -shrinkChoices :: AM.Map ChoiceId ChosenNum -> [AM.Map ChoiceId ChosenNum] +shrinkChoices :: AM.Map (ChoiceId PubKeyHash) ChosenNum -> [AM.Map (ChoiceId PubKeyHash) ChosenNum] shrinkChoices = shrinkAssocMap -arbitraryChoiceIdFromParty :: Gen Party -> Gen ChoiceId +arbitraryChoiceIdFromParty :: Gen (Party PubKeyHash) -> Gen (ChoiceId PubKeyHash) arbitraryChoiceIdFromParty party = ChoiceId <$> arbitraryChoiceName <*> party arbitraryBoundValues :: Gen (AM.Map ValueId Integer) @@ -373,7 +375,7 @@ shrinkBoundValues :: AM.Map ValueId Integer -> [AM.Map ValueId Integer] shrinkBoundValues = shrinkAssocMap -instance Arbitrary State where +instance Arbitrary (State PubKeyHash Token) where arbitrary = do accounts' <- arbitraryAccounts @@ -394,5 +396,5 @@ instance Arbitrary Environment where shrink (Environment x) = Environment <$> shrink x -caseGen :: Gen (Case Contract) +caseGen :: Gen (Case PubKeyHash Token) caseGen = sized $ (simpleIntegerGen >>=) . caseRelGenSized diff --git a/marlowe/test/Spec/Marlowe/Common.hs b/marlowe/test/Spec/Marlowe/Common.hs index 687b040ec1..9041104637 100644 --- a/marlowe/test/Spec/Marlowe/Common.hs +++ b/marlowe/test/Spec/Marlowe/Common.hs @@ -26,14 +26,14 @@ positiveAmount :: Gen Integer positiveAmount = choose (1, 100) -partyGen :: Gen Party +partyGen :: Gen (Party PubKeyHash) partyGen = oneof [ return $ Role "alice" , return $ Role "bob" , return $ PK (pubKeyHash "6361726f6c") ] -shrinkParty :: Party -> [Party] +shrinkParty :: Party PubKeyHash -> [Party PubKeyHash] shrinkParty party = case party of PK _ -> [Role "alice", Role "bob"] Role "bob" -> [Role "alice"] @@ -41,13 +41,13 @@ shrinkParty party = case party of _ -> [] -payeeGen :: Gen Payee +payeeGen :: Gen (Payee PubKeyHash) payeeGen = oneof [ Account <$> partyGen , Party <$> partyGen ] -shrinkPayee :: Payee -> [Payee] +shrinkPayee :: Payee PubKeyHash -> [Payee PubKeyHash] shrinkPayee (Account accId) = [Account x | x <- shrinkParty accId] shrinkPayee (Party party) = [Party x | x <- shrinkParty party] @@ -81,7 +81,7 @@ shrinkSimpleInteger 0 = [] shrinkSimpleInteger v = [0, v `quot` 2] -choiceIdGen :: Gen ChoiceId +choiceIdGen :: Gen (ChoiceId PubKeyHash) choiceIdGen = do choName <- oneof [ return "first" , return "second" ] @@ -89,7 +89,7 @@ choiceIdGen = do choName <- oneof [ return "first" return $ ChoiceId choName chooser -shrinkChoiceId :: ChoiceId -> [ChoiceId] +shrinkChoiceId :: ChoiceId PubKeyHash -> [ChoiceId PubKeyHash] shrinkChoiceId (ChoiceId "second" chooser) = ChoiceId "first" chooser :[ChoiceId "second" x | x <- shrinkParty chooser] shrinkChoiceId (ChoiceId "first" chooser) = [ChoiceId "first" x | x <- shrinkParty chooser] @@ -115,7 +115,7 @@ rationalGen = do return $ a % b -valueGenSized :: Int -> Gen (Value Observation) +valueGenSized :: Int -> Gen (Value PubKeyHash Token) valueGenSized s | s > 0 = oneof [ AvailableMoney <$> partyGen <*> tokenGen , Constant <$> simpleIntegerGen @@ -140,11 +140,11 @@ valueGenSized s ] -valueGen :: Gen (Value Observation) +valueGen :: Gen (Value PubKeyHash Token) valueGen = sized valueGenSized -shrinkValue :: Value Observation -> [Value Observation] +shrinkValue :: Value PubKeyHash Token -> [Value PubKeyHash Token] shrinkValue value = case value of Constant x -> [Constant y | y <- shrinkSimpleInteger x] TimeIntervalStart -> [Constant 0] @@ -167,7 +167,7 @@ shrinkValue value = case value of ++ [Cond b val1 y | y <- shrinkValue val2]) -observationGenSized :: Int -> Gen Observation +observationGenSized :: Int -> Gen (Observation PubKeyHash Token) observationGenSized s | s > 0 = oneof [ AndObs <$> observationGenSized (s `quot` 2) <*> observationGenSized (s `quot` 2) @@ -193,11 +193,11 @@ observationGenSized s , return FalseObs ] -observationGen :: Gen Observation +observationGen :: Gen (Observation PubKeyHash Token) observationGen = sized observationGenSized -shrinkObservation :: Observation -> [Observation] +shrinkObservation :: Observation PubKeyHash Token -> [Observation PubKeyHash Token] shrinkObservation obs = case obs of FalseObs -> [] TrueObs -> [FalseObs] @@ -244,18 +244,18 @@ boundListGen = do len <- listLengthGen boundListGenAux len firstBound -actionGenSized :: Int -> Gen Action +actionGenSized :: Int -> Gen (Action PubKeyHash Token) actionGenSized s = oneof [ Deposit <$> partyGen <*> partyGen <*> tokenGen <*> valueGenSized (s - 1) , Choice <$> choiceIdGen <*> boundListGen , Notify <$> observationGenSized (s - 1) ] -actionGen :: Gen Action +actionGen :: Gen (Action PubKeyHash Token) actionGen = sized actionGenSized -shrinkAction :: Action -> [Action] +shrinkAction :: Action PubKeyHash Token -> [Action PubKeyHash Token] shrinkAction action = case action of Deposit accId party tok val -> Notify FalseObs : [Deposit accId party tok v | v <- shrinkValue val] ++ [Deposit x party tok val | x <- shrinkParty accId] @@ -267,18 +267,18 @@ shrinkAction action = case action of Notify obs -> [Notify x | x <- shrinkObservation obs] -caseRelGenSized :: Int -> Integer -> Gen (Case Contract) +caseRelGenSized :: Int -> Integer -> Gen (Case PubKeyHash Token) caseRelGenSized s bn = frequency [ (9, Case <$> actionGenSized s <*> contractRelGenSized s bn) , (1, merkleizedCase <$> actionGenSized s <*> contractRelGenSized s bn) ] -shrinkCase :: Case Contract -> [Case Contract] +shrinkCase :: Case PubKeyHash Token -> [Case PubKeyHash Token] shrinkCase (Case act cont) = [Case act x | x <- shrinkContract cont] ++ [Case y cont | y <- shrinkAction act] shrinkCase (MerkleizedCase act bs) = [MerkleizedCase y bs | y <- shrinkAction act] -contractRelGenSized :: Int -> Integer -> Gen Contract +contractRelGenSized :: Int -> Integer -> Gen (Contract PubKeyHash Token) contractRelGenSized s bn | s > 0 = oneof [ return Close , Pay <$> partyGen <*> payeeGen <*> tokenGen @@ -301,15 +301,15 @@ contractRelGenSized s bn | otherwise = return Close -contractGenSized :: Int -> Gen Contract +contractGenSized :: Int -> Gen (Contract PubKeyHash Token) contractGenSized s = do iniBn <- simpleIntegerGen contractRelGenSized s iniBn -contractGen :: Gen Contract +contractGen :: Gen (Contract PubKeyHash Token) contractGen = sized contractGenSized -shrinkContract :: Contract -> [Contract] +shrinkContract :: Contract PubKeyHash Token -> [Contract PubKeyHash Token] shrinkContract cont = case cont of Close -> [] Let vid val cont -> Close : cont : ([Let vid v cont | v <- shrinkValue val] @@ -336,7 +336,7 @@ shrinkContract cont = case cont of ++ [Assert obs y | y <- shrinkContract cont]) -pangramContract :: Contract +pangramContract :: Contract PubKeyHash Token pangramContract = let alicePk = PK . unPaymentPubKeyHash . mockWalletPaymentPubKeyHash $ knownWallet 1 aliceAcc = alicePk diff --git a/marlowe/test/Spec/Marlowe/Marlowe.hs b/marlowe/test/Spec/Marlowe/Marlowe.hs index c132bde8d4..7a3ef4083f 100644 --- a/marlowe/test/Spec/Marlowe/Marlowe.hs +++ b/marlowe/test/Spec/Marlowe/Marlowe.hs @@ -46,6 +46,7 @@ import qualified Language.Marlowe as M ((%)) import Language.Marlowe.Analysis.FSSemantics import Language.Marlowe.Client import Language.Marlowe.Core.V1.Semantics +import Language.Marlowe.Core.V1.Semantics.Token import Language.Marlowe.Core.V1.Semantics.Types import Language.Marlowe.Scripts (MarloweInput, rolePayoutScript, smallTypedValidator, smallUntypedValidator) import Language.Marlowe.Util @@ -329,7 +330,7 @@ trustFundTest = checkPredicateOptions defaultCheckOptions "Trust Fund Contract" roles = Set.fromList ["alice", "bob"] - (params, _ :: TxConstraints MarloweInput MarloweData, _) = + (params, _ :: TxConstraints (MarloweInput PubKeyHash Token) (MarloweData PubKeyHash Token), _) = let con = setupMarloweParams @MarloweSchema @MarloweError (AssocMap.fromList [("alice", walletAddress alice), ("bob", walletAddress bob)]) roles @@ -422,7 +423,8 @@ valuesFormAbelianGroup = property $ do divisionRoundingTest :: Property divisionRoundingTest = property $ do - let eval = evalValue (Environment (POSIXTime 10, POSIXTime 1000)) (emptyState (POSIXTime 10)) + let eval :: Value PubKeyHash Token -> Integer + eval = evalValue (Environment (POSIXTime 10, POSIXTime 1000)) (emptyState (POSIXTime 10)) -- test half-even rounding let gen = do n <- amount @@ -451,7 +453,7 @@ divZeroTest = property $ do valueSerialization :: Property valueSerialization = property $ forAll valueGen $ \a -> - let decoded :: Maybe (Value Observation) + let decoded :: Maybe (Value PubKeyHash Token) decoded = decode $ encode a in Just a === decoded @@ -477,7 +479,9 @@ transferBetweenAccountsTest = do let txInput = TransactionInput { txInterval = (20, 30), txInputs = [] } - case computeTransaction txInput state contract of + let tx :: TransactionOutput PubKeyHash Token + tx = computeTransaction txInput state contract + case tx of TransactionOutput {txOutPayments, txOutState = State{accounts}, txOutContract} -> do assertBool "Accounts check" $ accounts == AssocMap.fromList [(("bob",Token "" ""), 100)] e -> fail $ show e @@ -495,7 +499,8 @@ divAnalysisTest = do result <- warningsTrace (contract 9 2) assertBool "Analysis ok" $ isRight result && either (const False) isJust result - let eval = evalValue (Environment (POSIXTime 10, POSIXTime 1000)) (emptyState (POSIXTime 10)) + let eval :: Value PubKeyHash Token -> Integer + eval = evalValue (Environment (POSIXTime 10, POSIXTime 1000)) (emptyState (POSIXTime 10)) eval (DivValue (Constant 0) (Constant 2)) @=? 0 eval (DivValue (Constant 1) (Constant 0)) @=? 0 eval (DivValue (Constant 5) (Constant 2)) @=? 2 @@ -506,7 +511,8 @@ divAnalysisTest = do divTest :: IO () divTest = do - let eval = evalValue (Environment (POSIXTime 10, POSIXTime 1000)) (emptyState (POSIXTime 10)) + let eval :: Value PubKeyHash Token -> Integer + eval = evalValue (Environment (POSIXTime 10, POSIXTime 1000)) (emptyState (POSIXTime 10)) eval (DivValue (Constant 0) (Constant 2)) @=? 0 eval (DivValue (Constant 1) (Constant 0)) @=? 0 eval (DivValue (Constant 5) (Constant 2)) @=? 2 @@ -523,7 +529,7 @@ pangramContractSerialization = do -- T.putStrLn json Just pangramContract @=? (decode $ encode pangramContract) contract <- readFile "test/contract.json" - let decoded :: Maybe Contract + let decoded :: Maybe (Contract PubKeyHash Token) decoded = decode (fromString contract) case decoded of Just cont -> cont @=? pangramContract @@ -534,7 +540,7 @@ tokenShowTest :: IO () tokenShowTest = do -- SCP-834, CurrencySymbol is HEX encoded ByteString, -- and TokenSymbol as UTF8 encoded Unicode string - let actual :: Value Observation + let actual :: Value PubKeyHash Token actual = AvailableMoney (Role "alice") (Token "00010afF" "ÚSD©") show actual @=? "AvailableMoney \"alice\" (Token \"00010aff\" \"ÚSD©\")" @@ -555,7 +561,7 @@ inputSerialization = do stateSerialization :: IO () stateSerialization = do state <- readFile "test/state.json" - let decoded :: Maybe State + let decoded :: Maybe (State PubKeyHash Token) decoded = decode (fromString state) case decoded of Just st -> @@ -568,7 +574,7 @@ prop_showWorksForContracts :: Property prop_showWorksForContracts = forAllShrink contractGen shrinkContract showWorksForContract -showWorksForContract :: Contract -> Property +showWorksForContract :: Contract PubKeyHash Token -> Property showWorksForContract contract = unsafePerformIO $ do res <- runInterpreter $ setImports ["Language.Marlowe"] >> set [ languageExtensions := [ OverloadedStrings ] ] @@ -578,11 +584,11 @@ showWorksForContract contract = unsafePerformIO $ do Left err -> counterexample (show err) False) -interpretContractString :: MonadInterpreter m => String -> m Contract -interpretContractString contractStr = interpret contractStr (as :: Contract) +interpretContractString :: MonadInterpreter m => String -> m (Contract PubKeyHash Token) +interpretContractString contractStr = interpret contractStr (as :: Contract PubKeyHash Token) -noFalsePositivesForContract :: Contract -> Property +noFalsePositivesForContract :: Contract PubKeyHash Token -> Property noFalsePositivesForContract cont = unsafePerformIO (do res <- catch (wrapLeft $ warningsTrace cont) (\exc -> return $ Left (Left (exc :: SomeException))) @@ -610,7 +616,7 @@ wrapLeft r = do tempRes <- r prop_noFalsePositives :: Property prop_noFalsePositives = forAllShrink contractGen shrinkContract noFalsePositivesForContract -jsonLoops :: Contract -> Property +jsonLoops :: Contract PubKeyHash Token -> Property jsonLoops cont = decode (encode cont) === Just cont prop_jsonLoops :: Property diff --git a/marlowe/test/Spec/Marlowe/Semantics.hs b/marlowe/test/Spec/Marlowe/Semantics.hs index 79cbf7ffb7..3cbc596ded 100644 --- a/marlowe/test/Spec/Marlowe/Semantics.hs +++ b/marlowe/test/Spec/Marlowe/Semantics.hs @@ -10,6 +10,7 @@ module Spec.Marlowe.Semantics ( import Data.Maybe (fromMaybe, isNothing) import Language.Marlowe.Core.V1.Semantics +import Language.Marlowe.Core.V1.Semantics.Token import Language.Marlowe.Core.V1.Semantics.Types import Plutus.V1.Ledger.Api (CurrencySymbol, POSIXTime (..), PubKeyHash, TokenName) import Spec.Marlowe.Arbitrary @@ -35,17 +36,17 @@ tests = [ testGroup "Entropy" [ - testCase "PubKeyHash" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen PubKeyHash ) - , testCase "CurrencySymbol" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen CurrencySymbol ) - , testCase "TokenName" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen TokenName ) - , testCase "Token" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen Token ) - , testCase "Party" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen Party ) + testCase "PubKeyHash" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen PubKeyHash ) + , testCase "CurrencySymbol" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen CurrencySymbol ) + , testCase "TokenName" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen TokenName ) + , testCase "Token" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen Token ) + , testCase "Party" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen (Party PubKeyHash) ) , testCase "ChoiceName" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) arbitraryChoiceName - , testCase "ChoiceId" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen ChoiceId ) - , testCase "ValueId" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen ValueId ) - , testCase "accounts" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (AM.keys <$> arbitraryAccounts ) - , testCase "choices" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (AM.keys <$> arbitraryChoices ) - , testCase "boundValues" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (AM.keys <$> arbitraryBoundValues) + , testCase "ChoiceId" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen (ChoiceId PubKeyHash)) + , testCase "ValueId" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (arbitrary :: Gen ValueId ) + , testCase "accounts" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (AM.keys <$> arbitraryAccounts ) + , testCase "choices" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (AM.keys <$> arbitraryChoices ) + , testCase "boundValues" $ checkEntropy 1000 (logBase 2 5, logBase 2 100) (AM.keys <$> arbitraryBoundValues ) ] ] , testGroup "Semantics" @@ -153,7 +154,8 @@ tests = checkFixInterval :: Bool -> Bool -> Property checkFixInterval invalid inPast = property $ do - let gen = do + let gen :: Gen ((POSIXTime, POSIXTime), State PubKeyHash Token) + gen = do state <- arbitrary end <- arbitrary `suchThat` (\t -> (t < minTime state) == inPast) start <- arbitrary `suchThat` (\t -> (t > end) == invalid && (t < minTime state) == inPast) @@ -168,8 +170,8 @@ checkFixInterval invalid inPast = checkValue :: Show a - => (Environment -> State -> Gen a) - -> ((Value Observation -> Integer) -> (Observation -> Bool) -> Environment -> State -> a -> Bool) + => (Environment -> State PubKeyHash Token -> Gen a) + -> ((Value PubKeyHash Token -> Integer) -> (Observation PubKeyHash Token -> Bool) -> Environment -> State PubKeyHash Token -> a -> Bool) -> Property checkValue gen f = property $ do @@ -185,6 +187,7 @@ checkValue gen f = checkAvailableMoney :: Bool -> Property checkAvailableMoney isElement = let + gen :: a -> State PubKeyHash Token -> Gen (AccountId PubKeyHash, Token) gen _ State{accounts} = if isElement && not (AM.null accounts) then elements $ AM.keys accounts @@ -238,9 +241,11 @@ checkMulValue = checkDivValueNumeratorDenominatorZero :: Assertion -checkDivValueNumeratorDenominatorZero = +checkDivValueNumeratorDenominatorZero = do + let eval :: Value PubKeyHash Token -> Integer + eval = evalValue undefined undefined assertBool "DivValue 0 0 = 0" - $ evalValue undefined undefined (DivValue (Constant 0) (Constant 0)) == 0 + $ eval (DivValue (Constant 0) (Constant 0)) == 0 checkDivValueNumeratorZero :: Property @@ -276,6 +281,7 @@ checkDivValueRounding = checkChoiceValue :: Bool -> Property checkChoiceValue isElement = let + gen :: a -> State PubKeyHash Token -> Gen (ChoiceId PubKeyHash) gen _ State{choices} = if isElement && not (AM.null choices) then elements $ AM.keys choices @@ -355,6 +361,7 @@ checkNotObs = checkChoseSomething :: Bool -> Property checkChoseSomething isElement = let + gen :: a -> State PubKeyHash Token -> Gen (ChoiceId PubKeyHash) gen _ State{choices} = if isElement && not (AM.null choices) then elements $ AM.keys choices @@ -413,20 +420,25 @@ checkValueEQ = checkTrueObs :: Assertion -checkTrueObs = +checkTrueObs = do + let eval :: Observation PubKeyHash Token -> Bool + eval = evalObservation undefined undefined assertBool "TrueObs is true." - $ evalObservation undefined undefined TrueObs + $ eval TrueObs checkFalseObs :: Assertion -checkFalseObs = +checkFalseObs = do + let eval :: Observation PubKeyHash Token -> Bool + eval = evalObservation undefined undefined assertBool "FalseObs is false." - . not $ evalObservation undefined undefined FalseObs + . not $ eval FalseObs checkApplyActionMismatch :: Property checkApplyActionMismatch = property $ do - let gen = do + let gen :: Gen (InputContent PubKeyHash Token, Action PubKeyHash Token) + gen = do let inputs = [IDeposit undefined undefined undefined undefined, IChoice undefined undefined, INotify] actions = [Deposit undefined undefined undefined undefined, Choice undefined undefined, Notify undefined] @@ -487,7 +499,8 @@ checkIDeposit accountMatches partyMatches tokenMatches amountMatches = property checkIChoice :: Maybe Bool -> Maybe Bool -> Property checkIChoice choiceMatches choiceInBounds = property $ do - let gen = do + let gen :: Gen (Environment, State PubKeyHash Token, ChoiceId PubKeyHash, ChosenNum, Action PubKeyHash Token, Bool) + gen = do choiceMatches' <- maybe arbitrary pure choiceMatches choiceInBounds' <- maybe arbitrary pure choiceInBounds environment <- arbitrary @@ -611,6 +624,7 @@ checkReduceContractStepClose = property $ do forAll ((,) <$> arbitrary <*> arbitrary) $ \(environment, state) -> let + checkPayment :: Payment PubKeyHash Token -> State PubKeyHash Token -> Contract PubKeyHash Token -> Bool checkPayment (Payment payee (Party payee') money) state' Close = payee == payee' && case flattenMoney money of diff --git a/marlowe/test/Spec/Marlowe/Util.hs b/marlowe/test/Spec/Marlowe/Util.hs index dde4252f03..9066fb2ae8 100644 --- a/marlowe/test/Spec/Marlowe/Util.hs +++ b/marlowe/test/Spec/Marlowe/Util.hs @@ -13,8 +13,11 @@ module Spec.Marlowe.Util ( import Control.Monad (replicateM) import Data.Function (on) import Data.List (group, sort) +import Language.Marlowe.Core.V1.Semantics.Money (Money) +import qualified Language.Marlowe.Core.V1.Semantics.Money as Money +import Language.Marlowe.Core.V1.Semantics.Token import Language.Marlowe.Core.V1.Semantics.Types -import Plutus.V1.Ledger.Value (flattenValue) +import Ledger (PubKeyHash) import Spec.Marlowe.Util.AssocMap import Test.Tasty.HUnit (Assertion, assertBool) import Test.Tasty.QuickCheck (Gen, generate) @@ -22,7 +25,7 @@ import Test.Tasty.QuickCheck (Gen, generate) import qualified PlutusTx.Prelude as P -canonicalState :: State -> State +canonicalState :: State PubKeyHash Token -> State PubKeyHash Token canonicalState State{..} = State (assocMapSort accounts) @@ -31,12 +34,12 @@ canonicalState State{..} = minTime -stateEq :: State -> State -> Bool +stateEq :: State PubKeyHash Token -> State PubKeyHash Token -> Bool stateEq = (==) `on` canonicalState -flattenMoney :: Money -> [(Token, Integer)] -flattenMoney = fmap (\(s, n, a) -> (Token s n, a)) . flattenValue +flattenMoney :: Money Token -> [(Token, Integer)] +flattenMoney = Money.toList roundedDivide :: Integer