Remove redundant conversions in the unified model

The unified model can now use the `LookupResult`, `QueryResult` and `Update`
types that are defined in the unified public API.

Author: jorisdral

test/Database/LSMTree/Model/IO.hs

@@ -12,9 +12,6 @@ module Database.LSMTree.Model.IO (
   , Cursor (..)
     -- * helpers
   , runInOpenSession
-  , convLookupResult
-  , convQueryResult
-  , convUpdate
   ) where
 
 import           Control.Concurrent.Class.MonadSTM.Strict
@@ -70,20 +67,20 @@ instance Class.IsTable Table where
 
     new s x = Table s <$> runInOpenSession s (Model.new x)
     close (Table s t) = runInOpenSession s (Model.close t)
-    lookups (Table s t) x1 = fmap convLookupResult . fmap (fmap (BlobRef s)) <$>
+    lookups (Table s t) x1 = fmap (fmap (BlobRef s)) <$>
       runInOpenSession s (Model.lookups x1 t)
-    updates (Table s t) x1 = runInOpenSession s (Model.updates Model.getResolve (fmap (fmap convUpdate) x1) t)
+    updates (Table s t) x1 = runInOpenSession s (Model.updates Model.getResolve x1 t)
     inserts (Table s t) x1 = runInOpenSession s (Model.inserts Model.getResolve x1 t)
     deletes (Table s t) x1 = runInOpenSession s (Model.deletes Model.getResolve x1 t)
     mupserts (Table s t) x1 = runInOpenSession s (Model.mupserts Model.getResolve x1 t)
 
-    rangeLookup (Table s t) x1 = fmap convQueryResult . fmap (fmap (BlobRef s)) <$>
+    rangeLookup (Table s t) x1 = fmap (fmap (BlobRef s)) <$>
       runInOpenSession s (Model.rangeLookup x1 t)
     retrieveBlobs _ s x1 = runInOpenSession s (Model.retrieveBlobs (fmap _brBlobRef x1))
 
     newCursor k (Table s t) = Cursor s <$> runInOpenSession s (Model.newCursor k t)
     closeCursor _ (Cursor s c) = runInOpenSession s (Model.closeCursor c)
-    readCursor _ x1 (Cursor s c) = fmap convQueryResult . fmap (fmap (BlobRef s)) <$>
+    readCursor _ x1 (Cursor s c) = fmap (fmap (BlobRef s)) <$>
       runInOpenSession s (Model.readCursor x1 c)
 
     createSnapshot x1 x2 (Table s t) = runInOpenSession s (Model.createSnapshot x1 x2 t)
@@ -93,20 +90,3 @@ instance Class.IsTable Table where
 
     union (Table s1 t1) (Table _s2 t2) =
       Table s1 <$> runInOpenSession s1 (Model.union Model.getResolve t1 t2)
-
-convLookupResult :: Model.LookupResult v b -> Class.LookupResult v b
-convLookupResult = \case
-    Model.NotFound -> Class.NotFound
-    Model.Found v -> Class.Found v
-    Model.FoundWithBlob v b -> Class.FoundWithBlob v b
-
-convQueryResult :: Model.QueryResult k v b -> Class.QueryResult k v b
-convQueryResult = \case
-    Model.FoundInQuery k v -> Class.FoundInQuery k v
-    Model.FoundInQueryWithBlob k v b -> Class.FoundInQueryWithBlob k v b
-
-convUpdate :: Class.Update v b -> Model.Update v b
-convUpdate = \case
-    Class.Insert v b -> Model.Insert v b
-    Class.Delete     -> Model.Delete
-    Class.Mupsert v  -> Model.Mupsert v

test/Database/LSMTree/Model/Table.hs

@@ -52,45 +52,13 @@ import qualified Data.Map.Strict as Map
 import           Data.Monoid (First (..))
 import           Data.Proxy (Proxy (Proxy))
 import qualified Data.Vector as V
+import           Database.LSMTree (LookupResult (..), QueryResult (..),
+                     ResolveValue (..), Update (..))
 import           Database.LSMTree.Common (Range (..), SerialiseKey (..),
                      SerialiseValue (..))
 import           Database.LSMTree.Internal.RawBytes (RawBytes)
-import           Database.LSMTree.Monoidal (ResolveValue (..))
 import           GHC.Exts (IsList (..))
 
