From e2407a02941193d4c98c9790c467f7773eb67a9a Mon Sep 17 00:00:00 2001 From: euonymos Date: Tue, 10 Dec 2024 16:43:12 -0600 Subject: [PATCH] chore: clean-up WIP --- src/Cardano/CEM.hs | 36 +++++++++----------- src/Cardano/CEM/Address.hs | 8 ++--- src/Cardano/CEM/DSL.hs | 23 +++++-------- src/Cardano/CEM/Documentation.hs | 44 +++++++++++++------------ src/Cardano/CEM/Examples/Auction.hs | 16 ++++----- src/Cardano/CEM/Indexing/Event.hs | 4 +-- src/Cardano/CEM/Indexing/Oura.hs | 2 +- src/Cardano/CEM/TH.hs | 2 +- src/Cardano/CEM/Testing/StateMachine.hs | 2 +- test/Main.hs | 5 +-- test/OuraFilters/Auction.hs | 2 -- 11 files changed, 63 insertions(+), 81 deletions(-) diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index 70b4554..6780911 100644 --- a/src/Cardano/CEM.hs +++ b/src/Cardano/CEM.hs @@ -4,26 +4,18 @@ -- FIXME: move all lib functions (`LiftPlutarch`s) to another module module Cardano.CEM where -import Prelude - import Data.Map qualified as Map import Data.Maybe (fromJust) +import Data.Singletons.TH +import Data.Spine (HasPlutusSpine, HasSpine (..), derivePlutusSpine, spineFieldsNum) +import Data.Text (Text) import GHC.OverloadedLabels (IsLabel (..)) import GHC.Records (HasField (..)) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import Unsafe.Coerce (unsafeCoerce) - --- Plutus imports -import PlutusLedgerApi.V1.Crypto (PubKeyHash) -import PlutusLedgerApi.V2 (ToData (..), Value) -import PlutusTx qualified -import PlutusTx.Builtins qualified as PlutusTx - -import Data.Singletons.TH -import Data.Text (Text) import Plutarch (Config (..), (#)) import Plutarch.Builtin (PIsData) import Plutarch.Evaluate (evalTerm) +import Plutarch.Extras import Plutarch.LedgerApi (KeyGuarantees (..)) import Plutarch.LedgerApi.Value import Plutarch.Lift (PUnsafeLiftDecl (..), pconstant, plift) @@ -37,11 +29,13 @@ import Plutarch.Prelude ( (#&&), (:-->), ) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V2 (ToData (..), Value) import PlutusLedgerApi.V2.Contexts (TxInfo) - --- Project imports -import Data.Spine (HasPlutusSpine, HasSpine (..), derivePlutusSpine, spineFieldsNum) -import Plutarch.Extras +import PlutusTx qualified +import PlutusTx.Builtins qualified as PlutusTx +import Unsafe.Coerce (unsafeCoerce) +import Prelude data CVar = CParams | CState | CTransition | CComp | CTxInfo deriving stock (Show) @@ -60,18 +54,18 @@ type family DSLPattern (resolved :: Bool) script value where data TxFanKind = In | InRef | Out deriving stock (Prelude.Eq, Prelude.Show) -data TxFanFilterNew (resolved :: Bool) script +data TxFanFilter (resolved :: Bool) script = UserAddress (DSLValue resolved script PubKeyHash) | -- FIXME: should have spine been specified known statically SameScript (DSLValue resolved script (State script)) -deriving stock instance (CEMScript script) => (Show (TxFanFilterNew True script)) -deriving stock instance (Show (TxFanFilterNew False script)) +deriving stock instance (CEMScript script) => (Show (TxFanFilter True script)) +deriving stock instance (Show (TxFanFilter False script)) data TxConstraint (resolved :: Bool) script = TxFan { kind :: TxFanKind - , cFilter :: TxFanFilterNew resolved script + , cFilter :: TxFanFilter resolved script , value :: DSLValue resolved script Value } | MainSignerCoinSelect @@ -479,7 +473,7 @@ type CEMScriptSpec resolved script = [TxConstraint resolved script] ) -data CompilationConfig = MkCompilationConfig +newtype CompilationConfig = MkCompilationConfig { errorCodesPrefix :: String } diff --git a/src/Cardano/CEM/Address.hs b/src/Cardano/CEM/Address.hs index 8e6596d..20e9a92 100644 --- a/src/Cardano/CEM/Address.hs +++ b/src/Cardano/CEM/Address.hs @@ -31,25 +31,23 @@ cardanoAddressBech32 = MkAddressBech32 . Cardano.Api.serialiseToBech32 scriptCardanoAddress :: forall script. (Compiled.CEMScriptCompiled script) => - Proxy script -> Cardano.Api.Ledger.Network -> + Proxy script -> Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr) -scriptCardanoAddress p network = +scriptCardanoAddress network = plutusAddressToShelleyAddress network . flip PlutusLedgerApi.V1.Address Nothing . scriptCredential - $ p scriptCredential :: forall script. (Compiled.CEMScriptCompiled script) => Proxy script -> PlutusLedgerApi.V1.Credential -scriptCredential p = +scriptCredential = PlutusLedgerApi.V1.ScriptCredential . scriptHash . Compiled.cemScriptCompiled - $ p plutusAddressToShelleyAddress :: Cardano.Api.Ledger.Network -> diff --git a/src/Cardano/CEM/DSL.hs b/src/Cardano/CEM/DSL.hs index bbdf0f9..ee217b5 100644 --- a/src/Cardano/CEM/DSL.hs +++ b/src/Cardano/CEM/DSL.hs @@ -1,19 +1,15 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RecordWildCards #-} module Cardano.CEM.DSL where -import Prelude - -import Data.Map qualified as Map - -import Data.Text (pack, unpack) -import Text.Show.Pretty (ppShowList) - import Cardano.CEM +import Data.Map qualified as Map import Data.Maybe (listToMaybe, mapMaybe) import Data.Spine (HasSpine (..)) +import Data.Text (pack, unpack) import PlutusLedgerApi.V1 (PubKeyHash) +import Text.Show.Pretty (ppShowList) +import Prelude -- Generic check datatypes @@ -44,11 +40,9 @@ sameScriptStateSpinesOfKind :: TxConstraint False script -> [Spine (State script)] sameScriptStateSpinesOfKind xKind constr = case constr of - TxFan kind (SameScript state) _ -> - if kind == xKind then [parseSpine state] else [] - If _ t e -> recur t <> (recur e) - MatchBySpine _ caseSwitch -> - foldMap recur (Map.elems caseSwitch) + TxFan kind (SameScript state) _ -> [parseSpine state | kind == xKind] + If _ t e -> recur t <> recur e + MatchBySpine _ caseSwitch -> foldMap recur (Map.elems caseSwitch) _ -> [] where recur = sameScriptStateSpinesOfKind xKind @@ -58,8 +52,7 @@ sameScriptStateSpinesOfKind xKind constr = case constr of parseSpine (UnsafeOfSpine spine _) = spine parseSpine (UnsafeUpdateOfSpine _ spine _) = spine -- FIXME: yet another not-properly DSL type encoded place - parseSpine _ = - error "SameScript is too complex to statically know its spine" + parseSpine _ = error "SameScript is too complex to statically know its spine" isSameScriptOfKind :: TxFanKind -> TxConstraint resolved script -> CheckResult isSameScriptOfKind xKind constr = case constr of diff --git a/src/Cardano/CEM/Documentation.hs b/src/Cardano/CEM/Documentation.hs index 4e1a7f2..480756d 100644 --- a/src/Cardano/CEM/Documentation.hs +++ b/src/Cardano/CEM/Documentation.hs @@ -1,27 +1,19 @@ -module Cardano.CEM.Documentation (cemDotGraphString) where - -import Prelude +module Cardano.CEM.Documentation (genCemGraph) where +import Cardano.CEM ( + CEMScript (perTransitionScriptSpec), + CEMScriptTypes (Transition), + TxFanKind (In, Out), + ) +import Cardano.CEM.DSL (transitionStateSpines) import Data.Foldable (fold) import Data.Map qualified as Map import Data.Proxy - -import Cardano.CEM -import Cardano.CEM.DSL (transitionStateSpines) import Data.Spine (allSpines) +import Prelude -dotStyling :: String -dotStyling = - "rankdir=LR;\n" - <> "node [shape=\"dot\",fontsize=14,fixedsize=true,width=1.5];\n" - <> "edge [fontsize=11];\n" - <> "\"Void In\" [color=\"orange\"];\n" - <> "\"Void Out\" [color=\"orange\"];\n" - --- FIXME: cover with golden test -cemDotGraphString :: - forall script. (CEMScript script) => String -> Proxy script -> String -cemDotGraphString name _proxy = +genCemGraph :: forall script. (CEMScript script) => String -> Proxy script -> String +genCemGraph name _proxy = "digraph " <> name <> " {\n" @@ -29,9 +21,6 @@ cemDotGraphString name _proxy = <> edges <> "}" where - showSpine :: (Show s) => s -> String - showSpine = stripSpineSuffix . show - stripSpineSuffix = reverse . drop 5 . reverse edges = fold $ [ from @@ -49,3 +38,16 @@ cemDotGraphString name _proxy = perTransitionScriptSpec @script Map.! transition of [] -> ["\"Void " <> show kind <> "\""] x -> map showSpine x + + showSpine :: (Show s) => s -> String + showSpine = stripSpineSuffix . show + + stripSpineSuffix = reverse . drop 5 . reverse + + dotStyling :: String + dotStyling = + "rankdir=LR;\n" + <> "node [shape=\"dot\",fontsize=14,fixedsize=true,width=1.5];\n" + <> "edge [fontsize=11];\n" + <> "\"Void In\" [color=\"orange\"];\n" + <> "\"Void Out\" [color=\"orange\"];\n" diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index b368923..fc23de4 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -3,20 +3,16 @@ module Cardano.CEM.Examples.Auction where -import PlutusTx.Prelude -import Prelude qualified - +import Cardano.CEM +import Cardano.CEM.TH (deriveCEMAssociatedTypes) import Data.Map qualified as Map - +import Data.Spine (derivePlutusSpine) import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V2 (Value) +import PlutusTx.Prelude +import Prelude qualified -import Cardano.CEM -import Cardano.CEM.TH (deriveCEMAssociatedTypes) -import Data.Spine - --- Simple no-deposit auction - +-- | Simple no-deposit auction data SimpleAuction data Bid = MkBet diff --git a/src/Cardano/CEM/Indexing/Event.hs b/src/Cardano/CEM/Indexing/Event.hs index f57ad6f..32b38c0 100644 --- a/src/Cardano/CEM/Indexing/Event.hs +++ b/src/Cardano/CEM/Indexing/Event.hs @@ -76,8 +76,8 @@ extractEvent :: Tx -> IO (Maybe (IndexerEvent script)) extractEvent network tx = do - -- Script payemnt credential based predicate - let ~(Right scriptAddr) = Address.scriptCardanoAddress (Proxy @script) network + -- Script payment credential based predicate + let ~(Right scriptAddr) = Address.scriptCardanoAddress network (Proxy @script) let cPred = hasAddr scriptAddr -- Source state diff --git a/src/Cardano/CEM/Indexing/Oura.hs b/src/Cardano/CEM/Indexing/Oura.hs index 4f2d9cb..4494db3 100644 --- a/src/Cardano/CEM/Indexing/Oura.hs +++ b/src/Cardano/CEM/Indexing/Oura.hs @@ -68,7 +68,7 @@ ouraMonitoringScript p network sourcePath sinkPath = . pure . selectByAddress . Address.cardanoAddressBech32 - <$> Address.scriptCardanoAddress p network + <$> Address.scriptCardanoAddress network p cursor :: Toml.Table cursor = diff --git a/src/Cardano/CEM/TH.hs b/src/Cardano/CEM/TH.hs index 1e78329..8b290b7 100644 --- a/src/Cardano/CEM/TH.hs +++ b/src/Cardano/CEM/TH.hs @@ -76,7 +76,7 @@ deriveCEMAssociatedTypes _deriveBlueprint scriptName = do compileCEM :: Bool -> Name -> Q [Dec] compileCEM debugBuild name = do - -- FIXIT: two duplicating cases on `transitionComp` + -- TODO: two duplicating cases on `transitionComp` let plutusScript = [| \a b c -> case transitionComp @($(conT name)) of diff --git a/src/Cardano/CEM/Testing/StateMachine.hs b/src/Cardano/CEM/Testing/StateMachine.hs index 45e4072..d41cba8 100644 --- 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), TxFanFilterNew (SameScript), TxFanKind (Out)) +import Cardano.CEM (CEMScript, CEMScriptTypes (Params, State, Transition), TxConstraint (TxFan), TxFanFilter (SameScript), TxFanKind (Out)) import Cardano.CEM.DSL (getMainSigner) import Cardano.CEM.Monads ( BlockchainMonadEvent (..), diff --git a/test/Main.hs b/test/Main.hs index be00a5f..61e9c92 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,7 +8,8 @@ import Test.Hspec (hspec, runIO) import Auction (auctionSpec) import Data.Maybe (isJust) -import Dynamic (dynamicSpec) + +-- import Dynamic (dynamicSpec) import OffChain (offChainSpec) import OuraFilters.Simple (simpleSpec) import System.Environment (lookupEnv) @@ -22,7 +23,7 @@ main = do auctionSpec votingSpec offChainSpec - dynamicSpec + -- dynamicSpec if runIndexing then do -- These tests are not currently supported on CI diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 3b8502b..f568103 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -8,7 +8,6 @@ import Cardano.CEM.Examples.Auction qualified as Auction import Cardano.CEM.Examples.Compilation () import Cardano.CEM.Indexing.Oura qualified as OuraConfig import Cardano.CEM.Indexing.Tx qualified as Tx -import Cardano.CEM.OnChain qualified as Compiled import Cardano.Ledger.BaseTypes qualified as Ledger import Control.Lens ((%~), (.~)) import Control.Monad ((>=>)) @@ -20,7 +19,6 @@ import Data.Data (Proxy (Proxy)) import Data.Text qualified as T import Oura.Communication qualified as Oura import OuraFilters.Mock qualified as Mock -import Plutus.Extras (scriptValidatorHash) import PlutusLedgerApi.V1 qualified import System.Process (ProcessHandle) import Test.Hspec (describe, focus, it, shouldBe)