Unify models

Alternative `ModelIO` instance for the reference implementation

Use the pure model with a tiny wrapper

Remove ModelIO.Normal

TOSQUASH: Alternative `ModelIO` instance

WIP: one model

WIP: full cleanup

lsm-tree.cabal

@@ -334,12 +334,8 @@ test-suite lsm-tree-test
   other-modules:
     Database.LSMTree.Class.Monoidal
     Database.LSMTree.Class.Normal
-    Database.LSMTree.Model.Monoidal
-    Database.LSMTree.Model.Normal
-    Database.LSMTree.Model.Normal.Session
-    Database.LSMTree.ModelIO.Monoidal
-    Database.LSMTree.ModelIO.Normal
-    Database.LSMTree.ModelIO.Session
+    Database.LSMTree.SessionModel
+    Database.LSMTree.TableModel
     Test.Data.Arena
     Test.Database.LSMTree.Class.Monoidal
     Test.Database.LSMTree.Class.Normal
@@ -366,12 +362,11 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.Internal.Serialise
     Test.Database.LSMTree.Internal.Serialise.Class
     Test.Database.LSMTree.Internal.Vector
-    Test.Database.LSMTree.Model.Monoidal
-    Test.Database.LSMTree.Model.Normal
     Test.Database.LSMTree.Monoidal
     Test.Database.LSMTree.Normal.Examples
     Test.Database.LSMTree.Normal.StateMachine
     Test.Database.LSMTree.Normal.StateMachine.Op
+    Test.Database.LSMTree.TableModel
     Test.System.Posix.Fcntl.NoCache
     Test.Util.FS
     Test.Util.Orphans

test/Database/LSMTree/Class/Monoidal.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE TypeFamilies #-}
 
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Database.LSMTree.Class.Monoidal (
     IsSession (..)
   , SessionArgs (..)
@@ -10,20 +12,36 @@ module Database.LSMTree.Class.Monoidal (
   , withTableDuplicate
   , withTableMerge
   , withCursor
+      -- * Model 2 instance
+  , runInOpenSession
+  , convLookupResult
+  , convLookupResult'
+  , convQueryResult
+  , convQueryResult'
+  , convUpdate
+  , convUpdate'
+  , MSession (..)
+  , MTableHandle (..)
+  , MCursor (..)
+  , MErr (..)
+  , MBlobRef (..)
   ) where
 
+import           Control.Exception (Exception)
 import           Control.Monad.Class.MonadThrow (MonadThrow (..))
 import           Data.Kind (Constraint, Type)
-import           Data.Typeable (Proxy (Proxy), Typeable)
+import           Data.Typeable (Proxy (Proxy))
 import qualified Data.Vector as V
-import           Database.LSMTree.Class.Normal (IsSession (..),
-                     SessionArgs (..), withSession)
+import           Data.Void (Void)
+import           Database.LSMTree.Class.Normal (IsSession (..), MSession (..),
+                     SessionArgs (..), runInOpenSession, withSession)
 import           Database.LSMTree.Common (IOLike, Labellable (..), Range (..),
                      SerialiseKey, SerialiseValue, SnapshotName)
-import qualified Database.LSMTree.ModelIO.Monoidal as M
 import           Database.LSMTree.Monoidal (LookupResult (..), QueryResult (..),
                      ResolveValue, Update (..))
 import qualified Database.LSMTree.Monoidal as R
+import qualified Database.LSMTree.SessionModel as M2
+import qualified Database.LSMTree.TableModel as M22
 
 
 -- | Class abstracting over table handle operations.
@@ -35,13 +53,17 @@ class (IsSession (Session h)) => IsTableHandle h where
     type Cursor h :: (Type -> Type) -> Type -> Type -> Type
 
     new ::
-           IOLike m
+           ( IOLike m
+           , M2.C k v Void
+           )
         => Session h m
         -> TableConfig h
         -> m (h m k v)
 
     close ::
-           IOLike m
+           ( IOLike m
+           , M2.C k v Void
+           )
         => h m k v
         -> m ()
 
@@ -50,6 +72,7 @@ class (IsSession (Session h)) => IsTableHandle h where
            , ResolveValue v
            , SerialiseKey k
            , SerialiseValue v
+           ,  M2.C k v Void
            )
         => h m k v
         -> V.Vector k
@@ -60,6 +83,7 @@ class (IsSession (Session h)) => IsTableHandle h where
            , ResolveValue v
            , SerialiseKey k
            , SerialiseValue v
+           , M2.C k v Void
            )
         => h m k v
         -> Range k
@@ -68,13 +92,16 @@ class (IsSession (Session h)) => IsTableHandle h where
     newCursor ::
            ( IOLike m
            , SerialiseKey k
+           , M2.C k v Void
            )
         => Maybe k
         -> h m k v
         -> m (Cursor h m k v)
 
     closeCursor ::