-data LookupResult v b =
-    NotFound
-  | Found         !v
-  | FoundWithBlob !v !b
-  deriving stock (Eq, Show, Functor, Foldable, Traversable)
-
-instance Bifunctor LookupResult where
-  first f = \case
-      NotFound          -> NotFound
-      Found v           -> Found (f v)
-      FoundWithBlob v b -> FoundWithBlob (f v) b
-
-  second g = \case
-      NotFound          -> NotFound
-      Found v           -> Found v
-      FoundWithBlob v b -> FoundWithBlob v (g b)
-
-data QueryResult k v b =
-    FoundInQuery         !k !v
-  | FoundInQueryWithBlob !k !v !b
-  deriving stock (Eq, Show, Functor, Foldable, Traversable)
-
-instance Bifunctor (QueryResult k) where
-  bimap f g = \case
-      FoundInQuery k v           -> FoundInQuery k (f v)
-      FoundInQueryWithBlob k v b -> FoundInQueryWithBlob k (f v) (g b)
-
-data Update v b =
-    Insert !v !(Maybe b)
-  | Delete
-  | Mupsert !v
-  deriving stock (Show, Eq)
-
 newtype ResolveSerialisedValue v =
     Resolve { resolveSerialised :: RawBytes -> RawBytes -> RawBytes }
 

test/Test/Database/LSMTree/StateMachine.hs

@@ -918,10 +918,10 @@ runModel lookUp = \case
       wrap MUnit
       . Model.runModelM (Model.close (getTable $ lookUp tableVar))
     Lookups ks tableVar ->
-      wrap (MVector . fmap (MLookupResult . fmap MBlobRef . ModelIO.convLookupResult))
+      wrap (MVector . fmap (MLookupResult . fmap MBlobRef))
       . Model.runModelM (Model.lookups ks (getTable $ lookUp tableVar))
     RangeLookup range tableVar ->
-      wrap (MVector . fmap (MQueryResult . fmap MBlobRef . ModelIO.convQueryResult))
+      wrap (MVector . fmap (MQueryResult . fmap MBlobRef))
       . Model.runModelM (Model.rangeLookup range (getTable $ lookUp tableVar))
     NewCursor offset tableVar ->
       wrap MCursor
@@ -930,11 +930,11 @@ runModel lookUp = \case
       wrap MUnit
       . Model.runModelM (Model.closeCursor (getCursor $ lookUp cursorVar))
     ReadCursor n cursorVar ->
-      wrap (MVector . fmap (MQueryResult . fmap MBlobRef . ModelIO.convQueryResult))
+      wrap (MVector . fmap (MQueryResult . fmap MBlobRef))
       . Model.runModelM (Model.readCursor n (getCursor $ lookUp cursorVar))
     Updates kups tableVar ->
       wrap MUnit
-      . Model.runModelM (Model.updates Model.getResolve (fmap ModelIO.convUpdate <$> kups) (getTable $ lookUp tableVar))
+      . Model.runModelM (Model.updates Model.getResolve kups (getTable $ lookUp tableVar))
     Inserts kins tableVar ->
       wrap MUnit
       . Model.runModelM (Model.inserts Model.getResolve kins (getTable $ lookUp tableVar))

test/Test/Database/LSMTree/StateMachine/Op.hs

@@ -20,7 +20,6 @@ import           Control.Monad.Reader (ReaderT)
 import           Control.Monad.State (StateT)
 import qualified Data.Vector as V
 import qualified Database.LSMTree.Class as Class
-import qualified Database.LSMTree.Model.Table as Model
 import           GHC.Show (appPrec)
 import           Test.QuickCheck.StateModel.Lockstep (InterpretOp, Operation)
 import qualified Test.QuickCheck.StateModel.Lockstep.Op as Op
@@ -165,12 +164,3 @@ instance HasBlobRef (Class.LookupResult v) where
 instance HasBlobRef (Class.QueryResult k v) where
   getBlobRef Class.FoundInQuery{}                     = Nothing
   getBlobRef (Class.FoundInQueryWithBlob _ _ blobref) = Just blobref
-
-instance HasBlobRef (Model.LookupResult v) where
-  getBlobRef Model.NotFound{}                = Nothing
-  getBlobRef Model.Found{}                   = Nothing
-  getBlobRef (Model.FoundWithBlob _ blobref) = Just blobref
-
-instance HasBlobRef (Model.QueryResult k v) where
-  getBlobRef Model.FoundInQuery{}                     = Nothing
-  getBlobRef (Model.FoundInQueryWithBlob _ _ blobref) = Just blobref