feat: newtype for SameScript agument

mlabs-haskell · Dec 13, 2024 · dbb5ce9 · dbb5ce9
1 parent 7ae5579
commit dbb5ce9
Show file tree

Hide file tree

Showing 8 changed files with 36 additions and 19 deletions.
diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs
@@ -108,11 +108,19 @@ data TxFanKind
 data TxFanFilter (resolved :: Bool) script
   = UserAddress (DSLValue resolved script PubKeyHash)
   | -- FIXME: should have spine been specified known statically
-    SameScript (DSLValue resolved script (State script))
+    SameScript (SameScriptArg resolved script) -- (DSLValue resolved script (State script))
 
 deriving stock instance (CEMScript script) => (Show (TxFanFilter True script))
 deriving stock instance (Show (TxFanFilter False script))
 
+data SameScriptArg (resolved :: Bool) script where
+  MkSameScriptArg ::
+    DSLValue resolved script (State script) ->
+    SameScriptArg resolved script
+
+deriving stock instance (CEMScript script) => (Show (SameScriptArg True script))
+deriving stock instance (Show (SameScriptArg False script))
+
 -- | Constraints are the root elements of the DSL.
 
 -- TODO: rename, why Tx? Transition? Just Constraint?
@@ -188,6 +196,8 @@ data ConstraintDSL script value where
     ConstraintDSL script sop ->
     Proxy label ->
     ConstraintDSL script value
