Marlowe validator using Data (IntersectMBO#5509)

* Marlowe validator using Data * WIP * WIP * WIP
mlabs-haskell · Nov 21, 2023 · 06edb24 · 06edb24
1 parent e5e8b88
commit 06edb24
Show file tree

Hide file tree

Showing 211 changed files with 736 additions and 894 deletions.
diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics.hs
@@ -1,4 +1,3 @@
-
 -- editorconfig-checker-disable-file
 
 
@@ -35,21 +34,27 @@
 {-# LANGUAGE DeriveDataTypeable    #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE PatternSynonyms       #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE ViewPatterns          #-}
 
-{-# OPTIONS_GHC -fno-specialise #-}  -- A big hammer, but it helps.
+{-# OPTIONS_GHC -O0 #-}
+-- the biggest hammer :(
+-- truly mysterious issues here
+{-# OPTIONS_GHC -fmax-simplifier-iterations=0 #-}
+-- O0 turns these off
 {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
-{-# OPTIONS_GHC -fno-warn-orphans       #-}
 {-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
 
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
 
 module PlutusBenchmark.Marlowe.Core.V1.Semantics
   ( -- * Semantics
-    MarloweData(..)
+    MarloweData(MarloweData, marloweParams, marloweState, marloweContract)
   , MarloweParams(..)
   , Payment(..)
   , TransactionInput(..)
@@ -94,19 +99,13 @@ module PlutusBenchmark.Marlowe.Core.V1.Semantics
   , totalBalance
   ) where
 
-
 import Data.Data (Data)
 import GHC.Generics (Generic)
-import PlutusBenchmark.Marlowe.Core.V1.Semantics.Types (AccountId, Accounts, Action (..), Case (..),
-                                                        Contract (..), Environment (..), Input (..),
-                                                        InputContent (..), IntervalError (..),
-                                                        IntervalResult (..), Money,
-                                                        Observation (..), Party, Payee (..),
-                                                        State (..), TimeInterval, Token (..),
-                                                        Value (..), ValueId, emptyState, getAction,
-                                                        getInputContent, inBounds)
+import PlutusBenchmark.Marlowe.Core.V1.Semantics.Types
 import PlutusLedgerApi.V2 (CurrencySymbol, POSIXTime (..))
-import PlutusTx (makeIsDataIndexed)
+import PlutusTx (FromData, ToData, UnsafeFromData)
+import PlutusTx.AsData (asData)
+import PlutusTx.IsData (makeIsDataIndexed)
 import PlutusTx.Lift (makeLift)
 import PlutusTx.Prelude (AdditiveGroup ((-)), AdditiveSemigroup ((+)), Bool (..), Eq (..), Integer,
                          Maybe (..), MultiplicativeSemigroup ((*)),
@@ -119,31 +118,6 @@ import PlutusTx.Builtins qualified as Builtins
 import Prelude qualified as Haskell
 
 
--- Functions that used in Plutus Core must be inlineable,
--- so their code is available for PlutusTx compiler.
-{-# INLINABLE fixInterval #-}
-{-# INLINABLE evalValue #-}
-{-# INLINABLE evalObservation #-}
-{-# INLINABLE refundOne #-}
-{-# INLINABLE moneyInAccount #-}
-{-# INLINABLE updateMoneyInAccount #-}
-{-# INLINABLE addMoneyToAccount #-}
-{-# INLINABLE giveMoney #-}
-{-# INLINABLE reduceContractStep #-}
-{-# INLINABLE reduceContractUntilQuiescent #-}
-{-# INLINABLE applyAction #-}
-{-# INLINABLE getContinuation #-}
-{-# INLINABLE applyCases #-}
-{-# INLINABLE applyInput #-}
-{-# INLINABLE convertReduceWarnings #-}
-{-# INLINABLE applyAllInputs #-}
-{-# INLINABLE isClose #-}
-{-# INLINABLE notClose #-}
-{-# INLINABLE computeTransaction #-}
-{-# INLINABLE contractLifespanUpperBound #-}
-{-# INLINABLE totalBalance #-}
-
-
 {-| Payment occurs during 'Pay' contract evaluation, and
     when positive balances are payed out on contract closure.
 -}
@@ -245,18 +219,25 @@ data TransactionOutput =
   deriving stock (Haskell.Show, Data)
 
 
--- | This data type is a content of a contract's /Datum/
-data MarloweData = MarloweData {
-        marloweParams   :: MarloweParams,
-        marloweState    :: State,
-        marloweContract :: Contract
-    } deriving stock (Haskell.Show, Haskell.Eq, Generic, Data)
-
-
 -- | Parameters constant during the course of a contract.
 newtype MarloweParams = MarloweParams { rolesCurrency :: CurrencySymbol }
   deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord, Data)
 
+makeIsDataIndexed ''MarloweParams [('MarloweParams, 0)]
+
+asData
+  [d|
+  -- | This data type is a content of a contract's /Datum/
+  data MarloweData = MarloweData {
+          marloweParams   :: MarloweParams,
+          marloweState    :: State,
+          marloweContract :: Contract
+      }
+      deriving stock (Generic, Data)
+      deriving newtype (ToData, FromData, UnsafeFromData, Haskell.Show, Haskell.Eq)
+  |]
+
+{-# INLINABLE MarloweData #-}
 
 -- | Checks 'interval' and trims it if necessary.
 fixInterval :: TimeInterval -> State -> IntervalResult
@@ -739,6 +720,30 @@ instance Eq ReduceEffect where
     ReduceWithPayment p1 == ReduceWithPayment p2 = p1 == p2
     ReduceWithPayment _ == _                     = False
 
+-- Functions that used in Plutus Core must be inlineable,
+-- so their code is available for PlutusTx compiler.
+{-# INLINABLE fixInterval #-}
+{-# INLINABLE evalValue #-}
+{-# INLINABLE evalObservation #-}
+{-# INLINABLE refundOne #-}
+{-# INLINABLE moneyInAccount #-}
+{-# INLINABLE updateMoneyInAccount #-}
+{-# INLINABLE addMoneyToAccount #-}
+{-# INLINABLE giveMoney #-}
+{-# INLINABLE reduceContractStep #-}
+{-# INLINABLE reduceContractUntilQuiescent #-}
+{-# INLINABLE applyAction #-}
+{-# INLINABLE getContinuation #-}
+{-# INLINABLE applyCases #-}
+{-# INLINABLE applyInput #-}
+{-# INLINABLE convertReduceWarnings #-}
+{-# INLINABLE applyAllInputs #-}
+{-# INLINABLE isClose #-}
+{-# INLINABLE notClose #-}
+{-# INLINABLE computeTransaction #-}
+{-# INLINABLE contractLifespanUpperBound #-}
+{-# INLINABLE totalBalance #-}
+
 
 -- Lifting data types to Plutus Core
 makeLift ''IntervalError
@@ -754,7 +759,5 @@ makeLift ''TransactionWarning
 makeLift ''ApplyAllResult
 makeLift ''TransactionError
 makeLift ''TransactionOutput
-makeIsDataIndexed ''MarloweParams [('MarloweParams,0)]
-makeIsDataIndexed ''MarloweData [('MarloweData,0)]
 makeLift ''MarloweParams
 makeLift ''MarloweData