Add Transition datatype to delegation model

Author: paolino

lib/unit/test/unit/Cardano/Wallet/DB/Store/Delegations/StoreSpec.hs

@@ -42,6 +42,7 @@ import Cardano.Wallet.DB.Store.Delegations.Store
 import Cardano.Wallet.Delegation.Model
     ( Operation (..)
     , Status (..)
+    , Transition (..)
     , status
     )
 import Cardano.Wallet.Delegation.ModelSpec
@@ -112,16 +113,20 @@ conf =
         }
 
 pattern Register :: slot -> Operation slot drep pool
-pattern Register i = VoteAndDelegate Nothing Nothing i
+pattern Register i = ApplyTransition (VoteAndDelegate Nothing Nothing) i
 
 pattern Delegate :: pool -> slot -> Operation slot drep pool
-pattern Delegate p i = VoteAndDelegate Nothing (Just p) i
+pattern Delegate p i = ApplyTransition (VoteAndDelegate Nothing (Just p)) i
 
 pattern Vote :: drep -> slot -> Operation slot drep pool
-pattern Vote v i = VoteAndDelegate (Just v) Nothing i
+pattern Vote v i = ApplyTransition (VoteAndDelegate (Just v) Nothing) i
+
+pattern Deregister' :: slot -> Operation slot drep pool
+pattern Deregister' i = ApplyTransition (VoteAndDelegate Nothing Nothing) i
 
 pattern DelegateAndVote :: pool -> drep -> slot -> Operation slot drep pool
-pattern DelegateAndVote p v i = VoteAndDelegate (Just v) (Just p) i
+pattern DelegateAndVote p v i
+    = ApplyTransition (VoteAndDelegate (Just v) (Just p)) i
 
 pattern Registered :: Status drep pool
 pattern Registered = Active Nothing Nothing
@@ -151,20 +156,20 @@ units = withInitializedWalletProp $ \_ runQ -> do
     runQ $ unitTestStore mempty mkStoreDelegations $ do
         unit "reg-dereg" $ do
             applyS $ Register 0
-            applyS $ Deregister 0
+            applyS $ Deregister' 0
             observeStatus 0 Inactive
         unit "reg-dereg, different time" $ do
             applyS $ Register 0
             observeStatus 0 Registered
-            applyS $ Deregister 1
+            applyS $ Deregister' 1
             observeStatus 0 Registered
             observeStatus 1 Inactive
         unit "dereg-reg" $ do
-            applyS $ Deregister 0
+            applyS $ Deregister' 0
             applyS $ Register 0
             observeStatus 0 Registered
         unit "dereg-reg different time" $ do
-            applyS $ Deregister 0
+            applyS $ Deregister' 0
             applyS $ Register 1
             observeStatus 1 Registered
         unit "reg-deleg" $ do
@@ -184,7 +189,7 @@ units = withInitializedWalletProp $ \_ runQ -> do
         unit "reg-deleg-dereg" $ do
             applyS $ Register 0
             applyS $ Delegate p0 0
-            applyS $ Deregister 1
+            applyS $ Deregister' 1
             observeStatus 2 Inactive
         unit "reg-vote" $ do
             applyS $ Register 0
@@ -203,7 +208,7 @@ units = withInitializedWalletProp $ \_ runQ -> do
         unit "reg-vote-dereg" $ do
             applyS $ Register 0
             applyS $ Vote v0 0
-            applyS $ Deregister 1
+            applyS $ Deregister' 1
             observeStatus 2 Inactive
         unit "reg-deleg-and-vote" $ do
             applyS $ Register 0
@@ -222,7 +227,7 @@ units = withInitializedWalletProp $ \_ runQ -> do
         unit "reg-deleg-and-vote-dereg" $ do
             applyS $ Register 0
             applyS $ DelegateAndVote p0 v0 0
-            applyS $ Deregister 1
+            applyS $ Deregister' 1
             observeStatus 2 Inactive
         unit "reg-deleg-then-vote" $ do
             applyS $ Register 0

lib/unit/test/unit/Cardano/Wallet/Delegation/ModelSpec.hs

