Skip to content

Commit

Permalink
chore: refactor Cardano.CEM.Compile module
Browse files Browse the repository at this point in the history
  • Loading branch information
euonymos committed Dec 16, 2024
1 parent a352f62 commit 0b866c9
Show file tree
Hide file tree
Showing 5 changed files with 52 additions and 38 deletions.
4 changes: 2 additions & 2 deletions example/CEM/Example/Compiled.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,5 +10,5 @@ import CEM.Example.Voting (SimpleVoting)
import Cardano.CEM
import Prelude

$(compileCEM True ''SimpleAuction)
$(compileCEM False ''SimpleVoting)
$(compileCEMOnchain True ''SimpleAuction)
$(compileCEMOnchain False ''SimpleVoting)
11 changes: 9 additions & 2 deletions src/Cardano/CEM.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,11 @@ module Cardano.CEM (

-- TODO: review

import Cardano.CEM.Address as X (cemScriptPlutusCredential)
import Cardano.CEM.Address as X (
cemScriptAddress,
cemScriptPlutusAddress,
cemScriptPlutusCredential,
)
import Cardano.CEM.Compile as X
import Cardano.CEM.DSL as X (
CEMScript (..),
Expand All @@ -19,5 +23,8 @@ import Cardano.CEM.Monads as X
import Cardano.CEM.Monads.CLB as X
import Cardano.CEM.OffChain as X
import Cardano.CEM.OnChain as X
import Cardano.CEM.TH as X (compileCEM, deriveCEMAssociatedTypes)
import Cardano.CEM.TH as X (
compileCEMOnchain,
deriveCEMAssociatedTypes,
)
import Data.Spine as X (derivePlutusSpine)
61 changes: 34 additions & 27 deletions src/Cardano/CEM/Compile.hs
Original file line number Diff line number Diff line change
Expand Up @@ -72,29 +72,54 @@ transitionStateSpines kind spec = concat $ map ownUtxoState spec
-- and smart constructors.
parseSpine _ = error "SameScript is too complex to statically know its spine"

-- | Checking for errors and normalising
-- -----------------------------------------------------------------------------
-- Some preliminary checks
-- -----------------------------------------------------------------------------

-- Checks are based on this pseudo-lattice ordering.
data CheckResult = Yes | No | Maybe
deriving stock (Eq, Show)

opposite :: Ordering -> Ordering
opposite EQ = EQ
opposite LT = GT
opposite GT = LT

instance Ord CheckResult where
compare Yes No = EQ
compare Yes Maybe = GT
compare No Maybe = GT
compare Yes Yes = EQ
compare No No = EQ
compare Maybe Maybe = EQ
compare x y = opposite $ compare y x

{- | Performs some preliminary checks over the CEM script specification:
* there is only one initial transition
* every transition has zero or one `In` state
-}
preProcessForOnChainCompilation ::
(CEMScript script, Show a) =>
Map.Map a [TxConstraint False script] ->
Map.Map a [TxConstraint False script]
preProcessForOnChainCompilation spec =
if length possibleCreators == 1
if length initialTransitions == 1
then
let
-- FIXME: relies on `error` inside...
-- PM relies on `error` inside transitionInStateSpine
!_ = map transitionInStateSpine $ Map.elems spec
in
spec
else
error $
"CEMScript should have exactly 1 creating transition, "
<> "while possible creators are "
<> ppShowList possibleCreators
"CEMScript must have exactly one initial transition, "
<> "while there are many ones: "
<> ppShowList initialTransitions
where
possibleCreators = filter (maybeIsCreator . snd) (Map.toList spec)
initialTransitions = filter (isInitial . snd) (Map.toList spec)

maybeIsCreator :: [TxConstraint resolved script] -> Bool
maybeIsCreator constrs =
isInitial :: [TxConstraint resolved script] -> Bool
isInitial constrs =
not (maybeHasSameScriptFanOfKind In)
&& maybeHasSameScriptFanOfKind Out
where
Expand All @@ -111,21 +136,3 @@ preProcessForOnChainCompilation spec =
_ -> No
where
recur = isSameScriptOfKind xKind

-- | We have abstract interpretator at home
data CheckResult = Yes | No | Maybe
deriving stock (Eq, Show)

opposite :: Ordering -> Ordering
opposite EQ = EQ
opposite LT = GT
opposite GT = LT

instance Ord CheckResult where
compare Yes No = EQ
compare Yes Maybe = GT
compare No Maybe = GT
compare Yes Yes = EQ
compare No No = EQ
compare Maybe Maybe = EQ
compare x y = opposite $ compare y x
8 changes: 4 additions & 4 deletions src/Cardano/CEM/Indexing.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
module Cardano.CEM.Indexing
( module X
) where
module Cardano.CEM.Indexing (
module X,
) where

import Cardano.CEM.Indexing.Event as X
import Cardano.CEM.Indexing.Oura as X
import Cardano.CEM.Indexing.Tx as X
import Cardano.CEM.Indexing.Tx as X
6 changes: 3 additions & 3 deletions src/Cardano/CEM/TH.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
module Cardano.CEM.TH (
deriveCEMAssociatedTypes,
compileCEM,
compileCEMOnchain,
) where

import Cardano.CEM.Compile (preProcessForOnChainCompilation)
Expand Down Expand Up @@ -49,8 +49,8 @@ deriveCEMAssociatedTypes _deriveBlueprint scriptName = do
reifyInstances familyName [argType]
return name

compileCEM :: Bool -> Name -> Q [Dec]
compileCEM debugBuild name = do
compileCEMOnchain :: Bool -> Name -> Q [Dec]
compileCEMOnchain debugBuild name = do
-- TODO: two duplicating cases on `transitionComp`
let plutusScript =
[|
Expand Down

0 comments on commit 0b866c9

Please sign in to comment.