TEMP: Plug in implementations

IntersectMBO · Aug 8, 2022 · f341bcb · f341bcb
1 parent 8aa7c63
commit f341bcb
Show file tree

Hide file tree

Showing 2 changed files with 42 additions and 23 deletions.
diff --git a/ouroboros-consensus-test/bench-storage/Bench/Ouroboros/Consensus/Storage/LedgerDB/HD.hs b/ouroboros-consensus-test/bench-storage/Bench/Ouroboros/Consensus/Storage/LedgerDB/HD.hs
@@ -69,7 +69,7 @@ data Cmd (i :: Imp) k v =
     Push     (DiffSeq i k v) (SlotNo i)      (Diff i k v)
   | Flush    Int             (DiffSeq i k v)
   | Rollback Int             (DiffSeq i k v)
-  | Forward  (Values i k v)  (Diff i k v)
+  | Forward  (Values i k v)  (Keys i k v)    (DiffSeq i k v)
   deriving stock Generic
 
 data Result (i :: Imp) k v =
@@ -82,6 +82,7 @@ data Result (i :: Imp) k v =
 deriving anyclass instance ( NFData (DiffSeq i k v)
                            , NFData (Diff i k v)
                            , NFData (Values i k v)
+                           , NFData (Keys i k v)
                            , NFData (SlotNo i)
                            ) => NFData (Cmd i k v)
 
