nothunks 0.1.1.0 → 0.1.2
raw patch · 4 files changed
+148/−5 lines, 4 filesdep +stmdep ~bytestringdep ~hedgehogdep ~random
Dependencies added: stm
Dependency ranges changed: bytestring, hedgehog, random, tasty, tasty-hedgehog
Files
- CHANGELOG.md +5/−0
- nothunks.cabal +7/−5
- src/NoThunks/Class.hs +36/−0
- test/Test/NoThunks/Class.hs +100/−0
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Revision history for nothunks +## 0.1.2++* Add IORef, MVar and TVar instances.+ Oleg Grenrus <oleg.grenrus@iki.fi>+ ## 0.1.1.0 -- 2020-09-29 * Export `Context` and `GWNoThunks`
nothunks.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: nothunks-version: 0.1.1.0+version: 0.1.2 synopsis: Examine values for unexpected thunks description: Long lived application data typically should not contain any thunks. This library can be used to examine values for@@ -26,6 +26,7 @@ build-depends: base >= 4.12 && < 5 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.7+ , stm >= 2.5 && < 2.6 , text >= 1.2 && < 1.3 , time >= 1.5 && < 1.11 , vector >= 0.12 && < 0.13@@ -49,15 +50,16 @@ -- Dependencies shared with the lib , containers+ , stm -- Whatever is bundled with ghc , ghc-prim -- Additional dependencies- , hedgehog >= 1.0 && <= 1.1- , random >= 1.1 && <= 1.3- , tasty >= 1.3 && <= 1.4- , tasty-hedgehog >= 1.0 && <= 1.1+ , hedgehog >= 1.0 && < 1.1+ , random >= 1.1 && < 1.3+ , tasty >= 1.3 && < 1.4+ , tasty-hedgehog >= 1.0 && < 1.1 hs-source-dirs: test default-language: Haskell2010
src/NoThunks/Class.hs view
@@ -55,14 +55,18 @@ import Data.Sequence (Seq) import Data.Set (Set) import Data.Time+import Data.Void (Void) import Data.Word import GHC.Stack import Numeric.Natural +import qualified Control.Concurrent.MVar as MVar+import qualified Control.Concurrent.STM.TVar as TVar import qualified Data.ByteString as BS.Strict import qualified Data.ByteString.Lazy as BS.Lazy import qualified Data.ByteString.Lazy.Internal as BS.Lazy.Internal import qualified Data.IntMap as IntMap+import qualified Data.IORef as IORef import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text.Strict@@ -456,6 +460,37 @@ deriving via OnlyCheckWhnf Word64 instance NoThunks Word64 {-------------------------------------------------------------------------------+ Mutable Vars+-------------------------------------------------------------------------------}++instance NoThunks a => NoThunks (IORef.IORef a) where+ showTypeOf _ = "IORef"+ wNoThunks ctx ref = do+ val <- IORef.readIORef ref+ noThunks ctx val++instance NoThunks a => NoThunks (MVar.MVar a) where+ showTypeOf _ = "MVar"+ wNoThunks ctx ref = do+ val <- MVar.tryReadMVar ref+ maybe (return Nothing) (noThunks ctx) val++instance NoThunks a => NoThunks (TVar.TVar a) where+ showTypeOf _ = "TVar"+ wNoThunks ctx ref = do+ -- An alternative is to use+ --+ -- val <- STM.atomically $ TVar.readTVar ref+ --+ -- but that would cause nested atomically failures with+ -- unsafeNoThunks. Fortunately, readTVarIO doesn't make a transaction.+ --+ -- See related tests.+ --+ val <- TVar.readTVarIO ref+ noThunks ctx val++{------------------------------------------------------------------------------- Time -------------------------------------------------------------------------------} @@ -572,6 +607,7 @@ Base types (other than tuples) -------------------------------------------------------------------------------} +instance NoThunks Void instance NoThunks () instance NoThunks a => NoThunks [a]
test/Test/NoThunks/Class.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}@@ -38,6 +39,11 @@ import qualified Data.Sequence as Seq import qualified Data.Sequence.Internal as Seq.Internal +import qualified Control.Concurrent.MVar as MVar+import qualified Control.Concurrent.STM as STM+import qualified Control.Concurrent.STM.TVar as TVar+import qualified Data.IORef as IORef+ import Hedgehog import Hedgehog.Internal.Report (Result (..), reportStatus) import Hedgehog.Internal.Region (displayRegion)@@ -81,6 +87,11 @@ , testProperty "ThunkFreeFn" $ testWithModel agreeOnContext $ Proxy @(ThunkFree "->" (Int -> Int)) , testProperty "ThunkFreeIO" $ testWithModel agreeOnContext $ Proxy @(ThunkFree "IO" (IO ())) ]+ , testGroup "MutableVars" [+ checkRef (Proxy :: Proxy IORef.IORef)+ , checkRef (Proxy :: Proxy MVar.MVar)+ , checkRef (Proxy :: Proxy TVar.TVar)+ ] ] -- | When using @InspectHeap@ we don't get a context, so merely check if@@ -541,6 +552,95 @@ b <- liftIO $ randomRIO (False, True) n <- liftIO $ ack 5 <$> randomRIO (0, 10) k (print (notStrict b n 6) :: IO ())++{-------------------------------------------------------------------------------+ Mutable Vars+-------------------------------------------------------------------------------}++checkRef :: forall ref. (IsRef ref, NoThunks (ref Int)) => Proxy ref -> TestTree+checkRef p = testGroup (show (typeRep p)) [+ testProperty "NotNF" checkRefNotNF+ , testProperty "NF" checkRefNF+ , testProperty "NotNFPure" checkRefNotNFPure+ , testProperty "NFPure" checkRefNFPure+ , testProperty "NotNFAtomically" checkRefNotNFAtomically+ , testProperty "NFAtomically" checkRefNFAtomically+ ]+ where+ checkRefNotNF :: Property+ checkRefNotNF = checkNFClass False $ \k -> do+ ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int))+ k ref+ where+ x :: Int+ x = 0++ checkRefNF :: Property+ checkRefNF = checkNFClass True $ \k -> do+ ! ref <- liftIO (newRef x :: IO (ref Int))+ k ref+ where+ x :: Int+ !x = 0++ checkRefNotNFPure :: Property+ checkRefNotNFPure = unsafeCheckNF False $ \k -> do+ ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int))+ k ref+ where+ x :: Int+ x = 0++ checkRefNFPure :: Property+ checkRefNFPure = unsafeCheckNF True $ \k -> do+ ! ref <- liftIO (newRef x :: IO (ref Int))+ k ref+ where+ x :: Int+ !x = 0++ checkRefNotNFAtomically :: Property+ checkRefNotNFAtomically = unsafeCheckNFAtomically False $ \k -> do+ ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int))+ k ref+ where+ x :: Int+ x = 0++ checkRefNFAtomically :: Property+ checkRefNFAtomically = unsafeCheckNFAtomically True $ \k -> do+ ! ref <- liftIO (newRef x :: IO (ref Int))+ k ref+ where+ x :: Int+ !x = 0++class Typeable ref => IsRef ref where newRef :: a -> IO (ref a)++instance IsRef IORef.IORef where newRef = IORef.newIORef+instance IsRef MVar.MVar where newRef = MVar.newMVar+instance IsRef TVar.TVar where newRef = TVar.newTVarIO++checkNFClass :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property+checkNFClass expectedNF k = withTests 1 $ property $ k $ \x -> do+ nf <- liftIO $ noThunks [] x+ isNothing nf === expectedNF++{-# NOINLINE unsafeCheckNF #-}+unsafeCheckNF :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property+unsafeCheckNF expectedNF k = withTests 1 $ property $ k $ \x -> do+ let nf = unsafeNoThunks x+ isNothing nf === expectedNF++{-# NOINLINE unsafeCheckNFAtomically #-}+unsafeCheckNFAtomically :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property+unsafeCheckNFAtomically expectedNF k = withTests 1 $ property $ k $ \x -> do+ tvar <- liftIO (TVar.newTVarIO True)+ true <- liftIO $ STM.atomically $ do+ val <- TVar.readTVar tvar+ -- the $! is essential to trigger NestedAtomically exception.+ return $! val && isNothing (unsafeNoThunks x)+ true === expectedNF {------------------------------------------------------------------------------- Hedgehog auxiliary