@@ -22,6 +22,7 @@ import Cardano.Wallet.Delegation.Model
     ( History
     , Operation (..)
     , Status (Active)
+    , Transition (..)
     )
 import Cardano.Wallet.Delegation.Properties
     ( Step (Step)
@@ -89,9 +90,9 @@ genDelta c h = do
     pool <- genPool c h
     drep <- genRep c h
     elements
-        [ VoteAndDelegate (Just drep) (Just pool) slot
-        , VoteAndDelegate Nothing (Just pool) slot
-        , VoteAndDelegate (Just drep) Nothing slot
+        [ ApplyTransition (VoteAndDelegate (Just drep) (Just pool)) slot
+        , ApplyTransition (VoteAndDelegate Nothing (Just pool)) slot
+        , ApplyTransition (VoteAndDelegate (Just drep) Nothing) slot
         , Rollback slot
         ]
 

lib/wallet/src/Cardano/Wallet/DB/Store/Delegations/Layer.hs

@@ -25,6 +25,7 @@ import Cardano.Wallet.DB.Store.Delegations.Model
 import Cardano.Wallet.Delegation.Model
     ( Operation (..)
     , Status (..)
+    , Transition (..)
     )
 import Cardano.Wallet.Primitive.Slotting
     ( TimeInterpreter
@@ -87,8 +88,9 @@ putDelegationCertificate
     -> SlotNo
     -> DeltaDelegations
 putDelegationCertificate cert sl = case cert of
-    CertDelegateNone _ -> Deregister sl
-    CertVoteAndDelegate _ pool drep -> VoteAndDelegate drep pool sl
+    CertDelegateNone _ -> ApplyTransition Deregister sl
+    CertVoteAndDelegate _ pool drep -> ApplyTransition
+        (VoteAndDelegate drep pool) sl
 
 -- | Arguments to 'readDelegation'.
 data CurrentEpochSlotting = CurrentEpochSlotting

lib/wallet/src/Cardano/Wallet/DB/Store/Delegations/Model.hs

@@ -15,6 +15,7 @@ import Cardano.Pool.Types
 import Cardano.Wallet.Delegation.Model
     ( History
     , Operation (..)
+    , Transition (..)
     )
 import Cardano.Wallet.Primitive.Types
     ( SlotNo
@@ -35,8 +36,8 @@ type DeltaDelegations = Operation SlotNo DRep PoolId
 
 instance Buildable DeltaDelegations where
     build = \case
-            Deregister slot -> "Deregister " <> build slot
-            VoteAndDelegate vote pool slot ->
+            ApplyTransition Deregister slot -> "Deregister " <> build slot
+            ApplyTransition (VoteAndDelegate vote pool) slot ->
                     "Delegate " <> build pool
                         <> " and vote "<> build vote <> " " <> build slot
             Rollback slot -> "Rollback " <> build slot

lib/wallet/src/Cardano/Wallet/Delegation/Model.hs

@@ -7,6 +7,7 @@
 -- Data types that represents a history of delegations and its changes.
 module Cardano.Wallet.Delegation.Model
     ( Operation (..)
+    , Transition (..)
     , slotOf
     , Status (..)
     , History
@@ -27,18 +28,21 @@ import Data.Map.Strict
 
 import qualified Data.Map.Strict as Map
 
+data Transition drep pool
+    = VoteAndDelegate (Maybe drep) (Maybe pool)
+    | Deregister
+    deriving (Show)
+
 -- | Delta type for the delegation 'History'.
 data Operation slot drep pool
-    = VoteAndDelegate (Maybe drep) (Maybe pool) slot
-    | Deregister slot
+    = ApplyTransition (Transition drep pool) slot
     | Rollback slot
     deriving (Show)
 
 -- | Target slot of each 'Operation'.
 slotOf :: Operation slot drep pool -> slot
-slotOf (Deregister x) = x
 slotOf (Rollback x) = x
-slotOf (VoteAndDelegate _ _ x) = x
+slotOf (ApplyTransition _ x) = x
 
 -- | Valid state for the delegations, independent of time.
 data Status drep pool
@@ -56,16 +60,17 @@ instance (Ord slot, Eq pool, Eq drep) => Delta (Operation slot drep pool) where
         slot = slotOf r
         hist' = cut (< slot) hist
         miss = status slot hist'
-        wanted = transition r $ status slot hist
+        wanted = case r of
+            ApplyTransition t _ -> applyTransition t $ status slot hist
+            Rollback _ -> status slot hist
 
-transition :: Operation slot drep pool -> Status drep pool -> Status drep pool
-transition (Deregister _) _ = Inactive
-transition (VoteAndDelegate d p _) (Active d' p') = Active d'' p''
+applyTransition :: Transition drep pool -> Status drep pool -> Status drep pool
+applyTransition Deregister _ = Inactive
+applyTransition (VoteAndDelegate d p) (Active d' p') = Active d'' p''
     where
         d'' = insertIfJust d d'
         p'' = insertIfJust p p'
-transition (VoteAndDelegate d p _) _ = Active d p
-transition _ s = s
+applyTransition (VoteAndDelegate d p) _ = Active d p
 
 insertIfJust :: Maybe a -> Maybe a -> Maybe a
 insertIfJust (Just y) _ = Just y

lib/wallet/src/Cardano/Wallet/Delegation/Properties.hs

@@ -20,6 +20,7 @@ import Cardano.Wallet.Delegation.Model
     ( History
     , Operation (..)
     , Status (..)
+    , Transition (..)
     , slotOf
     , status
     )
@@ -88,15 +89,15 @@ properties genSlot step =
                 $ property' genSlot step
                 $ precond cond target
     in  case delta_ step of
-            Deregister _ ->
+            ApplyTransition Deregister _ ->
                 that "deregister invariant is respected"
                     $ prop
                         ( \case
                             Active _ _ -> (True, Nothing)
                             _ -> (False, Nothing)
                         )
                         (const Inactive)
-            VoteAndDelegate v p _ -> do
+            ApplyTransition (VoteAndDelegate v p) _ -> do
                 that "delegate and/or vote invariant is respected"
                     $ prop
                         ( \case