Merge pull request #486 from IntersectMBO/jdral/unified-class-tests

Unify class-based tests

Author: jorisdral

lsm-tree.cabal

@@ -345,17 +345,12 @@ test-suite lsm-tree-test
   other-modules:
     Database.LSMTree.Class
     Database.LSMTree.Class.Common
-    Database.LSMTree.Class.Monoidal
-    Database.LSMTree.Class.Normal
     Database.LSMTree.Model
     Database.LSMTree.Model.IO
-    Database.LSMTree.Model.IO.Monoidal
-    Database.LSMTree.Model.IO.Normal
     Database.LSMTree.Model.Session
     Database.LSMTree.Model.Table
     Test.Data.Arena
-    Test.Database.LSMTree.Class.Monoidal
-    Test.Database.LSMTree.Class.Normal
+    Test.Database.LSMTree.Class
     Test.Database.LSMTree.Generators
     Test.Database.LSMTree.Internal
     Test.Database.LSMTree.Internal.BloomFilter

src-control/Control/Concurrent/Class/MonadSTM/RWVar.hs

@@ -117,7 +117,7 @@ unsafeAcquireWriteAccess rw@(RWVar !var) = do
 
 {-# SPECIALISE unsafeReleaseWriteAccess :: RWVar IO a -> a -> STM IO () #-}
 unsafeReleaseWriteAccess :: MonadSTM m => RWVar m a -> a -> STM m ()
-unsafeReleaseWriteAccess (RWVar !var) x = do
+unsafeReleaseWriteAccess (RWVar !var) !x = do
     readTVar var >>= \case
       Reading _ _ -> error "releasing a writer without write access (Reading)"
       WaitingToWrite _ _ -> error "releasing a writer without write access (WaitingToWrite)"

src-extras/Database/LSMTree/Extras/NoThunks.hs

@@ -548,28 +548,19 @@ instance (NoThunks a, Typeable s, Typeable a) => NoThunks (MutableHeap s a) wher
 -- Some constraints, like @NoThunks (MutVar s a)@ and @NoThunks (StrictTVar m
 -- a)@, can not be satisfied for arbitrary @m@\/@s@, and must be instantiated
 -- for a concrete @m@\/@s@, like @IO@\/@RealWorld@.
-class ( forall a. NoThunks a => NoThunks (StrictTVar m a)
+class ( forall a. (NoThunks a, Typeable a) => NoThunks (StrictTVar m a)
       , forall a. (NoThunks a, Typeable a) => NoThunks (StrictMVar m a)
       ) => NoThunksIOLike' m s
 
 instance NoThunksIOLike' IO RealWorld
 
 type NoThunksIOLike m = NoThunksIOLike' m (PrimState m)
 
--- TODO: on ghc-9.4, a check on StrictTVar IO (RWState (TableContent IO h))
--- fails, but we have not yet found out why so we simply disable NoThunks checks
--- for StrictTVars on ghc-9.4
-instance NoThunks a => NoThunks (StrictTVar IO a) where
-  showTypeOf (_ :: Proxy (StrictTVar IO a)) = "StrictTVar IO"
+instance (NoThunks a, Typeable a) => NoThunks (StrictTVar IO a) where
+  showTypeOf (p :: Proxy (StrictTVar IO a)) = show $ typeRep p
   wNoThunks _ctx _var = do
-#if defined(MIN_VERSION_GLASGOW_HASKELL)
-#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
-    pure Nothing
-#else
     x <- readTVarIO _var
     noThunks _ctx x
-#endif
-#endif
 
 -- TODO: in some cases, strict-mvar functions leave thunks behind, in particular
 -- modifyMVarMasked and modifyMVarMasked_. So in some specific cases we evaluate

src/Database/LSMTree/Monoidal.hs

@@ -241,7 +241,7 @@ lookups (Internal.MonoidalTable t) ks =
   where
     toLookupResult (Just e) = case e of
       Entry.Insert v           -> Found (Internal.deserialiseValue v)
-      Entry.InsertWithBlob _ _ -> error "Monoidal.lookups: unexpected InsertWithBlob"
+      Entry.InsertWithBlob v _ -> Found (Internal.deserialiseValue v)
       Entry.Mupdate v          -> Found (Internal.deserialiseValue v)
       Entry.Delete             -> NotFound
     toLookupResult Nothing = NotFound

src/Database/LSMTree/Normal.hs

@@ -332,7 +332,7 @@ lookups (Internal.NormalTable t) ks =
       Entry.Insert v            -> Found (Internal.deserialiseValue v)
       Entry.InsertWithBlob v br -> FoundWithBlob (Internal.deserialiseValue v)
                                                  (BlobRef br)
-      Entry.Mupdate _           -> error "Normal.lookups: unexpected Mupdate"
+      Entry.Mupdate v           -> Found (Internal.deserialiseValue v)
       Entry.Delete              -> NotFound
     toLookupResult Nothing = NotFound
 

test/Database/LSMTree/Class.hs

@@ -7,6 +7,7 @@ module Database.LSMTree.Class (
   , withTableNew
   , withTableFromSnapshot
   , withTableDuplicate
+  , withTableUnion
   , withCursor
   , module Common
   , module Types
@@ -17,7 +18,8 @@ import           Data.Kind (Constraint, Type)
 import           Data.Typeable (Proxy (..))
 import qualified Data.Vector as V
 import           Database.LSMTree as Types (LookupResult (..), QueryResult (..),
-                     ResolveValue, Update (..))
+                     ResolveAsFirst (..), ResolveValue (..), Update (..),
+                     resolveDeserialised)
 import qualified Database.LSMTree as R
 import           Database.LSMTree.Class.Common as Common
 
@@ -47,9 +49,6 @@ class (IsSession (Session h)) => IsTable h where
 
     lookups ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , ResolveValue v
            , C k v b
            )
         => h m k v b
@@ -58,9 +57,6 @@ class (IsSession (Session h)) => IsTable h where
 
     rangeLookup ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , ResolveValue v
            , C k v b
            )
         => h m k v b
