WIP

Author: jorisdral

src/Database/LSMTree.hs

@@ -272,6 +272,7 @@ import           Database.LSMTree.Internal.Unsafe (BlobRefInvalidError (..),
                      TableTrace, TableUnionNotCompatibleError (..),
                      UnionCredits (..), UnionDebt (..))
 import qualified Database.LSMTree.Internal.Unsafe as Internal
+import           GHC.Stack (HasCallStack)
 import           Prelude hiding (lookup, take, takeWhile)
 import           System.FS.API (FsPath, HasFS (..), MountPoint (..), mkFsPath)
 import           System.FS.BlockIO.API (HasBlockIO (..), defaultIOCtxParams)
@@ -1520,14 +1521,14 @@ prop> updates table entries = traverse_ (uncurry $ update table) entries
 -}
 {-# SPECIALISE
   updates ::
-    (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
+    (HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
     Table IO k v b ->
     Vector (k, Update v b) ->
     IO ()
   #-}
 updates ::
   forall m k v b.
-  (IOLike m) =>
+  (IOLike m, HasCallStack) =>
   (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
   Table m k v b ->
   Vector (k, Update v b) ->

src/Database/LSMTree/Internal/MergeSchedule.hs

@@ -445,7 +445,8 @@ releaseUnionCache reg (UnionCache mt) =
 -------------------------------------------------------------------------------}
 
 {-# SPECIALISE updatesWithInterleavedFlushes ::
-     Tracer IO (AtLevel MergeTrace)
+     HasCallStack
+  => Tracer IO (AtLevel MergeTrace)
   -> TableConfig
   -> ResolveSerialisedValue
   -> HasFS IO h
@@ -483,7 +484,7 @@ releaseUnionCache reg (UnionCache mt) =
 -- whole run should then end up in a fresh write buffer.
 updatesWithInterleavedFlushes ::
      forall m h.
-     (MonadMask m, MonadMVar m, MonadSTM m, MonadST m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadSTM m, MonadST m)
   => Tracer m (AtLevel MergeTrace)
   -> TableConfig
   -> ResolveSerialisedValue
@@ -565,7 +566,8 @@ addWriteBufferEntries hfs f wbblobs maxn =
 
 
 {-# SPECIALISE flushWriteBuffer ::
-     Tracer IO (AtLevel MergeTrace)
+     HasCallStack
+  => Tracer IO (AtLevel MergeTrace)
   -> TableConfig
   -> ResolveSerialisedValue
   -> HasFS IO h
@@ -581,7 +583,7 @@ addWriteBufferEntries hfs f wbblobs maxn =
 -- The returned table content contains an updated set of levels, where the write
 -- buffer is inserted into level 1.
 flushWriteBuffer ::
-     (MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
   => Tracer m (AtLevel MergeTrace)
   -> TableConfig
   -> ResolveSerialisedValue

src/Database/LSMTree/Internal/Unsafe.hs

@@ -153,6 +153,7 @@ import           Database.LSMTree.Internal.UniqCounter
 import qualified Database.LSMTree.Internal.Vector as V
 import qualified Database.LSMTree.Internal.WriteBuffer as WB
 import qualified Database.LSMTree.Internal.WriteBufferBlobs as WBB
+import           GHC.Stack (HasCallStack)
 import qualified System.FS.API as FS
 import           System.FS.API (FsError, FsErrorPath (..), FsPath, HasFS)
 import qualified System.FS.API.Lazy as FS
@@ -1242,15 +1243,16 @@ rangeLookup resolve range t fromEntry = do
         else pure (V.concat (reverse (V.slice 0 n chunk : chunks)))
 
 {-# SPECIALISE updates ::
-     ResolveSerialisedValue
+     HasCallStack
+  => ResolveSerialisedValue
   -> V.Vector (SerialisedKey, Entry SerialisedValue SerialisedBlob)
   -> Table IO h
   -> IO () #-}
 -- | See 'Database.LSMTree.updates'.
 --
 -- Does not enforce that upsert and BLOBs should not occur in the same table.
 updates ::
-     (MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
   => ResolveSerialisedValue
   -> V.Vector (SerialisedKey, Entry SerialisedValue SerialisedBlob)
   -> Table m h