Merge pull request mlabs-haskell#53 from mlabs-haskell/uhbif19/fixup-…

…basic-graph-rendering

Fixup: commit missing changes for graph support

cem-script.cabal

@@ -161,7 +161,7 @@ library
   hs-source-dirs:  src/
   exposed-modules:
     Cardano.CEM
-    Cardano.CEM.Documentaiton
+    Cardano.CEM.Documentation
     Cardano.CEM.Examples.Auction
     Cardano.CEM.Examples.Compilation
     Cardano.CEM.Examples.Voting

src-lib/data-spine/Data/Spine.hs

@@ -23,6 +23,7 @@ import Data.Singletons
 -}
 class
   ( Ord (Spine sop)
+  , Show (Spine sop)
   ) =>
   HasSpine sop
   where
@@ -110,7 +111,7 @@ deriveSpine name = do
     suffix = "Spine"
     spineName = addSuffix name suffix
     spineTypeQ = reifyType spineName
-  spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum]
+  spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show]
   -- TODO: derive Sing
   -- TODO: derive HasField (OfSpine ...)
 

src/Cardano/CEM.hs

@@ -81,6 +81,7 @@ class
   ( HasSpine (Transition script)
   , HasSpine (State script)
   , Stages (Stage script)
+  , Show (Stage script)
   ) =>
   CEMScript script
   where
@@ -101,12 +102,16 @@ class
   -- | Transitions for deterministic CEM-machine
   type Transition script = transition | transition -> script
 
-  -- | Each kind of Transition has statically associated Stage and State spine
+  -- | Each kind of Transition has statically associated Stage
+  -- from/to `State`s spines
   transitionStage ::
     Proxy script ->
     Map.Map
       (Spine (Transition script))
-      (Stage script, Maybe (Spine (State script)))
+      ( Stage script
+      , Maybe (Spine (State script))
+      , Maybe (Spine (State script))
+      )
 
   -- This functions define domain logic
   transitionSpec ::

src/Cardano/CEM/Examples/Auction.hs

@@ -86,11 +86,11 @@ instance CEMScript SimpleAuction where
 
   transitionStage Proxy =
     Map.fromList
-      [ (CreateSpine, (Open, Nothing))
-      , (StartSpine, (Open, Just NotStartedSpine))
-      , (MakeBidSpine, (Open, Just CurrentBidSpine))
-      , (CloseSpine, (Closed, Just CurrentBidSpine))
-      , (BuyoutSpine, (Closed, Just WinnerSpine))
+      [ (CreateSpine, (Open, Nothing, Just NotStartedSpine))
+      , (StartSpine, (Open, Just NotStartedSpine, Just CurrentBidSpine))
+      , (MakeBidSpine, (Open, Just CurrentBidSpine, Just CurrentBidSpine))
+      , (CloseSpine, (Closed, Just CurrentBidSpine, Just WinnerSpine))
+      , (BuyoutSpine, (Closed, Just WinnerSpine, Nothing))
       ]
 
   {-# INLINEABLE transitionSpec #-}

src/Cardano/CEM/Examples/Voting.hs

@@ -108,10 +108,10 @@ instance CEMScript SimpleVoting where
 
   transitionStage _ =
     Map.fromList
-      [ (CreateSpine, (Always, Nothing))
-      , (StartSpine, (Always, Just NotStartedSpine))
-      , (VoteSpine, (Always, Just InProgressSpine))
-      , (FinalizeSpine, (Always, Just InProgressSpine))
+      [ (CreateSpine, (Always, Nothing, Just NotStartedSpine))
+      , (StartSpine, (Always, Just NotStartedSpine, Just InProgressSpine))
+      , (VoteSpine, (Always, Just InProgressSpine, Just InProgressSpine))
+      , (FinalizeSpine, (Always, Just InProgressSpine, Nothing))
       ]
 
   {-# INLINEABLE transitionSpec #-}

src/Cardano/CEM/OffChain.hs

@@ -201,7 +201,7 @@ resolveAction
       let
         -- TODO
         mScriptTxIn = case transitionStage (Proxy :: Proxy script) Map.! getSpine transition of
-          (_, Nothing) -> Nothing
+          (_, Nothing, _) -> Nothing
           _ -> mScriptTxIn'
         mState = cemTxOutState =<< snd <$> mScriptTxIn
         witnesedScriptTxIns =