feat: parse transition spines from transactions WIP

src/Cardano/CEM/Examples/Auction.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-}
 {-# LANGUAGE NoPolyKinds #-}
 
 module Cardano.CEM.Examples.Auction where
@@ -36,6 +37,7 @@ data SimpleAuctionStageParams
   | CanCloseAt POSIXTime
   deriving stock (Prelude.Eq, Prelude.Show)
 
+
 instance Stages SimpleAuctionStage where
   type StageParams SimpleAuctionStage = SimpleAuctionStageParams
   stageToOnChainInterval NoControl _ = Interval.always

test/Oura.hs

@@ -1,3 +1,4 @@
+{- TODO: move to the Indexing folder? -}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 

test/Oura/Config.hs

@@ -1,81 +1,82 @@
+{- FIXME: remove -}
 {-# LANGUAGE BlockArguments #-}
 
 module Oura.Config (
-  filtersL,
-  predicateL,
-  tableL,
-  atKey,
-  _Table,
-  _Integer,
-  _Bool,
-  _Text,
+  -- filtersL,
+  -- predicateL,
+  -- tableL,
+  -- atKey,
+  -- _Table,
+  -- _Integer,
+  -- _Bool,
+  -- _Text,
 ) where
 
-import Prelude
+-- import Prelude
 
-import Cardano.CEM.Indexing qualified as Config
-import Control.Lens (
-  At (at),
-  Each (each),
-  Iso',
-  Lens',
-  Prism',
-  Traversal',
-  from,
-  iso,
-  mapping,
-  partsOf,
-  prism',
-  _Just,
- )
-import Data.Map (Map)
-import Data.Text qualified as T
-import Toml qualified
+-- import Cardano.CEM.Indexing qualified as Config
+-- import Control.Lens (
+--   At (at),
+--   Each (each),
+--   Iso',
+--   Lens',
+--   Prism',
+--   Traversal',
+--   from,
+--   iso,
+--   mapping,
+--   partsOf,
+--   prism',
+--   _Just,
+--  )
+-- import Data.Map (Map)
+-- import Data.Text qualified as T
+-- import Toml qualified
 
--- * Config
+-- -- * Config
 
-filterL :: Iso' Config.Filter Toml.Table
-filterL = iso Config.unFilter Config.MkFilter
+-- filterL :: Iso' Config.Filter Toml.Table
+-- filterL = iso Config.unFilter Config.MkFilter
 
-predicateL :: Traversal' Config.Filter T.Text
-predicateL = filterL . atKey "predicate" . _Just . _Text
+-- predicateL :: Traversal' Config.Filter T.Text
+-- predicateL = filterL . atKey "predicate" . _Just . _Text
 
-filtersL :: Traversal' Toml.Table [Config.Filter]
-filtersL =
-  atKey "filters"
-    . _Just
-    . _List
-    . partsOf (each . _Table . from filterL)
+-- filtersL :: Traversal' Toml.Table [Config.Filter]
+-- filtersL =
+--   atKey "filters"
+--     . _Just
+--     . _List
+--     . partsOf (each . _Table . from filterL)
 
-atKey :: T.Text -> Traversal' Toml.Table (Maybe Toml.Value)
-atKey key = tableL . at key
+-- atKey :: T.Text -> Traversal' Toml.Table (Maybe Toml.Value)
+-- atKey key = tableL . at key
 
-tableL :: Lens' Toml.Table (Map T.Text Toml.Value)
-tableL =
-  iso (\(Toml.MkTable t) -> t) Toml.MkTable
-    . mapping (iso snd ((),))
+-- tableL :: Lens' Toml.Table (Map T.Text Toml.Value)
+-- tableL =
+--   iso (\(Toml.MkTable t) -> t) Toml.MkTable
+--     . mapping (iso snd ((),))
 
-_Table :: Prism' Toml.Value Toml.Table
-_Table = prism' Toml.Table \case
-  Toml.Table table -> Just table
-  _ -> Nothing
+-- _Table :: Prism' Toml.Value Toml.Table
+-- _Table = prism' Toml.Table \case
+--   Toml.Table table -> Just table
+--   _ -> Nothing
 
-_Text :: Prism' Toml.Value T.Text
-_Text = prism' Toml.Text \case
-  Toml.Text t -> Just t
-  _ -> Nothing
+-- _Text :: Prism' Toml.Value T.Text
+-- _Text = prism' Toml.Text \case
+--   Toml.Text t -> Just t
+--   _ -> Nothing
 
-_List :: Prism' Toml.Value [Toml.Value]
-_List = prism' Toml.List \case
-  Toml.List xs -> Just xs
-  _ -> Nothing
+-- _List :: Prism' Toml.Value [Toml.Value]
+-- _List = prism' Toml.List \case
+--   Toml.List xs -> Just xs
+--   _ -> Nothing
 
-_Bool :: Prism' Toml.Value Bool
-_Bool = prism' Toml.Bool \case
-  Toml.Bool b -> Just b
-  _ -> Nothing
+-- _Bool :: Prism' Toml.Value Bool
+-- _Bool = prism' Toml.Bool \case
+--   Toml.Bool b -> Just b
+--   _ -> Nothing
 
-_Integer :: Prism' Toml.Value Integer
-_Integer = prism' Toml.Integer \case
-  Toml.Integer n -> Just n
-  _ -> Nothing
+-- _Integer :: Prism' Toml.Value Integer
+-- _Integer = prism' Toml.Integer \case
+--   Toml.Integer n -> Just n
+--   _ -> Nothing

test/OuraFilters/Mock.hs

@@ -21,6 +21,7 @@ import Data.ByteString.Base16 qualified as Base16
 import Data.ByteString.Base64 qualified as Base64
 import Data.ByteString.Lazy qualified as LBS
 import Data.Functor ((<&>))
+import Data.Map.Strict qualified as Map
 import Data.Text qualified as T
 import Data.Vector qualified as Vec
 import GHC.Generics (Generic (Rep))
@@ -29,6 +30,11 @@ import PlutusLedgerApi.V1 qualified
 import Safe qualified
 import Utils (digits)
 import Prelude
+import Cardano.CEM (Transition, CEMScript, transitionStage, State)
+import Data.Data (Proxy(Proxy))
+import Data.Spine (getSpine, Spine)
+import Data.Tuple (swap)
+import Data.Bifunctor (first)
 
 newtype WithoutUnderscore a = MkWithoutUnderscore a
   deriving newtype (Generic)
@@ -261,6 +267,28 @@ data Tx = MkTx
 makeLenses ''Tx
 makeLensesFor [("collateral", "txCollateral")] ''Tx
 
+
+-- ---
+
+type Event script = Spine (Transition script)
+
+
+extractEvent :: forall script. (CEMScript script) => Tx -> Maybe (Event script)
+extractEvent tx = do
+  let mOwnInput :: Maybe TxInput = undefined
+  let mSourceState ::  Maybe (State script) = _ mOwnInput
+  let mSourceSpine ::  Maybe (Spine (State script)) = getSpine <$> mSourceState
+
+  let mOwnOutput :: Maybe TxInput = undefined
+  let mTargetState ::  Maybe (State script) = _ mOwnInput
+  let mSourceSpine ::  Maybe (Spine (State script)) = getSpine <$> mSourceState
+
+  let transitions = first (\(_,b,c) -> (b,c)) . swap <$> Map.toList (transitionStage $ Proxy @script)
+  lookup (mSourceSpine, mSourceSpine) transitions
+
+-- ---
+
+
 data TxEvent = MkTxEvent
   { _parsed_tx :: Tx
   , _point :: String -- "Origin"
@@ -369,3 +397,4 @@ plutusAddressToOuraAddress =
     . SerialiseRaw.serialiseToRawBytes
     . either error id
     . Address.plutusAddressToShelleyAddress Ledger.Mainnet
+