diff --git a/src-extras/Database/LSMTree/Extras/NoThunks.hs b/src-extras/Database/LSMTree/Extras/NoThunks.hs index b7e25547a..65bef21d0 100644 --- a/src-extras/Database/LSMTree/Extras/NoThunks.hs +++ b/src-extras/Database/LSMTree/Extras/NoThunks.hs @@ -8,7 +8,8 @@ -- | 'NoThunks' orphan instances module Database.LSMTree.Extras.NoThunks ( assertNoThunks - , prop_NoThunks + , propUnsafeNoThunks + , propNoThunks , NoThunksIOLike ) where @@ -80,12 +81,19 @@ assertNoThunks x = assert p Nothing -> True Just thunkInfo -> error $ "Assertion failed: found thunk" <> show thunkInfo -prop_NoThunks :: NoThunks a => a -> Property -prop_NoThunks x = +propUnsafeNoThunks :: NoThunks a => a -> Property +propUnsafeNoThunks x = case unsafeNoThunks x of Nothing -> property True Just thunkInfo -> counterexample ("Found thunk " <> show thunkInfo) False +propNoThunks :: NoThunks a => a -> IO Property +propNoThunks x = do + thunkInfoMay <- noThunks [] x + pure $ case thunkInfoMay of + Nothing -> property True + Just thunkInfo -> counterexample ("Found thunk " <> show thunkInfo) False + {------------------------------------------------------------------------------- Public API -------------------------------------------------------------------------------} diff --git a/test/Test/Database/LSMTree/Internal/PageAcc.hs b/test/Test/Database/LSMTree/Internal/PageAcc.hs index b014163ea..31ec86c16 100644 --- a/test/Test/Database/LSMTree/Internal/PageAcc.hs +++ b/test/Test/Database/LSMTree/Internal/PageAcc.hs @@ -15,7 +15,7 @@ import Database.LSMTree.Internal.PageAcc1 import Database.LSMTree.Internal.RawPage (RawPage) import Database.LSMTree.Internal.Serialise -import Database.LSMTree.Extras.NoThunks (prop_NoThunks) +import Database.LSMTree.Extras.NoThunks (propNoThunks) import qualified Database.LSMTree.Extras.ReferenceImpl as Ref import Test.Util.RawPage (propEqualRawPages) @@ -180,7 +180,7 @@ toRawPageViaPageAcc kops0 = prop_noThunks_newPageAcc :: Property prop_noThunks_newPageAcc = once $ ioProperty $ do pa <- stToIO newPageAcc - pure $ prop_NoThunks pa + propNoThunks pa prop_noThunks_pageAccAddElem :: Property prop_noThunks_pageAccAddElem = once $ ioProperty $ do @@ -188,7 +188,7 @@ prop_noThunks_pageAccAddElem = once $ ioProperty $ do pa <- newPageAcc pageAccAddElemN pa 10 pure pa - pure $ prop_NoThunks pa + propNoThunks pa prop_noThunks_resetPageAcc :: Property prop_noThunks_resetPageAcc = once $ ioProperty $ do @@ -197,7 +197,7 @@ prop_noThunks_resetPageAcc = once $ ioProperty $ do pageAccAddElemN pa 10 resetPageAcc pa pure pa - pure $ prop_NoThunks pa + propNoThunks pa pageAccAddElemN :: PageAcc s -> Word64 -> ST s () pageAccAddElemN pa n = do diff --git a/test/Test/Database/LSMTree/StateMachine.hs b/test/Test/Database/LSMTree/StateMachine.hs index a61a6089b..2bdec4efa 100644 --- a/test/Test/Database/LSMTree/StateMachine.hs +++ b/test/Test/Database/LSMTree/StateMachine.hs @@ -93,7 +93,7 @@ import Database.LSMTree.Class (LookupResult (..), QueryResult (..)) import qualified Database.LSMTree.Class as Class import Database.LSMTree.Extras (showPowersOf) import Database.LSMTree.Extras.Generators (KeyForIndexCompact) -import Database.LSMTree.Extras.NoThunks (assertNoThunks) +import Database.LSMTree.Extras.NoThunks (propNoThunks) import Database.LSMTree.Internal (LSMTreeError (..)) import qualified Database.LSMTree.Internal as R.Internal import Database.LSMTree.Internal.Serialise (SerialisedBlob, @@ -302,10 +302,12 @@ propLockstep_RealImpl_RealFS_IO tr = errsVar <- newTVarIO FSSim.emptyErrors pure (tmpDir, session, errsVar) - release :: (FilePath, Class.Session R.Table IO, StrictTVar IO Errors) -> IO () - release (tmpDir, session, _) = do + release :: (FilePath, Class.Session R.Table IO, StrictTVar IO Errors) -> IO Property + release (tmpDir, !session, _) = do + !prop <- propNoThunks session R.closeSession session removeDirectoryRecursive tmpDir + pure prop propLockstep_RealImpl_MockFS_IO :: Tracer IO R.LSMTreeTrace @@ -891,7 +893,6 @@ instance ( Eq (Class.TableConfig h) , Show (Class.TableConfig h) , Arbitrary (Class.TableConfig h) , Typeable h - , NoThunks (Class.Session h IO) ) => RunLockstep (ModelState h) (RealMonad h IO) where observeReal :: Proxy (RealMonad h IO) @@ -1016,7 +1017,6 @@ instance ( Eq (Class.TableConfig h) , Show (Class.TableConfig h) , Arbitrary (Class.TableConfig h) , Typeable h - , NoThunks (Class.Session h IO) ) => RunModel (Lockstep (ModelState h)) (RealMonad h IO) where perform _ = runIO postcondition = Lockstep.Defaults.postcondition @@ -1127,14 +1127,12 @@ wrap f = first (MEither . bimap MErr f) -------------------------------------------------------------------------------} runIO :: - forall a h. (Class.IsTable h, NoThunks (Class.Session h IO)) + forall a h. Class.IsTable h => LockstepAction (ModelState h) a -> LookUp (RealMonad h IO) -> RealMonad h IO (Realized (RealMonad h IO) a) runIO action lookUp = ReaderT $ \ !env -> do - x <- aux env action - assertNoThunks (envSession env) $ pure () - pure x + aux env action where aux :: RealEnv h IO