From 0b866c97e713f7abd1684ce656aa06d0af7ebcf9 Mon Sep 17 00:00:00 2001
From: euonymos <ilia@mlabs.city>
Date: Mon, 16 Dec 2024 13:27:28 -0600
Subject: [PATCH] chore: refactor Cardano.CEM.Compile module

---
 example/CEM/Example/Compiled.hs |  4 +--
 src/Cardano/CEM.hs              | 11 ++++--
 src/Cardano/CEM/Compile.hs      | 61 ++++++++++++++++++---------------
 src/Cardano/CEM/Indexing.hs     |  8 ++---
 src/Cardano/CEM/TH.hs           |  6 ++--
 5 files changed, 52 insertions(+), 38 deletions(-)

diff --git a/example/CEM/Example/Compiled.hs b/example/CEM/Example/Compiled.hs
index e843026..6e3cf8f 100644
--- a/example/CEM/Example/Compiled.hs
+++ b/example/CEM/Example/Compiled.hs
@@ -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)
diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs
index 79b560a..0b8c942 100644
--- a/src/Cardano/CEM.hs
+++ b/src/Cardano/CEM.hs
@@ -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 (..),
@@ -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)
diff --git a/src/Cardano/CEM/Compile.hs b/src/Cardano/CEM/Compile.hs
index 888dc8d..212e1f5 100644
--- a/src/Cardano/CEM/Compile.hs
+++ b/src/Cardano/CEM/Compile.hs
@@ -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
@@ -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
diff --git a/src/Cardano/CEM/Indexing.hs b/src/Cardano/CEM/Indexing.hs
index 907130a..5b0ecd9 100644
--- a/src/Cardano/CEM/Indexing.hs
+++ b/src/Cardano/CEM/Indexing.hs
@@ -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
\ No newline at end of file
+import Cardano.CEM.Indexing.Tx as X
diff --git a/src/Cardano/CEM/TH.hs b/src/Cardano/CEM/TH.hs
index 357fb47..6560693 100644
--- a/src/Cardano/CEM/TH.hs
+++ b/src/Cardano/CEM/TH.hs
@@ -1,6 +1,6 @@
 module Cardano.CEM.TH (
   deriveCEMAssociatedTypes,
-  compileCEM,
+  compileCEMOnchain,
 ) where
 
 import Cardano.CEM.Compile (preProcessForOnChainCompilation)
@@ -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 =
         [|