Make Marlowe chain agnostic

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)

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

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 {..} =

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,20 +72,20 @@ 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
     -- is exectued, resp. the schedule do not depend on
     -- 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

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

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

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 {..}

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 }

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

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.

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

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,25 +228,25 @@ readAddressAnyEither s =
 
 
 -- | Parser for `Party`.
-parseParty :: O.ReadM Party
+parseParty :: O.ReadM (Party PubKeyHash)
 parseParty =
         O.eitherReader readPartyPkEither
     <|> O.eitherReader readPartyRoleEither
     <|> O.readerError "Invalid party."
 
 
 -- | 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
     _                 -> Left "Invalid public key hash for party."
 
 
 -- | 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

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