+  -- | Builds a datatype value from the spine and field setters.
+  -- Used for Out "filters"
   UnsafeOfSpine ::
     forall script datatype spine.
     ( spine ~ Spine datatype
@@ -196,8 +206,8 @@ data ConstraintDSL script value where
     Spine datatype ->
     [RecordSetter (ConstraintDSL script) datatype] ->
     ConstraintDSL script datatype
-  -- FIXME: On-chain compilation bounds `UnsafeUpdateOfSpine` to tuple datum?
-  -- Used with In
+  -- FIXME: Шляпа шляпная
+  -- Used for  In
   UnsafeUpdateOfSpine ::
     forall script datatype spine.
     ( spine ~ Spine datatype
@@ -462,9 +472,10 @@ compileConstraint datum transition c = case c of
     compileDslRecur :: ConstraintDSL script x -> Either String x
     compileDslRecur = compileDsl @script datum transition
     recur = compileConstraint @script datum transition
+    compileFanFilter :: TxFanFilter 'False script -> Either String (TxFanFilter 'True script)
     compileFanFilter fanFilter = case fanFilter of
       UserAddress dsl -> UserAddress <$> compileDslRecur dsl
-      SameScript stateDsl -> SameScript <$> compileDslRecur stateDsl
+      SameScript (MkSameScriptArg stateDsl) -> SameScript . MkSameScriptArg <$> compileDslRecur stateDsl
 
 compileDsl ::
   forall script x.

diff --git a/src/Cardano/CEM/DSL.hs b/src/Cardano/CEM/DSL.hs
@@ -47,7 +47,7 @@ transitionStateSpines kind spec = concat $ map (sameScriptStateSpinesOfKind kind
       TxConstraint False script ->
       [Spine (State script)]
     sameScriptStateSpinesOfKind xKind constr = case constr of
-      TxFan kind (SameScript state) _ -> [parseSpine state | kind == xKind]
+      TxFan kind (SameScript (MkSameScriptArg state)) _ -> [parseSpine state | kind == xKind]
       If _ t e -> recur t <> recur e
       MatchBySpine _ caseSwitch -> foldMap recur (Map.elems caseSwitch)
       _ -> []

diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs
@@ -74,8 +74,8 @@ instance CEMScript SimpleAuction where
         ( CreateSpine
         ,
           [ MainSignerCoinSelect ctxParams.seller cMinLovelace cEmptyValue
-          , -- , TxFan Out (SameScript $ nullarySpine NotStartedSpine) scriptStateValue
-            TxFan Out (SameScript $ ctxState) scriptStateValue
+          , -- , TxFan Out (SameScript $ MkSameScriptArg ctxState) scriptStateValue
+            TxFan Out (SameScript $ MkSameScriptArg $ nullarySpine @SimpleAuctionState NotStartedSpine) scriptStateValue
           ]
         )
       ,
@@ -85,6 +85,7 @@ instance CEMScript SimpleAuction where
           , TxFan
               Out
               ( SameScript
+                  $ MkSameScriptArg
                   $ cOfSpine CurrentBidSpine [#bid ::= initialBid]
               )
               scriptStateValue
@@ -101,6 +102,7 @@ instance CEMScript SimpleAuction where
           , TxFan
               Out
               ( SameScript
+                  $ MkSameScriptArg
                   $ cOfSpine
                     CurrentBidSpine
                     [#bid ::= ctxTransition.bid]
@@ -116,6 +118,7 @@ instance CEMScript SimpleAuction where
           , TxFan
               Out
               ( SameScript
+                  $ MkSameScriptArg
                   $ cOfSpine WinnerSpine [#bid ::= ctxState.bid]
               )
               scriptStateValue
@@ -160,7 +163,7 @@ instance CEMScript SimpleAuction where
       ownInputInState state =
         TxFan
           In
-          (SameScript $ cUpdateOfSpine' ctxState state)
-          -- (SameScript $  ctxState)
-          -- (SameScript $ Pure $ _ state)
+          (SameScript $ MkSameScriptArg $ cUpdateOfSpine' ctxState state)
+          -- (SameScript $ MkSameScriptArg $ cOfSpine state [])
+          -- (SameScript $ MkSameScriptArg ctxState)
           scriptStateValue
diff --git a/src/Cardano/CEM/Examples/Voting.hs b/src/Cardano/CEM/Examples/Voting.hs
@@ -161,15 +161,15 @@ instance CEMScript SimpleVoting where
       [
         ( CreateSpine
         ,
-          [ TxFan Out (SameScript $ lift NotStarted) cMinLovelace
+          [ TxFan Out (SameScript $ MkSameScriptArg $ lift NotStarted) cMinLovelace
           , MainSignerNoValue ctxParams.creator
           ]
         )
       ,
         ( StartSpine
         ,
-          [ TxFan In (SameScript $ lift NotStarted) cMinLovelace
-          , TxFan Out (SameScript $ lift $ InProgress PMap.empty) cMinLovelace
+          [ TxFan In (SameScript $ MkSameScriptArg $ lift NotStarted) cMinLovelace
+          , TxFan Out (SameScript $ MkSameScriptArg $ lift $ InProgress PMap.empty) cMinLovelace
           , MainSignerNoValue ctxParams.creator
           ]
         )
@@ -185,6 +185,7 @@ instance CEMScript SimpleVoting where
                   , TxFan
                       Out
                       ( SameScript
+                          $ MkSameScriptArg
                           $ cOfSpine
                             InProgressSpine
                             [ #votes
@@ -224,6 +225,7 @@ instance CEMScript SimpleVoting where
           , TxFan
               Out
               ( SameScript
+                  $ MkSameScriptArg
                   $ cOfSpine
                     FinalizedSpine
                     [#votingResult ::= ctxComp.result]
@@ -235,4 +237,4 @@ instance CEMScript SimpleVoting where
       ]
     where
       sameScriptIncOfSpine spine =
-        TxFan In (SameScript $ cUpdateOfSpine ctxState spine []) cMinLovelace
+        TxFan In (SameScript $ MkSameScriptArg $ cUpdateOfSpine ctxState spine []) cMinLovelace
diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs
@@ -210,7 +210,7 @@ process (MkCEMAction params transition) ec = case ec of
         txOutValue txOut == fromPlutusValue value
           && case fanFilter of
             -- FIXME: refactor DRY
-            SameScript state ->
+            SameScript (MkSameScriptArg state) ->
               cemTxOutDatum txOut
                 == Just
                   ( params
@@ -220,7 +220,7 @@ process (MkCEMAction params transition) ec = case ec of
 
       (address, outTxDatum) = case fanFilter of
         UserAddress pkh -> (pubKeyHashAddress pkh, TxOutDatumNone)
-        SameScript state ->
+        SameScript (MkSameScriptArg state) ->
           ( scriptAddress
           , mkInlineDatum
               ( params

diff --git a/src/Cardano/CEM/OnChain.hs b/src/Cardano/CEM/OnChain.hs
@@ -155,7 +155,7 @@ genericPlutarchScript spec code =
                                 #== pfromData (pfield @"address" # txOut)
                            in
                             correctAddress
-                        SameScript expectedState ->
+                        SameScript (MkSameScriptArg expectedState) ->
                           pmatch (pfromData (pfield @"datum" # txOut)) $ \case
                             POutputDatum datum' -> P.do
                               PDatum fanDatum <-

diff --git a/src/Cardano/CEM/Testing/StateMachine.hs b/src/Cardano/CEM/Testing/StateMachine.hs
@@ -9,7 +9,7 @@ module Cardano.CEM.Testing.StateMachine where
 import Prelude
 
 import Cardano.Api (PaymentKey, SigningKey, TxId, Value)
-import Cardano.CEM (CEMScript, CEMScriptTypes (Params, State, Transition), TxConstraint (TxFan), TxFanFilter (SameScript), TxFanKind (Out))
+import Cardano.CEM (CEMScript, CEMScriptTypes (Params, State, Transition), SameScriptArg (MkSameScriptArg), TxConstraint (TxFan), TxFanFilter (SameScript), TxFanKind (Out))
 import Cardano.CEM.DSL (getMainSigner)
 import Cardano.CEM.Monads (
   BlockchainMonadEvent (..),
@@ -219,7 +219,7 @@ instance (CEMScriptArbitrary script) => StateModel (ScriptState script) where
           _ ->
             error
               "Scripts with >1 SameScript outputs are not supported by QD"
-        f (TxFan Out (SameScript outState) _) = Just outState
+        f (TxFan Out (SameScript (MkSameScriptArg outState)) _) = Just outState
         f _ = Nothing
   nextState _ _ _ = error "Unreachable"
 

diff --git a/test/Auction.hs b/test/Auction.hs
@@ -38,6 +38,7 @@ auctionSpec = describe "AuctionSpec" $ do
   it "Wrong transition resolution error" $ execClb $ do
     seller <- (!! 0) <$> getTestWalletSks
     bidder1 <- (!! 1) <$> getTestWalletSks
+
     let
       auctionParams =
         MkAuctionParams