prototype: make more type safe

Author: mheinzel

prototypes/ScheduledMerges.hs

@@ -19,7 +19,7 @@
 module ScheduledMerges (
     -- * Main API
     LSM,
-    Key, Value, Blob,
+    Key (K), Value (V), resolveValue, Blob (B),
     new,
     LookupResult (..),
     lookup, lookups,
@@ -122,12 +122,20 @@ runSize = Map.size
 bufferSize :: Buffer -> Int
 bufferSize = Map.size
 
-type Op     = Update Value Blob
+type Op = Update Value Blob
 
-type Key    = Int
-type Value  = Int
-type Blob   = Int
+newtype Key = K Int
+  deriving stock (Eq, Ord, Show)
+  deriving newtype Enum
 
+newtype Value  = V Int
+  deriving stock (Eq, Show)
+
+resolveValue :: Value -> Value -> Value
+resolveValue (V x) (V y) = V (x + y)
+
+newtype Blob = B Int
+  deriving stock (Eq, Show)
 
 -- | The size of the 4 tiering runs at each level are allowed to be:
 -- @4^(level-1) < size <= 4^level@
@@ -425,6 +433,7 @@ new = do
 inserts :: Tracer (ST s) Event -> LSM s -> [(Key, Value)] -> ST s ()
 inserts tr lsm kvs = updates tr lsm [ (k, Insert v Nothing) | (k,v) <- kvs ]
 
+-- TODO: support (and test!) blobs
 insert :: Tracer (ST s) Event -> LSM s -> Key -> Value -> ST s ()
 insert tr lsm k v = update tr lsm k (Insert v Nothing)
 

prototypes/ScheduledMergesTest.hs

@@ -25,8 +25,8 @@ test_regression_empty_run =
     runWithTracer $ \tracer -> do
       stToIO $ do
         lsm <- LSM.new
-        let ins k = LSM.insert tracer lsm k 0
-        let del k = LSM.delete tracer lsm k
+        let ins k = LSM.insert tracer lsm (K k) (V 0)
+        let del k = LSM.delete tracer lsm (K k)
         -- run 1
         ins 0
         ins 1
@@ -80,7 +80,7 @@ test_merge_again_with_incoming =
     runWithTracer $ \tracer -> do
       stToIO $ do
         lsm <- LSM.new
-        let ins k = LSM.insert tracer lsm k 0
+        let ins k = LSM.insert tracer lsm (K k) (V 0)
         -- get something to 3rd level (so 2nd level is not levelling)
         -- (needs 5 runs to go to level 2 so the resulting run becomes too big)
         traverse_ ins [101..100+(5*16)]

prototypes/ScheduledMergesTestQLS.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE TypeFamilies #-}
 
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module ScheduledMergesTestQLS (tests) where
 
 import           Prelude hiding (lookup)
@@ -144,44 +146,44 @@ instance InLockstep Model where
     case findVars ctx (Proxy :: Proxy (LSM RealWorld)) of
       []   -> return (Some ANew)
       vars ->
-        frequency $
-            -- inserts of potentially fresh keys
+        let kvars = findVars ctx (Proxy :: Proxy Key)
+            existingKey = Left <$> elements kvars
+            freshKey = Right <$> arbitrary @Key
+        in frequency $
+          -- inserts of potentially fresh keys
           [ (3, fmap Some $
                   AInsert <$> elements vars
-                          <*> fmap Right arbitrarySizedNatural -- key
-                          <*> arbitrarySizedNatural)           -- value
+                          <*> freshKey
+                          <*> arbitrary @Value)
           ]
-            -- inserts of the same keys as used earlier
+          -- inserts of the same keys as used earlier
        ++ [ (1, fmap Some $
                   AInsert <$> elements vars
-                          <*> fmap Left (elements kvars) -- key var
-                          <*> arbitrarySizedNatural)    -- value
-          | let kvars = findVars ctx (Proxy :: Proxy Key)
-          , not (null kvars)
+                          <*> existingKey
+                          <*> arbitrary @Value)
+          | not (null kvars)
           ]
           -- deletes of arbitrary keys:
        ++ [ (1, fmap Some $
                   ADelete <$> elements vars
-                          <*> fmap Right arbitrarySizedNatural) -- key value
+                          <*> freshKey)
           ]
           -- deletes of the same key as inserted earlier:
        ++ [ (1, fmap Some $
                   ADelete <$> elements vars
-                          <*> fmap Left (elements kvars)) -- key var
-          | let kvars = findVars ctx (Proxy :: Proxy Key)
-          , not (null kvars)
+                          <*> existingKey)
+          | not (null kvars)
           ]
           -- lookup of arbitrary keys:
        ++ [ (1, fmap Some $
                   ALookup <$> elements vars
-                          <*> fmap Right arbitrarySizedNatural) -- key value
+                          <*> freshKey)
           ]
           -- lookup of the same key as inserted earlier:
        ++ [ (3, fmap Some $
                   ALookup <$> elements vars
-                          <*> fmap Left (elements kvars)) -- key var
-          | let kvars = findVars ctx (Proxy :: Proxy Key)
-          , not (null kvars)
+                          <*> existingKey)
+          | not (null kvars)
           ]
        ++ [ (1, fmap Some $
                   ADump <$> elements vars)
@@ -194,13 +196,13 @@ instance InLockstep Model where
     [ Some $ AInsert var (Right k') v' | (k', v') <- shrink (k, v) ]
 
   shrinkWithVars _ctx _model (AInsert var (Left _kv) v) =
-    [ Some $ AInsert var (Right k) v | k <- shrink 100 ]
+    [ Some $ AInsert var (Right k) v | k <- shrink (K 100) ]
 
   shrinkWithVars _ctx _model (ADelete var (Right k)) =
     [ Some $ ADelete var (Right k') | k' <- shrink k ]
 
   shrinkWithVars _ctx _model (ADelete var (Left _kv)) =
-    [ Some $ ADelete var (Right k) | k <- shrink 100 ]
+    [ Some $ ADelete var (Right k) | k <- shrink (K 100) ]
 
   shrinkWithVars _ctx _model _action = []
 
@@ -289,3 +291,19 @@ runModel action ctx m =
 
     lookUpKeyVar :: ModelVar Model Key -> Key
     lookUpKeyVar var = case lookupVar ctx var of MInsert k -> k
+
+-------------------------------------------------------------------------------
+-- Instances
+--
+
+instance Arbitrary Key where
+  arbitrary = K <$> arbitrarySizedNatural
+  shrink (K v) = K <$> shrink v
+
+instance Arbitrary Value where
+  arbitrary = V <$> arbitrarySizedNatural
+  shrink (V v) = V <$> shrink v
+
+instance Arbitrary Blob where
+  arbitrary = B <$> arbitrarySizedNatural
+  shrink (B v) = B <$> shrink v