TEMP: Next steps on generator

ouroboros-consensus-test/bench-storage/Bench/Ouroboros/Consensus/Storage/LedgerDB/HD.hs

@@ -23,16 +23,13 @@ import           Control.DeepSeq
 import           Control.Monad (replicateM)
 import           Control.Monad.Trans.Class (MonadTrans, lift)
 import           Control.Monad.Trans.State (StateT (..), gets, modify)
-import qualified Data.FingerTree.Strict as FT
-import           Data.Foldable (toList)
-import qualified Data.Sequence as Seq
+import qualified Data.Map.Strict as Map
 --import           Criterion
 import           GHC.Generics (Generic)
 import           Test.QuickCheck hiding (Result)
 import           Test.Tasty.Bench
 import           Test.Tasty.QuickCheck (testProperty)
 
-import qualified Data.FingerTree.Strict.Alt as Alt
 import qualified Data.Map.Strict.Diff2 as D2
 
 import qualified Ouroboros.Consensus.Block as Block
@@ -51,9 +48,9 @@ benchmarks = bgroup "HD" [ bgroup "DiffSeq/Diff operations" [
         bgroup "Comparative performance analysis" [
             bcompare "$NF == \"LegacyDiff\"" $
               bench "AntiDiff"    $
-                whnf (interpret @New @Int @Int) newCmds
+                nf (interpret @New @Int @Int) newCmds
           ,   bench "LegacyDiff"  $
-                whnf (interpret @Legacy @Int @Int) legacyCmds
+                nf (interpret @Legacy @Int @Int) legacyCmds
           , testProperty "AntiDiff == LegacyDiff" $
                 to (interpret @Legacy @Int @Int legacyCmds)
               ===
@@ -223,40 +220,40 @@ genInitialModel :: (Eq v, Arbitrary v) => GenConfig -> Gen (Model Int v)
 genInitialModel GenConfig{nrInitialValues} = do
     kvs <- mapM genKeyValue [0 .. nrInitialValues - 1]
     pure $ Model DS.emptyDiffSeq 0 (TT.valuesFromList kvs) nrInitialValues
-  where
-    genKeyValue x = (x,) <$> arbitrary
+
+genKeyValue :: Arbitrary v => k -> Gen (k, v)
+genKeyValue x = (x,) <$> arbitrary
 
 type CmdGen v a = StateT (Model Int v) Gen a
 
-genCmds :: Eq v => GenConfig -> CmdGen v [Cmd 'New Int v]
+genCmds :: (Eq v, Arbitrary v) => GenConfig -> CmdGen v [Cmd 'New Int v]
 genCmds conf = mapM (const $ genCmd conf) [1 .. size conf]
 
--- | Like @'genCmds'@, but the size of the generated command sequence is not
--- set by the given @'GenConfig'@ parameter, and uses the QuickCheck size
--- instead.
---
--- Use this version of @'genCmds'@ for property tests.
-genCmdsSized :: Eq v => GenConfig -> CmdGen v [Cmd 'New Int v]
-genCmdsSized conf = listOf' (genCmd conf)
-
--- | FIXME(jdral): Copied from most recent version of @feature/utxo-hd@.
-oneof' :: (MonadTrans t, Monad (t Gen)) => [t Gen a] -> t Gen a
-oneof' [] = error "QuickCheck.oneof used with empty list"
-oneof' gs = lift (chooseInt (0,length gs - 1)) >>= (gs !!)
-
 listOf' :: CmdGen v a -> CmdGen v [a]
 listOf' gen = do
   n <- lift getSize
   k <- lift $ choose (0, n)
   replicateM k gen
 
-genCmd :: Eq v => GenConfig -> CmdGen v (Cmd 'New Int v)
+-- | Variant of 'frequency' that allows for transformers of 'Gen'
+frequency' :: (MonadTrans t, Monad (t Gen)) => [(Int, t Gen a)] -> t Gen a
+frequency' [] = error "frequency' used with empty list"
+frequency' xs0 = lift (choose (1, tot)) >>= (`pick` xs0)
+  where
+    tot = sum (map fst xs0)
+
+    pick n ((k,x):xs)
+      | n <= k    = x
+      | otherwise = pick (n-k) xs
+    pick _ _  = error "pick used with empty list"
+
+genCmd :: (Eq v, Arbitrary v) => GenConfig -> CmdGen v (Cmd 'New Int v)
 genCmd conf = do
-    oneof' [
-        genPush
-      , genFlush conf
+    frequency' [
+        (100, genPush)
+      , (1, genFlush conf) -- FIXME: Only generate flushes when k < tip
       --, genRollback
-      , genForward conf
+      , (100, genForward conf)
       ]
 
 -- | Generate a @'Push'@ command.
@@ -277,18 +274,32 @@ genCmd conf = do
 --
 -- TODO(jdral): Make the behaviour configurable for things like: which key-value
 -- pairs to delete/insert, how many to delete/insert, etc.
-genPush :: Eq v => CmdGen v (Cmd 'New Int v)
+genPush :: (Eq v, Arbitrary v) => CmdGen v (Cmd 'New Int v)
 genPush = do
   ds <- gets diffs
   t <- gets tip
   vs <- gets backingValues
+  kc <- gets keyCounter
 
   let
-    vs' = TT.forwardValues vs (DS.cumulativeDiff ds)
-    toGen = 100
-    d = mempty
+    _vs'@(TT.TableValues m) = TT.forwardValues vs (DS.cumulativeDiff ds)
 
-  modify (\s -> s { diffs = push ds (fromIntegral t) d, tip = t + 1 })
+  toTake :: Int <- pure 50 -- getPositive <$> lift arbitrary
+  toMake :: Int <- pure 50 -- getPositive <$> lift arbitrary
+
+  taken <- take toTake <$> lift (shuffle (Map.toList m))
+  made <- lift $ mapM genKeyValue [kc .. kc + toMake - 1]
+
+  let
+    d = TT.TableDiff . D2.Diff $
+         Map.fromList [(k, D2.singletonDelete v) | (k,v) <- taken]
+      <> Map.fromList [(k, D2.singletonInsert v) | (k,v) <- made]
+
+  modify (\s -> s {
+      diffs = push ds (fromIntegral t) d
+    , tip = t + 1
+    , keyCounter = kc + toMake
+    })
 
   pure (Push ds (fromIntegral t) d)
 
@@ -305,13 +316,20 @@ genPush = do
 -- * Return the current diff sequence and @n@.
 -- BOOKKEEPING: Remove the first @n@ diffs from the models' diff sequence and
 -- use them to forward the model's backing values.
-genFlush :: GenConfig -> CmdGen v (Cmd 'New Int v)
-genFlush GenConfig{securityParameter = _k} = do
+genFlush :: Eq v => GenConfig -> CmdGen v (Cmd 'New Int v)
+genFlush GenConfig{securityParameter = k} = do
   ds <- gets diffs
   t <- gets tip
+  vs <- gets backingValues
 
   let
-    n = 0
+    (l, r) = DS.splitAtSlot (fromIntegral $ t - k) ds
+    n = DS.length l
+
+  modify (\s -> s {
+      diffs = r
+    , backingValues = TT.forwardValues vs (DS.cumulativeDiff l)
+    })
 
   pure $ Flush n ds
 
@@ -321,7 +339,6 @@ genFlush GenConfig{securityParameter = _k} = do
 -- >    -- ...
 -- >    | Rollback Int (DiffSeq i k v)
 -- >    -- ...
-
 genRollback :: GenConfig -> CmdGen v (Cmd 'New Int v)
 genRollback = error "Not implemented: genRollback"
 

ouroboros-consensus/src/Data/Map/Strict/Diff2.hs

@@ -14,6 +14,8 @@ module Data.Map.Strict.Diff2 (
     Diff (..)
   , DiffEntry (..)
   , DiffHistory (..)
+  , singletonDelete
+  , singletonInsert
   ) where
 
 import           Data.Group
@@ -43,6 +45,15 @@ newtype DiffHistory v = DiffHistory (Seq (DiffEntry v))
   deriving stock (Generic, Show, Eq)
   deriving anyclass (NoThunks)
 
+singleton :: DiffEntry v -> DiffHistory v
+singleton = DiffHistory . Seq.singleton
+
+singletonInsert :: v -> DiffHistory v
+singletonInsert = singleton . Insert
+
+singletonDelete :: v -> DiffHistory v
+singletonDelete = singleton . Delete
+
 -- | A change to a value in a key-value store.
 --
 -- Note: updates are equivalent to inserts, since we consider them to