-           IOLike m
+           ( IOLike m
+           , M2.C k v Void
+           )
         => proxy h
         -> Cursor h m k v
         -> m ()
@@ -84,6 +111,7 @@ class (IsSession (Session h)) => IsTableHandle h where
            , ResolveValue v
            , SerialiseKey k
            , SerialiseValue v
+           , M2.C k v Void
            )
         => proxy h
         -> Int
@@ -95,6 +123,7 @@ class (IsSession (Session h)) => IsTableHandle h where
            , SerialiseKey k
            , SerialiseValue v
            , ResolveValue v
+           , M2.C k v Void
            )
         => h m k v
         -> V.Vector (k, Update v)
@@ -105,6 +134,7 @@ class (IsSession (Session h)) => IsTableHandle h where
            , SerialiseKey k
            , SerialiseValue v
            , ResolveValue v
+           , M2.C k v Void
            )
         => h m k v
         -> V.Vector (k, v)
@@ -115,6 +145,7 @@ class (IsSession (Session h)) => IsTableHandle h where
            , SerialiseKey k
            , SerialiseValue v
            , ResolveValue v
+           , M2.C k v Void
            )
         => h m k v
         -> V.Vector k
@@ -125,6 +156,7 @@ class (IsSession (Session h)) => IsTableHandle h where
            , SerialiseKey k
            , SerialiseValue v
            , ResolveValue v
+           , M2.C k v Void
            )
         => h m k v
         -> V.Vector (k, v)
@@ -136,8 +168,7 @@ class (IsSession (Session h)) => IsTableHandle h where
            , ResolveValue v
            , SerialiseKey k
            , SerialiseValue v
-             -- Model-specific constraints
-           , Typeable k, Typeable v
+           , M2.C k v Void
            )
         => SnapshotName
         -> h m k v
@@ -148,22 +179,24 @@ class (IsSession (Session h)) => IsTableHandle h where
            , Labellable (k, v)
            , SerialiseKey k
            , SerialiseValue v
-             -- Model-specific constraints
-           , Typeable k, Typeable v
+           , M2.C k v Void
            )
         => Session h m
         -> SnapshotName
         -> m (h m k v)
 
     duplicate ::
-           IOLike m
+           ( IOLike m
+           , M2.C k v Void
+           )
         => h m k v
         -> m (h m k v)
 
     merge ::
            ( IOLike m
            , ResolveValue v
            , SerialiseValue v
+           , M2.C k v Void
            )
         => h m k v
         -> h m k v
@@ -172,6 +205,7 @@ class (IsSession (Session h)) => IsTableHandle h where
 withTableNew :: forall h m k v a.
      ( IOLike m
      , IsTableHandle h
+     , M2.C k v Void
      )
   => Session h m
   -> TableConfig h
@@ -185,7 +219,7 @@ withTableOpen :: forall h m k v a.
      , SerialiseKey k
      , SerialiseValue v
      , Labellable (k, v)
-     , Typeable k, Typeable v
+     , M2.C k v Void
      )
   => Session h m
   -> SnapshotName
@@ -196,6 +230,7 @@ withTableOpen sesh snap = bracket (open sesh snap) close
 withTableDuplicate :: forall h m k v a.
      ( IOLike m
      , IsTableHandle h
+     , M2.C k v Void
      )
   => h m k v
   -> (h m k v -> m a)
@@ -207,6 +242,7 @@ withTableMerge :: forall h m k v a.
      , IsTableHandle h
      , SerialiseValue v
      , ResolveValue v
+     , M2.C k v Void
      )
   => h m k v
   -> h m k v
@@ -218,6 +254,7 @@ withCursor :: forall h m k v a.
      ( IOLike m
      , IsTableHandle h
      , SerialiseKey k
+     , M2.C k v Void
      )
   => Maybe k
   -> h m k v
@@ -226,33 +263,100 @@ withCursor :: forall h m k v a.
 withCursor offset hdl = bracket (newCursor offset hdl) (closeCursor (Proxy @h))
 
 {-------------------------------------------------------------------------------
-  Model instance
+  Model 2 instance
 -------------------------------------------------------------------------------}
 
