Skip to content

Commit e2407a0

Browse files
author
euonymos
committed
chore: clean-up WIP
1 parent 74f8a3d commit e2407a0

File tree

11 files changed

+63
-81
lines changed

11 files changed

+63
-81
lines changed

‎src/Cardano/CEM.hs‎

Lines changed: 15 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -4,26 +4,18 @@
44
-- FIXME: move all lib functions (`LiftPlutarch`s) to another module
55
module Cardano.CEM where
66

7-
import Prelude
8-
97
import Data.Map qualified as Map
108
import Data.Maybe (fromJust)
9+
import Data.Singletons.TH
10+
import Data.Spine (HasPlutusSpine, HasSpine (..), derivePlutusSpine, spineFieldsNum)
11+
import Data.Text (Text)
1112
import GHC.OverloadedLabels (IsLabel (..))
1213
import GHC.Records (HasField (..))
1314
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
14-
import Unsafe.Coerce (unsafeCoerce)
15-
16-
-- Plutus imports
17-
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
18-
import PlutusLedgerApi.V2 (ToData (..), Value)
19-
import PlutusTx qualified
20-
import PlutusTx.Builtins qualified as PlutusTx
21-
22-
import Data.Singletons.TH
23-
import Data.Text (Text)
2415
import Plutarch (Config (..), (#))
2516
import Plutarch.Builtin (PIsData)
2617
import Plutarch.Evaluate (evalTerm)
18+
import Plutarch.Extras
2719
import Plutarch.LedgerApi (KeyGuarantees (..))
2820
import Plutarch.LedgerApi.Value
2921
import Plutarch.Lift (PUnsafeLiftDecl (..), pconstant, plift)
@@ -37,11 +29,13 @@ import Plutarch.Prelude (
3729
(#&&),
3830
(:-->),
3931
)
32+
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
33+
import PlutusLedgerApi.V2 (ToData (..), Value)
4034
import PlutusLedgerApi.V2.Contexts (TxInfo)
41-
42-
-- Project imports
43-
import Data.Spine (HasPlutusSpine, HasSpine (..), derivePlutusSpine, spineFieldsNum)
44-
import Plutarch.Extras
35+
import PlutusTx qualified
36+
import PlutusTx.Builtins qualified as PlutusTx
37+
import Unsafe.Coerce (unsafeCoerce)
38+
import Prelude
4539

4640
data CVar = CParams | CState | CTransition | CComp | CTxInfo
4741
deriving stock (Show)
@@ -60,18 +54,18 @@ type family DSLPattern (resolved :: Bool) script value where
6054
data TxFanKind = In | InRef | Out
6155
deriving stock (Prelude.Eq, Prelude.Show)
6256

63-
data TxFanFilterNew (resolved :: Bool) script
57+
data TxFanFilter (resolved :: Bool) script
6458
= UserAddress (DSLValue resolved script PubKeyHash)
6559
| -- FIXME: should have spine been specified known statically
6660
SameScript (DSLValue resolved script (State script))
6761

68-
deriving stock instance (CEMScript script) => (Show (TxFanFilterNew True script))
69-
deriving stock instance (Show (TxFanFilterNew False script))
62+
deriving stock instance (CEMScript script) => (Show (TxFanFilter True script))
63+
deriving stock instance (Show (TxFanFilter False script))
7064

7165
data TxConstraint (resolved :: Bool) script
7266
= TxFan
7367
{ kind :: TxFanKind
74-
, cFilter :: TxFanFilterNew resolved script
68+
, cFilter :: TxFanFilter resolved script
7569
, value :: DSLValue resolved script Value
7670
}
7771
| MainSignerCoinSelect
@@ -479,7 +473,7 @@ type CEMScriptSpec resolved script =
479473
[TxConstraint resolved script]
480474
)
481475

482-
data CompilationConfig = MkCompilationConfig
476+
newtype CompilationConfig = MkCompilationConfig
483477
{ errorCodesPrefix :: String
484478
}
485479

‎src/Cardano/CEM/Address.hs‎

Lines changed: 3 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -31,25 +31,23 @@ cardanoAddressBech32 = MkAddressBech32 . Cardano.Api.serialiseToBech32
3131
scriptCardanoAddress ::
3232
forall script.
3333
(Compiled.CEMScriptCompiled script) =>
34-
Proxy script ->
3534
Cardano.Api.Ledger.Network ->
35+
Proxy script ->
3636
Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr)
37-
scriptCardanoAddress p network =
37+
scriptCardanoAddress network =
3838
plutusAddressToShelleyAddress network
3939
. flip PlutusLedgerApi.V1.Address Nothing
4040
. scriptCredential
41-
$ p
4241

4342
scriptCredential ::
4443
forall script.
4544
(Compiled.CEMScriptCompiled script) =>
4645
Proxy script ->
4746
PlutusLedgerApi.V1.Credential
48-
scriptCredential p =
47+
scriptCredential =
4948
PlutusLedgerApi.V1.ScriptCredential
5049
. scriptHash
5150
. Compiled.cemScriptCompiled
52-
$ p
5351

5452
plutusAddressToShelleyAddress ::
5553
Cardano.Api.Ledger.Network ->

‎src/Cardano/CEM/DSL.hs‎

Lines changed: 8 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,15 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
2-
{-# LANGUAGE RecordWildCards #-}
32

43
module Cardano.CEM.DSL where
54

6-
import Prelude
7-
8-
import Data.Map qualified as Map
9-
10-
import Data.Text (pack, unpack)
11-
import Text.Show.Pretty (ppShowList)
12-
135
import Cardano.CEM
6+
import Data.Map qualified as Map
147
import Data.Maybe (listToMaybe, mapMaybe)
158
import Data.Spine (HasSpine (..))
9+
import Data.Text (pack, unpack)
1610
import PlutusLedgerApi.V1 (PubKeyHash)
11+
import Text.Show.Pretty (ppShowList)
12+
import Prelude
1713

1814
-- Generic check datatypes
1915

@@ -44,11 +40,9 @@ sameScriptStateSpinesOfKind ::
4440
TxConstraint False script ->
4541
[Spine (State script)]
4642
sameScriptStateSpinesOfKind xKind constr = case constr of
47-
TxFan kind (SameScript state) _ ->
48-
if kind == xKind then [parseSpine state] else []
49-
If _ t e -> recur t <> (recur e)
50-
MatchBySpine _ caseSwitch ->
51-
foldMap recur (Map.elems caseSwitch)
43+
TxFan kind (SameScript state) _ -> [parseSpine state | kind == xKind]
44+
If _ t e -> recur t <> recur e
45+
MatchBySpine _ caseSwitch -> foldMap recur (Map.elems caseSwitch)
5246
_ -> []
5347
where
5448
recur = sameScriptStateSpinesOfKind xKind
@@ -58,8 +52,7 @@ sameScriptStateSpinesOfKind xKind constr = case constr of
5852
parseSpine (UnsafeOfSpine spine _) = spine
5953
parseSpine (UnsafeUpdateOfSpine _ spine _) = spine
6054
-- FIXME: yet another not-properly DSL type encoded place
61-
parseSpine _ =
62-
error "SameScript is too complex to statically know its spine"
55+
parseSpine _ = error "SameScript is too complex to statically know its spine"
6356

6457
isSameScriptOfKind :: TxFanKind -> TxConstraint resolved script -> CheckResult
6558
isSameScriptOfKind xKind constr = case constr of

‎src/Cardano/CEM/Documentation.hs‎

Lines changed: 23 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,37 +1,26 @@
1-
module Cardano.CEM.Documentation (cemDotGraphString) where
2-
3-
import Prelude
1+
module Cardano.CEM.Documentation (genCemGraph) where
42

3+
import Cardano.CEM (
4+
CEMScript (perTransitionScriptSpec),
5+
CEMScriptTypes (Transition),
6+
TxFanKind (In, Out),
7+
)
8+
import Cardano.CEM.DSL (transitionStateSpines)
59
import Data.Foldable (fold)
610
import Data.Map qualified as Map
711
import Data.Proxy
8-
9-
import Cardano.CEM
10-
import Cardano.CEM.DSL (transitionStateSpines)
1112
import Data.Spine (allSpines)
13+
import Prelude
1214

13-
dotStyling :: String
14-
dotStyling =
15-
"rankdir=LR;\n"
16-
<> "node [shape=\"dot\",fontsize=14,fixedsize=true,width=1.5];\n"
17-
<> "edge [fontsize=11];\n"
18-
<> "\"Void In\" [color=\"orange\"];\n"
19-
<> "\"Void Out\" [color=\"orange\"];\n"
20-
21-
-- FIXME: cover with golden test
22-
cemDotGraphString ::
23-
forall script. (CEMScript script) => String -> Proxy script -> String
24-
cemDotGraphString name _proxy =
15+
genCemGraph :: forall script. (CEMScript script) => String -> Proxy script -> String
16+
genCemGraph name _proxy =
2517
"digraph "
2618
<> name
2719
<> " {\n"
2820
<> dotStyling
2921
<> edges
3022
<> "}"
3123
where
32-
showSpine :: (Show s) => s -> String
33-
showSpine = stripSpineSuffix . show
34-
stripSpineSuffix = reverse . drop 5 . reverse
3524
edges =
3625
fold $
3726
[ from
@@ -49,3 +38,16 @@ cemDotGraphString name _proxy =
4938
perTransitionScriptSpec @script Map.! transition of
5039
[] -> ["\"Void " <> show kind <> "\""]
5140
x -> map showSpine x
41+
42+
showSpine :: (Show s) => s -> String
43+
showSpine = stripSpineSuffix . show
44+
45+
stripSpineSuffix = reverse . drop 5 . reverse
46+
47+
dotStyling :: String
48+
dotStyling =
49+
"rankdir=LR;\n"
50+
<> "node [shape=\"dot\",fontsize=14,fixedsize=true,width=1.5];\n"
51+
<> "edge [fontsize=11];\n"
52+
<> "\"Void In\" [color=\"orange\"];\n"
53+
<> "\"Void Out\" [color=\"orange\"];\n"

‎src/Cardano/CEM/Examples/Auction.hs‎

Lines changed: 6 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -3,20 +3,16 @@
33

44
module Cardano.CEM.Examples.Auction where
55

6-
import PlutusTx.Prelude
7-
import Prelude qualified
8-
6+
import Cardano.CEM
7+
import Cardano.CEM.TH (deriveCEMAssociatedTypes)
98
import Data.Map qualified as Map
10-
9+
import Data.Spine (derivePlutusSpine)
1110
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
1211
import PlutusLedgerApi.V2 (Value)
12+
import PlutusTx.Prelude
13+
import Prelude qualified
1314

14-
import Cardano.CEM
15-
import Cardano.CEM.TH (deriveCEMAssociatedTypes)
16-
import Data.Spine
17-
18-
-- Simple no-deposit auction
19-
15+
-- | Simple no-deposit auction
2016
data SimpleAuction
2117

2218
data Bid = MkBet

‎src/Cardano/CEM/Indexing/Event.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -76,8 +76,8 @@ extractEvent ::
7676
Tx ->
7777
IO (Maybe (IndexerEvent script))
7878
extractEvent network tx = do
79-
-- Script payemnt credential based predicate
80-
let ~(Right scriptAddr) = Address.scriptCardanoAddress (Proxy @script) network
79+
-- Script payment credential based predicate
80+
let ~(Right scriptAddr) = Address.scriptCardanoAddress network (Proxy @script)
8181
let cPred = hasAddr scriptAddr
8282

8383
-- Source state

‎src/Cardano/CEM/Indexing/Oura.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -68,7 +68,7 @@ ouraMonitoringScript p network sourcePath sinkPath =
6868
. pure
6969
. selectByAddress
7070
. Address.cardanoAddressBech32
71-
<$> Address.scriptCardanoAddress p network
71+
<$> Address.scriptCardanoAddress network p
7272

7373
cursor :: Toml.Table
7474
cursor =

‎src/Cardano/CEM/TH.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,7 @@ deriveCEMAssociatedTypes _deriveBlueprint scriptName = do
7676

7777
compileCEM :: Bool -> Name -> Q [Dec]
7878
compileCEM debugBuild name = do
79-
-- FIXIT: two duplicating cases on `transitionComp`
79+
-- TODO: two duplicating cases on `transitionComp`
8080
let plutusScript =
8181
[|
8282
\a b c -> case transitionComp @($(conT name)) of

‎src/Cardano/CEM/Testing/StateMachine.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ module Cardano.CEM.Testing.StateMachine where
99
import Prelude
1010

1111
import Cardano.Api (PaymentKey, SigningKey, TxId, Value)
12-
import Cardano.CEM (CEMScript, CEMScriptTypes (Params, State, Transition), TxConstraint (TxFan), TxFanFilterNew (SameScript), TxFanKind (Out))
12+
import Cardano.CEM (CEMScript, CEMScriptTypes (Params, State, Transition), TxConstraint (TxFan), TxFanFilter (SameScript), TxFanKind (Out))
1313
import Cardano.CEM.DSL (getMainSigner)
1414
import Cardano.CEM.Monads (
1515
BlockchainMonadEvent (..),

‎test/Main.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,8 @@ import Test.Hspec (hspec, runIO)
88

99
import Auction (auctionSpec)
1010
import Data.Maybe (isJust)
11-
import Dynamic (dynamicSpec)
11+
12+
-- import Dynamic (dynamicSpec)
1213
import OffChain (offChainSpec)
1314
import OuraFilters.Simple (simpleSpec)
1415
import System.Environment (lookupEnv)
@@ -22,7 +23,7 @@ main = do
2223
auctionSpec
2324
votingSpec
2425
offChainSpec
25-
dynamicSpec
26+
-- dynamicSpec
2627
if runIndexing
2728
then do
2829
-- These tests are not currently supported on CI

0 commit comments

Comments
 (0)