@@ -69,7 +65,6 @@ class (IsSession (Session h)) => IsTable h where
 
     newCursor ::
            ( IOLike m
-           , SerialiseKey k
            , C k v b
            )
         => Maybe k
@@ -86,9 +81,6 @@ class (IsSession (Session h)) => IsTable h where
 
     readCursor ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , ResolveValue v
            , C k v b
            )
         => proxy h
@@ -98,8 +90,7 @@ class (IsSession (Session h)) => IsTable h where
 
     retrieveBlobs ::
            ( IOLike m
-           , SerialiseValue b
-           , C_ b
+           , CB b
            )
         => proxy h
         -> Session h m
@@ -108,10 +99,6 @@ class (IsSession (Session h)) => IsTable h where
 
     updates ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , SerialiseValue b
-           , ResolveValue v
            , C k v b
            )
         => h m k v b
@@ -120,10 +107,6 @@ class (IsSession (Session h)) => IsTable h where
 
     inserts ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , SerialiseValue b
-           , ResolveValue v
            , C k v b
            )
         => h m k v b
@@ -132,10 +115,6 @@ class (IsSession (Session h)) => IsTable h where
 
     deletes ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , SerialiseValue b
-           , ResolveValue v
            , C k v b
            )
         => h m k v b
@@ -144,10 +123,6 @@ class (IsSession (Session h)) => IsTable h where
 
     mupserts ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , SerialiseValue b
-           , ResolveValue v
            , C k v b
            )
         => h m k v b
@@ -156,10 +131,6 @@ class (IsSession (Session h)) => IsTable h where
 
     createSnapshot ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , SerialiseValue b
-           , ResolveValue v
            , C k v b
            )
         => SnapshotLabel
@@ -169,10 +140,6 @@ class (IsSession (Session h)) => IsTable h where
 
     openSnapshot ::
            ( IOLike m
-           , SerialiseKey k
-           , SerialiseValue v
-           , ResolveValue v
-           , SerialiseValue b
            , C k v b
            )
         => Session h m
