Add a dsl to define deposit pure tests

lib/customer-deposit-wallet/customer-deposit-wallet.cabal

@@ -69,11 +69,12 @@ library
     , delta-types
     , fingertree
     , io-classes
-    , microlens
+    , lens
     , monoidal-containers
     , mtl
     , mwc-random
     , OddWord
+    , operational
     , random
     , text
     , time
@@ -94,6 +95,9 @@ library
     Cardano.Wallet.Deposit.Pure.Submissions
     Cardano.Wallet.Deposit.Pure.UTxO
     Cardano.Wallet.Deposit.Read
+    Cardano.Wallet.Deposit.Testing.DSL
+    Cardano.Wallet.Deposit.Testing.DSL.ByTime
+    Cardano.Wallet.Deposit.Testing.DSL.Types
     Cardano.Wallet.Deposit.Time
     Cardano.Wallet.Deposit.Write
 
@@ -114,6 +118,8 @@ test-suite scenario
     , customer-deposit-wallet
     , delta-store
     , hspec                      >=2.8.2
+    , time
+    , transformers
 
   other-modules:
     Test.Scenario.Blockchain

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs

@@ -46,6 +46,7 @@ module Cardano.Wallet.Deposit.Map
       -- * Modification
     , onMap
     , onFinger
+    , Peel
     )
 where
 
@@ -298,3 +299,8 @@ onFinger
     -> (TimedSeq k (Map ks a) -> TimedSeq k (Map ks a))
     -> Map (F w k : ks) a
 onFinger (Finger w m) f = Finger w $ f m
+
+type family Peel x where
+    Peel (Map (W w k : xs) v) =  Map xs v
+    Peel (Map (F w k : xs) v) =  Map xs v
+    Peel (Map '[] v) = v

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs

@@ -34,7 +34,9 @@ import Cardano.Wallet.Deposit.Read
     , TxId
     )
 import Cardano.Wallet.Read