@@ -98,6 +99,7 @@ deriving stock instance ( Eq (DiffSeq i k v)
 deriving stock instance ( Show (DiffSeq i k v)
                         , Show (Diff i k v)
                         , Show (Values i k v)
+                        , Show (Keys i k v)
                         , Show (SlotNo i)
                         ) => Show (Cmd i k v)
 
@@ -110,47 +112,54 @@ deriving stock instance ( Show (DiffSeq i k v)
   Interpreter
 -------------------------------------------------------------------------------}
 
-interpret :: forall i k v. Comparable i => [Cmd i k v] -> [Result i k v]
+interpret :: forall i k v. (Ord k, Eq v) => Comparable i => [Cmd i k v] -> [Result i k v]
 interpret = map go'
   where
     go' :: Cmd i k v -> Result i k v
-    go' (Push ds sl d)  = RPush $ push ds sl d
-    go' (Flush n ds)    = RFlush $ flush n ds
-    go' (Rollback n ds) = RRollback $ rollback n ds
-    go' (Forward vs d)  = RForward $ forward vs d
+    go' (Push ds sl d)     = RPush $ push ds sl d
+    go' (Flush n ds)       = RFlush $ flush n ds
+    go' (Rollback n ds)    = RRollback $ rollback n ds
+    go' (Forward vs ks ds) = RForward $ forward vs ks ds
 
 class Comparable (i :: Imp) where
   type DiffSeq i k v = r | r -> i k v
   type Diff i k v    = r | r -> i k v
   type Values i k v  = r | r -> i k v
+  type Keys i k v    = r | r -> i k v
   type SlotNo i      = r | r -> i
 
-  push     :: DiffSeq i k v -> SlotNo i -> Diff i k v -> DiffSeq i k v
-  flush    :: Int -> DiffSeq i k v -> (DiffSeq i k v, DiffSeq i k v)
-  rollback :: Int -> DiffSeq i k v -> (DiffSeq i k v, DiffSeq i k v)
-  forward  :: Values i k v -> Diff i k v -> Values i k v
+  -- | Mimicks @'Ouroboros.Consensus.Ledger.Basics.extendDbChangelog.ext'@
+  push     :: (Ord k, Eq v) => DiffSeq i k v -> SlotNo i -> Diff i k v -> DiffSeq i k v
+  -- | Mimicks @'Ouroboros.Consensus.Ledger.Basics.flushDbChangelog.split'@
+  flush    :: (Ord k, Eq v) => Int -> DiffSeq i k v -> (DiffSeq i k v, DiffSeq i k v)
+  -- | Mimicks @'Ouroboros.Consensus.Ledger.Basics.rollbackDbChangelog.trunc'@
+  rollback :: (Ord k, Eq v) => Int -> DiffSeq i k v -> (DiffSeq i k v, DiffSeq i k v)
+  -- | Mimicks @'Ouroboros.Consensus.Storage.LedgerDB.InMemory.forward'@.
+  forward  :: (Ord k, Eq v) => Values i k v -> Keys i k v -> DiffSeq i k v -> Values i k v
 
 instance Comparable Legacy where
   type DiffSeq Legacy k v = HD.SeqUtxoDiff k v
   type Diff Legacy k v    = HD.UtxoDiff k v
   type Values Legacy k v  = HD.UtxoValues k v
+  type Keys Legacy k v    = HD.UtxoKeys k v
   type SlotNo Legacy      = Block.SlotNo
 
-  push     = error "Not implemented: Legacy.push"
-  flush    = error "Not implemented: Legacy.flush"
-  rollback = error "Not implemented: Legacy.rollback"
-  forward  = error "Not implemented: Legacy.forward"
+  push             = HD.extendSeqUtxoDiff
+  flush            = HD.splitAtSeqUtxoDiff
+  rollback         = HD.splitAtFromEndSeqUtxoDiff
+  forward vs ks ds = HD.forwardValuesAndKeys vs ks (HD.cumulativeDiffSeqUtxoDiff ds)
 
 instance Comparable New where
   type DiffSeq New k v = DS.DiffSeq TS.UTxO k v
   type Diff New k v    = TT.TableDiff TS.UTxO k v
   type Values New k v  = TT.TableValues TS.UTxO k v
+  type Keys New k v    = TT.TableKeys TS.UTxO k v
   type SlotNo New      = DS.SlotNo
 
-  push     = error "Not implemented: New.push"
-  flush    = error "Not implemented: New.flush"
-  rollback = error "Not implemented: New.rollback"
-  forward  = error "Not implemented: New.forward"
+  push ds slot d   = DS.extend ds (DS.Element slot d)
+  flush            = DS.splitAt
+  rollback         = DS.splitAtFromEnd
+  forward vs ks ds = TT.forwardValuesAndKeys vs ks (DS.cumulativeDiff ds)
 
 {-------------------------------------------------------------------------------
   Stateful generator for command sequences
@@ -223,10 +232,10 @@ instance (Isomorphism a c, Isomorphism b d) => Isomorphism (a, b) (c, d) where
 -- | Given that @'Legacy'@ and
 instance Isomorphism (Cmd New k v) (Cmd Legacy k v) where
   to :: Cmd New k v -> Cmd Legacy k v
-  to (Push ds sl d)  = Push (to ds) (to sl) (to d)
-  to (Flush n ds)    = Flush n (to ds)
-  to (Rollback n ds) = Rollback n (to ds)
-  to (Forward vs d)  = Forward (to vs) (to d)
+  to (Push ds sl d)    = Push (to ds) (to sl) (to d)
+  to (Flush n ds)      = Flush n (to ds)
+  to (Rollback n ds)   = Rollback n (to ds)
+  to (Forward vs ks d) = Forward (to vs) (to ks) (to d)
 
 instance Isomorphism (Cmd Legacy k v) (Cmd New k v) where
   to :: Cmd Legacy k v -> Cmd New k v
@@ -266,6 +275,14 @@ instance Isomorphism (HD.UtxoValues k v) (TT.TableValues ts k v) where
   to :: HD.UtxoValues k v -> TT.TableValues ts k v
   to = from @(TT.TableValues ts k v)
 
+instance Isomorphism (TT.TableKeys ts k v) (HD.UtxoKeys k v) where
+  to :: TT.TableKeys ts k v -> HD.UtxoKeys k v
+  to = error "Not implemented"
+
+instance Isomorphism (HD.UtxoKeys k v) (TT.TableKeys ts k v) where
+  to :: HD.UtxoKeys k v -> TT.TableKeys ts k v
+  to = from @(TT.TableKeys ts k v)
+
 instance Isomorphism DS.SlotNo Block.SlotNo where
   to :: DS.SlotNo -> Block.SlotNo
   to = error "Not implemented"

diff --git a/ouroboros-consensus-test/src/Test/Util/Orphans/NFData.hs b/ouroboros-consensus-test/src/Test/Util/Orphans/NFData.hs
@@ -17,7 +17,7 @@ import           Data.Map.Strict.Diff2 (Diff (..), DiffEntry (..),
                      DiffHistory (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.HD (SeqUtxoDiff (..),
                      SudElement (..), SudMeasure (..), UtxoDiff (..),
-                     UtxoEntryDiff (..), UtxoEntryDiffState (..),
+                     UtxoEntryDiff (..), UtxoEntryDiffState (..), UtxoKeys (..),
                      UtxoValues (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.HD.DiffSeq (DiffSeq (..),
                      Element (..), InternalMeasure (..), Length (..),
@@ -40,6 +40,8 @@ instance (NFData a, NFData v, Measured v a) => NFData (StrictFingerTree v a) whe
 
 deriving newtype instance (NFData k, NFData v) => NFData (UtxoValues k v)
 
+deriving newtype instance NFData k => NFData (UtxoKeys k v)
+
 deriving anyclass instance NFData UtxoEntryDiffState
 deriving anyclass instance NFData v => NFData (UtxoEntryDiff v)
 deriving newtype instance (NFData k, NFData v) => NFData (UtxoDiff k v)