@@ -189,30 +156,22 @@ class (IsSession (Session h)) => IsTable h where
 
     union ::
            ( IOLike m
-           , ResolveValue v
-           , SerialiseValue v
            , C k v b
            )
         => h m k v b
         -> h m k v b
         -> m (h m k v b)
 
 withTableNew :: forall h m k v b a.
-    ( IOLike m
-    , IsTable h
-    , C k v b
-    )
+    (IOLike m, IsTable h, C k v b)
   => Session h m
   -> TableConfig h
   -> (h m k v b -> m a)
   -> m a
 withTableNew sesh conf = bracket (new sesh conf) close
 
 withTableFromSnapshot :: forall h m k v b a.
-     ( IOLike m, IsTable h
-     , SerialiseKey k, SerialiseValue v, SerialiseValue b, ResolveValue v
-     , C k v b
-     )
+     (IOLike m, IsTable h, C k v b)
   => Session h m
   -> SnapshotLabel
   -> SnapshotName
@@ -221,21 +180,22 @@ withTableFromSnapshot :: forall h m k v b a.
 withTableFromSnapshot sesh label snap = bracket (openSnapshot sesh label snap) close
 
 withTableDuplicate :: forall h m k v b a.
-     ( IOLike m
-     , IsTable h
-     , C k v b
-     )
+     (IOLike m, IsTable h, C k v b)
   => h m k v b
   -> (h m k v b -> m a)
   -> m a
 withTableDuplicate table = bracket (duplicate table) close
 
+withTableUnion :: forall h m k v b a.
+     (IOLike m, IsTable h, C k v b)
+  => h m k v b
+  -> h m k v b
+  -> (h m k v b -> m a)
+  -> m a
+withTableUnion table1 table2 = bracket (table1 `union` table2) close
+
 withCursor :: forall h m k v b a.
-     ( IOLike m
-     , IsTable h
-     , SerialiseKey k
-     , C k v b
-     )
+     (IOLike m, IsTable h, C k v b)
   => Maybe k
   -> h m k v b
   -> (Cursor h m k v b -> m a)

test/Database/LSMTree/Class/Common.hs

@@ -1,8 +1,7 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module Database.LSMTree.Class.Common (
-    C
-  , C_
+    C, CK, CV, CB, C_
   , IsSession (..)
   , SessionArgs (..)
   , withSession
@@ -13,17 +12,37 @@ import           Control.Monad.Class.MonadThrow (MonadThrow (..))
 import           Control.Tracer (nullTracer)
 import           Data.Kind (Constraint, Type)
 import           Data.Typeable (Typeable)
+import           Database.LSMTree (ResolveValue)
 import           Database.LSMTree.Common as Types (IOLike, Range (..),
                      SerialiseKey, SerialiseValue, SnapshotLabel (..),
                      SnapshotName)
 import qualified Database.LSMTree.Common as R
 import           System.FS.API (FsPath, HasFS)
 import           System.FS.BlockIO.API (HasBlockIO)
 
--- | Model-specific constraints
-type C k v b = (C_ k, C_ v, C_ b)
+{-------------------------------------------------------------------------------
+  Constraints
+-------------------------------------------------------------------------------}
+
+-- | Constraints for keys, values, and blobs
+type C k v b = (CK k, CV v, CB b)
+
+-- | Constaints for keys
+type CK k = (C_ k, SerialiseKey k)
+
+-- | Constraints for values
+type CV v = (C_ v, SerialiseValue v, ResolveValue v)
+
+-- | Constraints for blobs
+type CB b = (C_ b, SerialiseValue b)
+
+-- | Model-specific constraints for keys, values, and blobs
 type C_ a = (Show a, Eq a, Typeable a)
 
+{-------------------------------------------------------------------------------
+  Session
+-------------------------------------------------------------------------------}
+
 -- | Class abstracting over session operations.
 --
 type IsSession :: ((Type -> Type) -> Type) -> Constraint