-    ( getTxId, IsEra, Block
+    ( Block
+    , IsEra
+    , getTxId
     )
 import Control.Monad
     ( guard

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs

@@ -0,0 +1,206 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Wallet.Deposit.Testing.DSL where
+
+import Prelude
+
+import Cardano.Wallet.Deposit.Pure
+    ( Customer
+    , WalletState
+    )
+import Cardano.Wallet.Deposit.Pure.API.TxHistory
+    ( ByTime
+    )
+import Cardano.Wallet.Deposit.Read
+    ( Address
+    )
+import Cardano.Wallet.Deposit.Testing.DSL.ByTime
+    ( ByTimeM
+    , at
+    , deposited
+    , forCustomer
+    , inTx
+    , newTimes
+    , withdrawn
+    )
+import Cardano.Wallet.Deposit.Testing.DSL.Types
+    ( BlockI (..)
+    , TxI (..)
+    , UnspentI (..)
+    )
+import Cardano.Wallet.Deposit.Write
+    ( TxBody
+    , addTxIn
+    , addTxOut
+    , emptyTxBody
+    , mkAda
+    , mkTx
+    , mkTxOut
+    )
+import Cardano.Wallet.Read
+    ( Slot
+    , WithOrigin (At, Origin)
+    , getTxId
+    , pattern TxIn
+    )
+import Control.Lens
+    ( _2
+    , zoom
+    )
+import Control.Monad
+    ( (>=>)
+    )
+import Control.Monad.Operational
+    ( ProgramT
+    , ProgramViewT (..)
+    , singleton
+    , viewT
+    )
+import Control.Monad.State
+    ( MonadState (..)
+    , MonadTrans (..)
+    , StateT
+    , execStateT
+    )
+import Data.Map
+    ( Map
+    )
+import Data.Time
+    ( UTCTime
+    )
+
+import qualified Data.Map as Map
+
+data Scenario p a where
+    ExistsTx :: Scenario p TxI
+    Deposit :: TxI -> Customer -> Int -> Scenario p UnspentI
+    Withdrawal :: TxI -> UnspentI -> Scenario p ()
+    CreateBlock :: Slot -> [TxI] -> Scenario p BlockI
+    RollForward :: [BlockI] -> Scenario p ()
+    RollBackward :: Slot -> Scenario p ()
+    HistoryByTime :: Scenario p ByTime
+    NewHistoryByTime :: ByTimeM m ByTime -> Scenario p ByTime
+    Assert :: p -> Scenario p ()
+
+type ScenarioP p m = ProgramT (Scenario p) m
+
+existsTx :: ScenarioP p m TxI
+existsTx = singleton ExistsTx
+
+deposit :: TxI -> Customer -> Int -> ScenarioP p m UnspentI
+deposit tx customer value = singleton (Deposit tx customer value)
+
+withdrawal :: TxI -> UnspentI -> ScenarioP p m ()
+withdrawal tx unspent = singleton (Withdrawal tx unspent)
+
+block :: Slot -> [TxI] -> ScenarioP p m BlockI
+block slot txs = singleton (CreateBlock slot txs)
+
+rollForward :: [BlockI] -> ScenarioP p m ()
+rollForward blocks = singleton (RollForward blocks)
+
+rollBackward :: Slot -> ScenarioP p m ()
+rollBackward slot = singleton (RollBackward slot)
+
+historyByTime :: ScenarioP p m ByTime
+historyByTime = singleton HistoryByTime
+
+newHistoryByTime :: ByTimeM m ByTime -> ScenarioP p m ByTime
+newHistoryByTime = singleton . NewHistoryByTime
+
+assert :: p -> ScenarioP p m ()
+assert = singleton . Assert
+
+-- example :: Monad m => (forall a . Eq a => a -> a -> p) -> ScenarioP p m ()
+example
+    :: Monad m
+    => (forall a . Eq a => a -> a -> p)
+    -> ProgramT (Scenario p) m ()
+example assertEq = do
+    h0 <- historyByTime
+    h0' <- newHistoryByTime $ pure mempty
+    assert $ assertEq h0 h0'
+    tx1 <- existsTx
+    unspent1 <- deposit tx1 1 100
+    _ <- deposit tx1 2 200
+    b1 <- block Origin [tx1]
+    tx2 <- existsTx
+    _ <- deposit tx2 1 200
+    withdrawal tx2 unspent1
+    b2 <- block (At 1) [tx2]
+    rollForward [b1, b2]
+    h1 <- historyByTime
+    h1' <- newHistoryByTime $ newTimes $ do
+        at Origin $ do
+            forCustomer 1 $ do
+                inTx tx1 $ deposited 100
+            forCustomer 2 $ do
+                inTx tx1 $ deposited 200
+        at (At 1) $ do
+            forCustomer 1 $ do
+                inTx tx2 $ do
+                    deposited 200
+                    withdrawn 100
+    assert $ assertEq h1 h1'
+    rollBackward (At 1)
+    rollForward [b2]
+    h2 <- historyByTime
+    assert $ assertEq h1 h2
+
+newTxId :: Monad m => StateT (Map TxI TxBody) m TxI
+newTxId = do
+    txs <- get
+    let TxI z = fst $ Map.findMax txs
+        txId = TxI (z + 1)
+    put $ Map.insert txId emptyTxBody txs
+    return txId
+
+interpret
+    :: Monad m
+    => (Customer -> Address)
+    -> (Slot -> WithOrigin UTCTime)
+    -> ScenarioP
+        p
+        (StateT (WalletState, Map TxI TxBody) m)
+        ()
+    -> StateT WalletState m ()
+interpret customerAddresses _slotTimes p = do
+    walletState <- get
+    (walletState', _) <- lift $ execStateT (go p) (walletState, mempty)
+    put walletState'
+  where
+    go = viewT >=> eval
+    -- eval :: Monad m => ProgramViewT (ScenarioP p m) m a -> m a
+    eval (Return x) = return x
+    eval (ExistsTx :>>= k) = do
+        txId <- zoom _2 newTxId
+        go $ k txId
+    eval (Deposit tx customer value :>>= k) = do
+        let v = mkAda $ fromIntegral value
+            txOut = mkTxOut (customerAddresses customer) v
+        (w, txs) <- get
+        let txBody = txs Map.! tx
+            (txBody', ix) = addTxOut txOut txBody
+        put (w, Map.insert tx txBody' txs)
+
+        go $ k $ UnspentI (tx, ix)
+    eval (Withdrawal tx (UnspentI (tx', ix)) :>>= k) = do
+        (w, txs) <- get
+        let txInBody = txs Map.! tx'
+            txId = getTxId $ mkTx txInBody
+        let txBody = txs Map.! tx
+            txIn = TxIn (txId) ix
+            txBody' = addTxIn txIn txBody
+        put (w, Map.insert tx txBody' txs)
+        go $ k ()
+    -- eval (CreateBlock slot txs :>>= k) = do
+    --     (w, txs) <- get
+    --     let txs' = Map.restrictKeys txs (Map.fromList txs)
+    --     put (w, txs')
+    --     go $ k $ BlockI slot
+    eval _ = error "Not implemented"