-instance IsTableHandle M.TableHandle where
-    type Session M.TableHandle = M.Session
-    type TableConfig M.TableHandle = M.TableConfig
-    type Cursor M.TableHandle = M.Cursor
-
-    new = M.new
-    close = M.close
-    lookups = flip M.lookups
-    updates = flip M.updates
-    inserts = flip M.inserts
-    deletes = flip M.deletes
-    mupserts = flip M.mupserts
-
-    rangeLookup = flip M.rangeLookup
-
-    newCursor = M.newCursor
-    closeCursor _ = M.closeCursor
-    readCursor _ = M.readCursor
-
-    snapshot = M.snapshot
-    open = M.open
-
-    duplicate = M.duplicate
-    merge = M.merge
+data MTableHandle m k v = MTableHandle {
+    _mthSession     :: !(MSession m)
+  , _mthTableHandle :: !(M2.TableHandle k v Void)
+  }
+
+data MBlobRef m = MBlobRef {
+    _mrbSession :: !(MSession m)
+  , mrbBlobRef  :: !(M2.BlobRef Void)
+  }
+
+data MCursor m k v = MCursor {
+    _mcSession :: !(MSession m)
+  , _mcCursor  :: !(M2.Cursor k v Void)
+  }
+
+newtype MErr = MErr (M2.Err)
+  deriving stock Show
+  deriving anyclass Exception
+
+-- runInOpenSession :: (MonadSTM m, MonadThrow (STM m)) => MSession m -> M2.ModelM a -> m a
+-- runInOpenSession (MSession var) action = atomically $ do
+--     readTVar var >>= \case
+--       Nothing -> error "session closed"
+--       Just m  -> do
+--         let (r, m') = M2.runModelM action m
+--         case r of
+--           Left e  -> throwSTM (MErr e)
+--           Right x -> writeTVar var (Just m') >> pure x
+
+instance IsTableHandle MTableHandle where
+    type Session MTableHandle = MSession
+    type TableConfig MTableHandle = M2.TableConfig
+    type Cursor MTableHandle = MCursor
+
+    new s x = MTableHandle s <$> runInOpenSession s (M2.new x)
+    close (MTableHandle s t) = runInOpenSession s (M2.close t)
+    lookups (MTableHandle s t) x1 = fmap convLookupResult . fmap (fmap (MBlobRef s)) <$>
+      runInOpenSession s (M2.lookups x1 t)
+    updates (MTableHandle s t) x1 = runInOpenSession s (M2.updates (fmap (fmap convUpdate) x1) t)
+    inserts (MTableHandle s t) x1 = runInOpenSession s (M2.inserts (fmap (\(k, v) -> (k, v, Nothing)) x1) t)
+    deletes (MTableHandle s t) x1 = runInOpenSession s (M2.deletes x1 t)
+    mupserts (MTableHandle s t) x1 = runInOpenSession s (M2.mupserts x1 t)
+
+    rangeLookup (MTableHandle s t) x1 = fmap convQueryResult . fmap (fmap (MBlobRef s)) <$>
+      runInOpenSession s (M2.rangeLookup x1 t)
+
+    newCursor k (MTableHandle s t) = MCursor s <$> runInOpenSession s (M2.newCursor k t)
+    closeCursor _ (MCursor s c) = runInOpenSession s (M2.closeCursor c)
+    readCursor _ x1 (MCursor s c) = fmap convQueryResult . fmap (fmap (MBlobRef s)) <$>
+      runInOpenSession s (M2.readCursor x1 c)
+
+    snapshot x1 (MTableHandle s t) = runInOpenSession s (M2.snapshot x1 t)
+    open s x1 = MTableHandle s <$> runInOpenSession s (M2.open x1)
+
+    duplicate (MTableHandle s t) = MTableHandle s <$> runInOpenSession s (M2.duplicate t)
+
+    merge (MTableHandle s1 t1) (MTableHandle _s2 t2) =
+        MTableHandle s1 <$> runInOpenSession s1 (M2.merge t1 t2)
+
+convLookupResult :: M22.LookupResult v b -> LookupResult v
+convLookupResult = \case
+    M22.NotFound -> NotFound
+    M22.Found v -> Found v
+    M22.FoundWithBlob{} -> error "convLookupResult: did not expect a blob"
+
+convLookupResult' :: LookupResult v ->  M22.LookupResult v b
+convLookupResult' = \case
+    NotFound ->  M22.NotFound
+    Found v ->  M22.Found v
+
+convQueryResult :: M22.QueryResult k v b -> QueryResult k v
+convQueryResult = \case
+    M22.FoundInQuery k v -> FoundInQuery k v
+    M22.FoundInQueryWithBlob{} -> error "convQueryResult: did not expect a blob"
+
+convQueryResult' :: QueryResult k v -> M22.QueryResult k v b
+convQueryResult' = \case
+    FoundInQuery k v -> M22.FoundInQuery k v
+
+convUpdate :: Update v -> M22.Update v b
+convUpdate = \case
+    Insert v -> M22.Insert v Nothing
+    Delete   -> M22.Delete
+    Mupsert v -> M22.Mupsert v
+
+convUpdate' :: M22.Update v b -> Update v
+convUpdate' = \case
+    M22.Insert v Nothing -> Insert v
+    M22.Insert _ (Just _) -> error "convUpdate': did not expect a blob"
+    M22.Delete     -> Delete
+    M22.Mupsert v -> Mupsert v
 
 {-------------------------------------------------------------------------------
   Real instance