newSession in class

IntersectMBO · Sep 28, 2023 · d935e09 · d935e09
1 parent 04290ab
commit d935e09
Showing 1 changed file with 18 additions and 12 deletions.
diff --git a/test/Test/Database/LSMTree/ModelIO/Class.hs b/test/Test/Database/LSMTree/ModelIO/Class.hs
@@ -1,23 +1,28 @@
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase     #-}
-{-# LANGUAGE TypeFamilies   #-}
+{-# LANGUAGE KindSignatures           #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies             #-}
 module Test.Database.LSMTree.ModelIO.Class (
     LookupResult (..)
   , TableHandle (..)
   ) where
+
+import           Control.Monad.Class.MonadThrow (MonadThrow (throwIO))
 import           Data.Kind (Constraint, Type)
-import           Database.LSMTree.Common (IOLike)
+import           Data.Proxy (Proxy (..))
+import           Database.LSMTree.Common (IOLike, SomeSerialisationConstraint)
 import qualified Database.LSMTree.ModelIO.Normal as M
 import           Database.LSMTree.Normal (LookupResult (..), Update (..))
 import qualified Database.LSMTree.Normal as R
 
+type TableHandle :: ((Type -> Type) -> Type -> Type -> Type -> Type) -> Constraint
 class TableHandle h where
     type Session h :: (Type -> Type) -> Type
     type TableConfig h :: Type
     type BlobRef h :: Type -> Type
 
-    -- TODO: should there be only one definition of SomeSerialisationConstraint in the library?
-    type SomeSerialisationConstraint h :: Type -> Constraint
+    -- Create fresh session (for testing purposes).
+    newSession :: IOLike m => Proxy h -> m (Session h m)
 
     new ::
            IOLike m
@@ -26,16 +31,16 @@ class TableHandle h where
         -> m (h m k v blob)
 
     lookups ::
-            (IOLike m, SomeSerialisationConstraint h k, SomeSerialisationConstraint h v)
+            (IOLike m, SomeSerialisationConstraint k, SomeSerialisationConstraint v)
         => [k]
         -> h m k v blob
         -> m [LookupResult k v (BlobRef h blob)]
 
     updates ::
         ( IOLike m
-        , SomeSerialisationConstraint h k
-        , SomeSerialisationConstraint h v
-        , SomeSerialisationConstraint h blob
+        , SomeSerialisationConstraint k
+        , SomeSerialisationConstraint v
+        , SomeSerialisationConstraint blob
         )
         => [(k, Update v blob)]
         -> h m k v blob
@@ -44,19 +49,20 @@ class TableHandle h where
 instance TableHandle M.TableHandle where
     type Session M.TableHandle = M.Session
     type TableConfig M.TableHandle = M.TableConfig
-    type SomeSerialisationConstraint M.TableHandle = M.SomeSerialisationConstraint
     type BlobRef M.TableHandle = M.BlobRef
 
+    newSession _ = M.newSession
     new = M.new
     lookups = M.lookups
     updates = M.updates
 
 instance TableHandle R.TableHandle where
     type Session R.TableHandle = R.Session
     type TableConfig R.TableHandle = R.TableConfig
-    type SomeSerialisationConstraint R.TableHandle = R.SomeSerialisationConstraint
     type BlobRef R.TableHandle = R.BlobRef
 
+    newSession _ = throwIO (userError "newSession unimplemented")
+
     new = R.new
     lookups = R.lookups
     updates = R.updates