{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | 'NoThunks' orphan instances
module Database.LSMTree.Extras.NoThunks (
    assertNoThunks
  , propUnsafeNoThunks
  , propNoThunks
  , NoThunksIOLike
  ) where

import           Control.Concurrent.Class.MonadMVar.Strict
import           Control.Concurrent.Class.MonadSTM.RWVar
import           Control.Concurrent.Class.MonadSTM.Strict
import           Control.Exception
import           Control.Monad.Primitive
import           Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
import           Control.RefCount
import           Control.Tracer
import           Data.Bit
import           Data.BloomFilter
import           Data.Map.Strict
import           Data.Primitive
import           Data.Primitive.PrimVar
import           Data.Proxy
import           Data.STRef
import           Data.Typeable
import qualified Data.Vector.Mutable as VM
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Unboxed.Mutable as VUM
import           Data.Word
import           Database.LSMTree.Internal as Internal
import           Database.LSMTree.Internal.Arena
import           Database.LSMTree.Internal.BlobFile
import           Database.LSMTree.Internal.BlobRef
import           Database.LSMTree.Internal.ChecksumHandle
import           Database.LSMTree.Internal.Chunk
import           Database.LSMTree.Internal.Config
import           Database.LSMTree.Internal.CRC32C
import           Database.LSMTree.Internal.Entry
import           Database.LSMTree.Internal.IncomingRun
import           Database.LSMTree.Internal.Index
import           Database.LSMTree.Internal.Index.Compact
import           Database.LSMTree.Internal.Index.CompactAcc
import           Database.LSMTree.Internal.Index.Ordinary
import           Database.LSMTree.Internal.Index.OrdinaryAcc
import           Database.LSMTree.Internal.Merge
import qualified Database.LSMTree.Internal.Merge as Merge
import           Database.LSMTree.Internal.MergeSchedule
import           Database.LSMTree.Internal.MergingRun
import           Database.LSMTree.Internal.MergingTree
import           Database.LSMTree.Internal.Page
import           Database.LSMTree.Internal.PageAcc
import           Database.LSMTree.Internal.Paths
import           Database.LSMTree.Internal.RawBytes
import           Database.LSMTree.Internal.RawOverflowPage
import           Database.LSMTree.Internal.RawPage
import           Database.LSMTree.Internal.Run
import           Database.LSMTree.Internal.RunAcc
import           Database.LSMTree.Internal.RunBuilder
import           Database.LSMTree.Internal.RunNumber
import           Database.LSMTree.Internal.RunReader hiding (Entry)
import qualified Database.LSMTree.Internal.RunReader as Reader
import           Database.LSMTree.Internal.RunReaders
import           Database.LSMTree.Internal.Serialise
import           Database.LSMTree.Internal.UniqCounter
import           Database.LSMTree.Internal.Unsliced
import           Database.LSMTree.Internal.Vector.Growing
import           Database.LSMTree.Internal.WriteBuffer
import           Database.LSMTree.Internal.WriteBufferBlobs
import           GHC.Generics
import           KMerge.Heap
import           NoThunks.Class
import           System.FS.API
import           System.FS.BlockIO.API
import           System.FS.IO
import           System.FS.Sim.MockFS
import           Test.QuickCheck (Property, Testable (..), counterexample)
import           Unsafe.Coerce

assertNoThunks :: NoThunks a => a -> b -> b
assertNoThunks :: forall a b. NoThunks a => a -> b -> b
assertNoThunks a
x = Bool -> b -> b
forall a. HasCallStack => Bool -> a -> a
assert Bool
p
  where p :: Bool
p = case a -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks a
x of
              Maybe ThunkInfo
Nothing -> Bool
True
              Just ThunkInfo
thunkInfo -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"Assertion failed: found thunk" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ThunkInfo -> [Char]
forall a. Show a => a -> [Char]
show ThunkInfo
thunkInfo

propUnsafeNoThunks :: NoThunks a => a -> Property
propUnsafeNoThunks :: forall a. NoThunks a => a -> Property
propUnsafeNoThunks a
x =
    case a -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks a
x of
      Maybe ThunkInfo
Nothing        -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      Just ThunkInfo
thunkInfo -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Found thunk " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ThunkInfo -> [Char]
forall a. Show a => a -> [Char]
show ThunkInfo
thunkInfo) Bool
False

propNoThunks :: NoThunks a => a -> IO Property
propNoThunks :: forall a. NoThunks a => a -> IO Property
propNoThunks a
x = do
    Maybe ThunkInfo
thunkInfoMay <- Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks [] a
x
    Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ case Maybe ThunkInfo
thunkInfoMay of
      Maybe ThunkInfo
Nothing        -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      Just ThunkInfo
thunkInfo -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Found thunk " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ThunkInfo -> [Char]
forall a. Show a => a -> [Char]
show ThunkInfo
thunkInfo) Bool
False

{-------------------------------------------------------------------------------
  Public API
-------------------------------------------------------------------------------}

-- | Also checks 'NoThunks' for the 'Normal.Table's that are known to be
-- open in the 'Common.Session'.
instance (NoThunksIOLike m, Typeable m, Typeable (PrimState m))
      => NoThunks (Session' m ) where
  showTypeOf :: Proxy (Session' m) -> [Char]
showTypeOf (Proxy (Session' m)
_ :: Proxy (Session' m)) = [Char]
"Session'"
  wNoThunks :: Context -> Session' m -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (Session' Session m h
s) = Context -> Session m h -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx Session m h
s

-- | Does not check 'NoThunks' for the 'Common.Session' that this
-- 'Normal.Table' belongs to.
instance (NoThunksIOLike m, Typeable m, Typeable (PrimState m))
      => NoThunks (NormalTable m k v b) where
  showTypeOf :: Proxy (NormalTable m k v b) -> [Char]
showTypeOf (Proxy (NormalTable m k v b)
_ :: Proxy (NormalTable m k v b)) = [Char]
"NormalTable"
  wNoThunks :: Context -> NormalTable m k v b -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (NormalTable Table m h
t) = Context -> Table m h -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx Table m h
t

{-------------------------------------------------------------------------------
  Internal
-------------------------------------------------------------------------------}

deriving stock instance Generic (Internal.Session m h)
-- | Also checks 'NoThunks' for the 'Internal.Table's that are known to be
-- open in the 'Internal.Session'.
deriving anyclass instance (NoThunksIOLike m, Typeable m, Typeable h, Typeable (PrimState m))
                        => NoThunks (Internal.Session m h)

deriving stock instance Generic (SessionState m h)
deriving anyclass instance (NoThunksIOLike m, Typeable m, Typeable h, Typeable (PrimState m))
                        => NoThunks (SessionState m h)

deriving stock instance Generic (SessionEnv m h)
deriving anyclass instance (NoThunksIOLike m, Typeable m, Typeable h, Typeable (PrimState m))
                        => NoThunks (SessionEnv m h)

deriving stock instance Generic (Internal.Table m h)
-- | Does not check 'NoThunks' for the 'Internal.Session' that this
-- 'Internal.Table' belongs to.
deriving via AllowThunksIn '["tableSession"] (Table m h)
    instance (NoThunksIOLike m, Typeable m, Typeable h, Typeable (PrimState m))
          => NoThunks (Internal.Table m h)

deriving stock instance Generic (TableState m h)
deriving anyclass instance (NoThunksIOLike m, Typeable m, Typeable h, Typeable (PrimState m))
                        => NoThunks (TableState m h)

deriving stock instance Generic (TableEnv m h)
deriving via AllowThunksIn '["tableSessionEnv"] (TableEnv m h)
    instance (NoThunksIOLike m, Typeable m, Typeable h, Typeable (PrimState m))
          => NoThunks (TableEnv m h)

-- | Does not check 'NoThunks' for the 'Internal.Session' that this
-- 'Internal.Cursor' belongs to.
deriving stock instance Generic (Internal.Cursor m h)
deriving anyclass instance (NoThunksIOLike m, Typeable m, Typeable h, Typeable (PrimState m))
                        => NoThunks (Internal.Cursor m h)

deriving stock instance Generic (CursorState m h)
deriving anyclass instance (NoThunksIOLike m, Typeable m, Typeable h, Typeable (PrimState m))
                        => NoThunks (CursorState m h)

deriving stock instance Generic (CursorEnv m h)
deriving via AllowThunksIn ["cursorSession", "cursorSessionEnv"] (CursorEnv m h)
    instance (Typeable m, Typeable h, Typeable (PrimState m))
          => NoThunks (CursorEnv m h)

deriving stock instance Generic TableId
deriving anyclass instance NoThunks TableId

deriving stock instance Generic CursorId
deriving anyclass instance NoThunks CursorId

{-------------------------------------------------------------------------------
  UniqCounter
-------------------------------------------------------------------------------}

deriving stock instance Generic (UniqCounter m)
deriving anyclass instance (NoThunks (PrimVar (PrimState m) Int))
                        => NoThunks (UniqCounter m)

{-------------------------------------------------------------------------------
  Serialise
-------------------------------------------------------------------------------}

deriving stock instance Generic RawBytes
deriving anyclass instance NoThunks RawBytes

deriving stock instance Generic SerialisedKey
deriving anyclass instance NoThunks SerialisedKey

deriving stock instance Generic SerialisedValue
deriving anyclass instance NoThunks SerialisedValue

deriving stock instance Generic SerialisedBlob
deriving anyclass instance NoThunks SerialisedBlob

instance NoThunks (Unsliced a) where
  showTypeOf :: Proxy (Unsliced a) -> [Char]
showTypeOf (Proxy (Unsliced a)
_ :: Proxy (Unsliced a)) = [Char]
"Unsliced"
  wNoThunks :: Context -> Unsliced a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (Unsliced a
x :: Unsliced a) = Context -> ByteArray -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx ByteArray
y
    where
      -- Unsliced is a newtype around a ByteArray, so we can unsafeCoerce
      -- safely. The bang pattern will only evaluate the coercion, because the
      -- byte array is already in WHNF.
      y :: ByteArray
      !y :: ByteArray
y = Unsliced a -> ByteArray
forall a b. a -> b
unsafeCoerce Unsliced a
x

{-------------------------------------------------------------------------------
  Run
-------------------------------------------------------------------------------}

deriving stock instance Generic (Run m h)
deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
                        => NoThunks (Run m h)

deriving stock instance Generic RunParams
deriving anyclass instance NoThunks RunParams

deriving stock instance Generic RunBloomFilterAlloc
deriving anyclass instance NoThunks RunBloomFilterAlloc

deriving stock instance Generic RunDataCaching
deriving anyclass instance NoThunks RunDataCaching

deriving stock instance Generic IndexType
deriving anyclass instance NoThunks IndexType

{-------------------------------------------------------------------------------
  Paths
-------------------------------------------------------------------------------}

deriving stock instance Generic RunNumber
deriving anyclass instance NoThunks RunNumber

deriving stock instance Generic SessionRoot
deriving anyclass instance NoThunks SessionRoot

deriving stock instance Generic RunFsPaths
deriving anyclass instance NoThunks RunFsPaths

deriving stock instance Generic (ForKOps a)
deriving anyclass instance NoThunks a => NoThunks (ForKOps a)

deriving stock instance Generic (ForBlob a)
deriving anyclass instance NoThunks a => NoThunks (ForBlob a)

deriving stock instance Generic (ForFilter a)
deriving anyclass instance NoThunks a => NoThunks (ForFilter a)

deriving stock instance Generic (ForIndex a)
deriving anyclass instance NoThunks a => NoThunks (ForIndex a)

deriving stock instance Generic (ForRunFiles a)
deriving anyclass instance NoThunks a => NoThunks (ForRunFiles a)

{-------------------------------------------------------------------------------
  CRC32C
-------------------------------------------------------------------------------}

deriving stock instance Generic CRC32C
deriving anyclass instance NoThunks CRC32C

{-------------------------------------------------------------------------------
  WriteBuffer
-------------------------------------------------------------------------------}

instance NoThunks WriteBuffer where
  showTypeOf :: Proxy WriteBuffer -> [Char]
showTypeOf (Proxy WriteBuffer
_ :: Proxy WriteBuffer) = [Char]
"WriteBuffer"
  wNoThunks :: Context -> WriteBuffer -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (WriteBuffer
x :: WriteBuffer) = Context
-> Map SerialisedKey (Entry SerialisedValue BlobSpan)
-> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx Map SerialisedKey (Entry SerialisedValue BlobSpan)
y
    where
      -- toMap simply unwraps the WriteBuffer newtype wrapper. The bang pattern
      -- will only evaluate the coercion, because the inner Map is already in
      -- WHNF.
      y :: Map SerialisedKey (Entry SerialisedValue BlobSpan)
      !y :: Map SerialisedKey (Entry SerialisedValue BlobSpan)
y = WriteBuffer -> Map SerialisedKey (Entry SerialisedValue BlobSpan)
toMap WriteBuffer
x

{-------------------------------------------------------------------------------
  BlobFile
-------------------------------------------------------------------------------}

deriving stock instance Generic (WriteBufferBlobs m h)
deriving anyclass instance (Typeable (PrimState m), Typeable m, Typeable h)
                        => NoThunks (WriteBufferBlobs m h)

deriving stock instance Generic (FilePointer m)
deriving anyclass instance Typeable (PrimState m)
                        => NoThunks (FilePointer m)

{-------------------------------------------------------------------------------
  Index
-------------------------------------------------------------------------------}

deriving stock instance Generic IndexCompact
deriving anyclass instance NoThunks IndexCompact

deriving stock instance Generic PageNo
deriving anyclass instance NoThunks PageNo

deriving stock instance Generic IndexOrdinary
deriving anyclass instance NoThunks IndexOrdinary

deriving stock instance Generic Index
deriving anyclass instance NoThunks Index

{-------------------------------------------------------------------------------
  MergeSchedule
-------------------------------------------------------------------------------}

deriving stock instance Generic (TableContent m h)
deriving anyclass instance
  ( Typeable m, Typeable (PrimState m), Typeable h
  , NoThunks (StrictMVar m (MergingRunState LevelMergeType m h))
  , NoThunks (StrictMVar m (MergingTreeState m h))
  ) => NoThunks (TableContent m h)

deriving stock instance Generic (LevelsCache m h)
deriving anyclass instance
  (Typeable m, Typeable (PrimState m), Typeable h)
  => NoThunks (LevelsCache m h)

deriving stock instance Generic (Level m h)
deriving anyclass instance
  ( Typeable m, Typeable (PrimState m), Typeable h
  , NoThunks (StrictMVar m (MergingRunState LevelMergeType m h))
  ) => NoThunks (Level m h)

deriving stock instance Generic (IncomingRun m h)
deriving anyclass instance
  ( Typeable m, Typeable (PrimState m), Typeable h
  , NoThunks (StrictMVar m (MergingRunState LevelMergeType m h))
  ) => NoThunks (IncomingRun m h)

deriving stock instance Generic (UnionLevel m h)
deriving anyclass instance
  ( Typeable m, Typeable (PrimState m), Typeable h
  , NoThunks (StrictMVar m (MergingTreeState m h))
  ) => NoThunks (UnionLevel m h)

deriving stock instance Generic MergePolicyForLevel
deriving anyclass instance NoThunks MergePolicyForLevel

deriving stock instance Generic NominalDebt
deriving anyclass instance NoThunks NominalDebt

deriving stock instance Generic NominalCredits
deriving anyclass instance NoThunks NominalCredits

{-------------------------------------------------------------------------------
  MergingRun
-------------------------------------------------------------------------------}

deriving stock instance Generic (MergingRun t m h)
deriving anyclass instance ( Typeable m, Typeable (PrimState m), Typeable h
                           , NoThunks (StrictMVar m (MergingRunState t m h))
                           ) => NoThunks (MergingRun t m h)

deriving stock instance Generic (MergingRunState t m h)
deriving anyclass instance ( Typeable m, Typeable (PrimState m), Typeable h
                           , NoThunks t
                           ) => NoThunks (MergingRunState t m h)

deriving stock instance Generic MergeDebt
deriving anyclass instance NoThunks MergeDebt

deriving stock instance Generic MergeCredits
deriving anyclass instance NoThunks MergeCredits

deriving stock instance Generic (CreditsVar s)
deriving anyclass instance Typeable s => NoThunks (CreditsVar s)

deriving stock instance Generic MergeKnownCompleted
deriving anyclass instance NoThunks MergeKnownCompleted

{-------------------------------------------------------------------------------
  MergingTree
-------------------------------------------------------------------------------}

deriving stock instance Generic (MergingTree m h)
deriving anyclass instance
  ( Typeable m, Typeable (PrimState m), Typeable h
  , NoThunks (StrictMVar m (MergingTreeState m h))
  ) => NoThunks (MergingTree m h)

deriving stock instance Generic (MergingTreeState m h)
deriving anyclass instance
  ( Typeable m, Typeable (PrimState m), Typeable h
  , NoThunks (StrictMVar m (MergingRunState LevelMergeType m h))
  , NoThunks (StrictMVar m (MergingRunState TreeMergeType m h))
  , NoThunks (StrictMVar m (MergingTreeState m h))
  ) => NoThunks (MergingTreeState m h)

deriving stock instance Generic (PendingMerge m h)
deriving anyclass instance
  ( Typeable m, Typeable (PrimState m), Typeable h
  , NoThunks (StrictMVar m (MergingRunState LevelMergeType m h))
  , NoThunks (StrictMVar m (MergingTreeState m h))
  ) => NoThunks (PendingMerge m h)

deriving stock instance Generic (PreExistingRun m h)
deriving anyclass instance
  ( Typeable m, Typeable (PrimState m), Typeable h
  , NoThunks (StrictMVar m (MergingRunState LevelMergeType m h))
  ) => NoThunks (PreExistingRun m h)

{-------------------------------------------------------------------------------
  Entry
-------------------------------------------------------------------------------}

deriving stock instance Generic (Entry v b)
deriving anyclass instance (NoThunks v, NoThunks b)
                        => NoThunks (Entry v b)

deriving stock instance Generic NumEntries
deriving anyclass instance NoThunks NumEntries

{-------------------------------------------------------------------------------
  RunBuilder
-------------------------------------------------------------------------------}

deriving stock instance Generic (RunBuilder m h)
deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
                        => NoThunks (RunBuilder m h)

deriving stock instance Generic (ChecksumHandle s h)
deriving anyclass instance (Typeable s, Typeable h)
                        => NoThunks (ChecksumHandle s h)

{-------------------------------------------------------------------------------
  RunAcc
-------------------------------------------------------------------------------}

deriving stock instance Generic (RunAcc s)
deriving anyclass instance Typeable s
                        => NoThunks (RunAcc s)

{-------------------------------------------------------------------------------
  IndexAcc
-------------------------------------------------------------------------------}

deriving stock instance Generic (IndexCompactAcc s)
deriving anyclass instance Typeable s
                        => NoThunks (IndexCompactAcc s)

deriving stock instance Generic (SMaybe a)
deriving anyclass instance NoThunks a => NoThunks (SMaybe a)

deriving stock instance Generic (IndexOrdinaryAcc s)
deriving anyclass instance Typeable s
                        => NoThunks (IndexOrdinaryAcc s)

deriving stock instance Generic (IndexAcc s)
deriving anyclass instance Typeable s
                        => NoThunks (IndexAcc s)

{-------------------------------------------------------------------------------
  GrowingVector
-------------------------------------------------------------------------------}

instance (NoThunks a, Typeable s, Typeable a) => NoThunks (GrowingVector s a) where
  showTypeOf :: Proxy (GrowingVector s a) -> [Char]
showTypeOf (Proxy (GrowingVector s a)
p :: Proxy (GrowingVector s a)) = TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep -> [Char]) -> TypeRep -> [Char]
forall a b. (a -> b) -> a -> b
$ Proxy (GrowingVector s a) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (GrowingVector s a)
p
  wNoThunks :: Context -> GrowingVector s a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx
    (GrowingVector (STRef s (MVector s a)
a :: STRef s (VM.MVector s a)) (PrimVar s Int
b :: PrimVar s Int))
    = [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [
          Context -> PrimVar s Int -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx PrimVar s Int
b
          -- Check that the STRef is in WHNF
        , Context
-> OnlyCheckWhnf (STRef s (MVector s a)) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx (OnlyCheckWhnf (STRef s (MVector s a)) -> IO (Maybe ThunkInfo))
-> OnlyCheckWhnf (STRef s (MVector s a)) -> IO (Maybe ThunkInfo)
forall a b. (a -> b) -> a -> b
$ STRef s (MVector s a) -> OnlyCheckWhnf (STRef s (MVector s a))
forall a. a -> OnlyCheckWhnf a
OnlyCheckWhnf STRef s (MVector s a)
a
          -- Check that the MVector is in WHNF
        , do
            MVector s a
mvec <- ST s (MVector s a) -> IO (MVector s a)
forall s a. ST s a -> IO a
unsafeSTToIO (ST s (MVector s a) -> IO (MVector s a))
-> ST s (MVector s a) -> IO (MVector s a)
forall a b. (a -> b) -> a -> b
$ STRef s (MVector s a) -> ST s (MVector s a)
forall s a. STRef s a -> ST s a
readSTRef STRef s (MVector s a)
a
            Context -> OnlyCheckWhnf (MVector s a) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx' (OnlyCheckWhnf (MVector s a) -> IO (Maybe ThunkInfo))
-> OnlyCheckWhnf (MVector s a) -> IO (Maybe ThunkInfo)
forall a b. (a -> b) -> a -> b
$ MVector s a -> OnlyCheckWhnf (MVector s a)
forall a. a -> OnlyCheckWhnf a
OnlyCheckWhnf MVector s a
mvec
          -- Check that the vector elements contain no thunks. The vector
          -- contains undefined elements after the first @n@ elements
        , do
            Int
n <- ST s Int -> IO Int
forall s a. ST s a -> IO a
unsafeSTToIO (ST s Int -> IO Int) -> ST s Int -> IO Int
forall a b. (a -> b) -> a -> b
$ PrimVar (PrimState (ST s)) Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> m a
readPrimVar PrimVar s Int
PrimVar (PrimState (ST s)) Int
b
            MVector s a
mvec <- ST s (MVector s a) -> IO (MVector s a)
forall s a. ST s a -> IO a
unsafeSTToIO (ST s (MVector s a) -> IO (MVector s a))
-> ST s (MVector s a) -> IO (MVector s a)
forall a b. (a -> b) -> a -> b
$ STRef s (MVector s a) -> ST s (MVector s a)
forall s a. STRef s a -> ST s a
readSTRef STRef s (MVector s a)
a
            [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [
                ST s a -> IO a
forall s a. ST s a -> IO a
unsafeSTToIO (MVector (PrimState (ST s)) a -> Int -> ST s a
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
VM.read MVector s a
MVector (PrimState (ST s)) a
mvec Int
i) IO a -> (a -> IO (Maybe ThunkInfo)) -> IO (Maybe ThunkInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx'' a
x
              | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
              ]
        ]
    where
      ctx' :: Context
ctx' = Proxy (STRef s (MVector s a)) -> [Char]
forall a. NoThunks a => Proxy a -> [Char]
showTypeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(STRef s (VM.MVector s a))) [Char] -> Context -> Context
forall a. a -> [a] -> [a]
: Context
ctx
      ctx'' :: Context
ctx'' = Proxy (MVector s a) -> [Char]
forall a. NoThunks a => Proxy a -> [Char]
showTypeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(VM.MVector s a)) [Char] -> Context -> Context
forall a. a -> [a] -> [a]
: Context
ctx'

{-------------------------------------------------------------------------------
  Baler
-------------------------------------------------------------------------------}

deriving stock instance Generic (Baler s)
deriving anyclass instance Typeable s
                        => NoThunks (Baler s)

{-------------------------------------------------------------------------------
  PageAcc
-------------------------------------------------------------------------------}

deriving stock instance Generic (PageAcc s)
deriving anyclass instance Typeable s
                        => NoThunks (PageAcc s)

{-------------------------------------------------------------------------------
  Merge
-------------------------------------------------------------------------------}

deriving stock instance Generic (Merge t m h)
deriving anyclass instance ( Typeable m, Typeable (PrimState m), Typeable h
                           , NoThunks t
                           ) => NoThunks (Merge t m h)

deriving stock instance Generic MergeType
deriving anyclass instance NoThunks MergeType

deriving stock instance Generic LevelMergeType
deriving anyclass instance NoThunks LevelMergeType

deriving stock instance Generic TreeMergeType
deriving anyclass instance NoThunks TreeMergeType

deriving stock instance Generic Merge.StepResult
deriving anyclass instance NoThunks Merge.StepResult

deriving stock instance Generic Merge.MergeState
deriving anyclass instance NoThunks Merge.MergeState

{-------------------------------------------------------------------------------
  Readers
-------------------------------------------------------------------------------}

deriving stock instance Generic (Readers m h)
deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
                        => NoThunks (Readers m h)

deriving stock instance Generic (Reader m h)
instance (Typeable m, Typeable (PrimState m), Typeable h)
      => NoThunks (Reader m h) where
  showTypeOf :: Proxy (Reader m h) -> [Char]
showTypeOf (Proxy (Reader m h)
_ :: Proxy (Reader m h)) = [Char]
"Reader"
  wNoThunks :: Context -> Reader m h -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx = \case
    ReadRun RunReader m h
r      -> Context -> RunReader m h -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx RunReader m h
r
    ReadBuffer MutVar (PrimState m) [KOp m h]
var -> Context
-> OnlyCheckWhnf (MutVar (PrimState m) [KOp m h])
-> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx (MutVar (PrimState m) [KOp m h]
-> OnlyCheckWhnf (MutVar (PrimState m) [KOp m h])
forall a. a -> OnlyCheckWhnf a
OnlyCheckWhnf MutVar (PrimState m) [KOp m h]
var) -- contents intentionally lazy

deriving stock instance Generic ReaderNumber
deriving anyclass instance NoThunks ReaderNumber

deriving stock instance Generic (ReadCtx m h)
deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
                        => NoThunks (ReadCtx m h)

{-------------------------------------------------------------------------------
  Reader
-------------------------------------------------------------------------------}

deriving stock instance Generic (RunReader m h)
deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h)
                        => NoThunks (RunReader m h)

-- | Allows thunks in the overflow pages
instance ( Typeable m, Typeable (PrimState m), Typeable h
         ) => NoThunks (Reader.Entry m h) where
  showTypeOf :: Proxy (Entry m h) -> [Char]
showTypeOf (Proxy (Entry m h)
p :: Proxy (Reader.Entry m h)) = TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep -> [Char]) -> TypeRep -> [Char]
forall a b. (a -> b) -> a -> b
$ Proxy (Entry m h) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (Entry m h)
p
  wNoThunks :: Context -> Entry m h -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (Reader.Entry (Entry SerialisedValue (RawBlobRef m h)
e :: Entry SerialisedValue (RawBlobRef m h))) = Context
-> Entry SerialisedValue (RawBlobRef m h) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx Entry SerialisedValue (RawBlobRef m h)
e
  wNoThunks Context
ctx (EntryOverflow
    (Entry SerialisedValue (RawBlobRef m h)
entryPrefix :: Entry SerialisedValue (RawBlobRef m h))
    (RawPage
page :: RawPage)
    (Word32
len :: Word32)
    ([RawOverflowPage]
overflowPages :: [RawOverflowPage]) ) =
      [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [
          Context
-> Entry SerialisedValue (RawBlobRef m h) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx Entry SerialisedValue (RawBlobRef m h)
entryPrefix
        , Context -> RawPage -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx RawPage
page
        , Context -> Word32 -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx Word32
len
        , Context -> OnlyCheckWhnf [RawOverflowPage] -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx ([RawOverflowPage] -> OnlyCheckWhnf [RawOverflowPage]
forall a. a -> OnlyCheckWhnf a
OnlyCheckWhnf [RawOverflowPage]
overflowPages)
        ]

{-------------------------------------------------------------------------------
  RawPage
-------------------------------------------------------------------------------}

deriving stock instance Generic RawPage
deriving anyclass instance NoThunks RawPage

{-------------------------------------------------------------------------------
  RawPage
-------------------------------------------------------------------------------}

deriving stock instance Generic RawOverflowPage
deriving anyclass instance NoThunks RawOverflowPage

{-------------------------------------------------------------------------------
  BlobRef
-------------------------------------------------------------------------------}

deriving stock instance Generic BlobSpan
deriving anyclass instance NoThunks BlobSpan

deriving stock instance Generic (BlobFile m h)
deriving anyclass instance (Typeable h, Typeable (PrimState m))
                        => NoThunks (BlobFile m h)

deriving stock instance Generic (RawBlobRef m h)
deriving anyclass instance (Typeable h, Typeable (PrimState m))
                        => NoThunks (RawBlobRef m h)

deriving stock instance Generic (WeakBlobRef m h)
deriving anyclass instance (Typeable h, Typeable m, Typeable (PrimState m))
                        => NoThunks (WeakBlobRef m h)

{-------------------------------------------------------------------------------
  Arena
-------------------------------------------------------------------------------}

-- TODO: proper instance
deriving via OnlyCheckWhnf (ArenaManager m)
    instance Typeable m => NoThunks (ArenaManager m)

{-------------------------------------------------------------------------------
  Config
-------------------------------------------------------------------------------}

deriving stock instance Generic TableConfig
deriving anyclass instance NoThunks TableConfig

deriving stock instance Generic MergePolicy
deriving anyclass instance NoThunks MergePolicy

deriving stock instance Generic SizeRatio
deriving anyclass instance NoThunks SizeRatio

deriving stock instance Generic WriteBufferAlloc
deriving anyclass instance NoThunks WriteBufferAlloc

deriving stock instance Generic BloomFilterAlloc
deriving anyclass instance NoThunks BloomFilterAlloc

deriving stock instance Generic FencePointerIndexType
deriving anyclass instance NoThunks FencePointerIndexType

deriving stock instance Generic DiskCachePolicy
deriving anyclass instance NoThunks DiskCachePolicy

deriving stock instance Generic MergeSchedule
deriving anyclass instance NoThunks MergeSchedule

{-------------------------------------------------------------------------------
  RWVar
-------------------------------------------------------------------------------}

deriving stock instance Generic (RWVar m a)
deriving anyclass instance NoThunks (StrictTVar m (RWState a)) => NoThunks (RWVar m a)

deriving stock instance Generic (RWState a)
deriving anyclass instance NoThunks a => NoThunks (RWState a)

{-------------------------------------------------------------------------------
  RefCounter
-------------------------------------------------------------------------------}

instance Typeable (PrimState m) => NoThunks (RefCounter m) where
  showTypeOf :: Proxy (RefCounter m) -> [Char]
showTypeOf (Proxy (RefCounter m)
_ :: Proxy (RefCounter m)) = [Char]
"RefCounter"
  wNoThunks :: Context -> RefCounter m -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx
    (RefCounter (PrimVar (PrimState m) Int
a :: PrimVar (PrimState m) Int) (m ()
b :: m ()))
    = [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [
          Context -> PrimVar (PrimState m) Int -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx PrimVar (PrimState m) Int
a
        , Context
-> OnlyCheckWhnfNamed "finaliser" (m ()) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx (OnlyCheckWhnfNamed "finaliser" (m ()) -> IO (Maybe ThunkInfo))
-> OnlyCheckWhnfNamed "finaliser" (m ()) -> IO (Maybe ThunkInfo)
forall a b. (a -> b) -> a -> b
$ (m () -> OnlyCheckWhnfNamed "finaliser" (m ())
forall (name :: Symbol) a. a -> OnlyCheckWhnfNamed name a
OnlyCheckWhnfNamed m ()
b :: OnlyCheckWhnfNamed "finaliser" (m ()))
        ]

-- Ref constructor not exported, cannot derive Generic, use DeRef instead.
instance (NoThunks obj, Typeable obj) => NoThunks (Ref obj) where
  showTypeOf :: Proxy (Ref obj) -> [Char]
showTypeOf p :: Proxy (Ref obj)
p@(Proxy (Ref obj)
_ :: Proxy (Ref obj)) = TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep -> [Char]) -> TypeRep -> [Char]
forall a b. (a -> b) -> a -> b
$ Proxy (Ref obj) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (Ref obj)
p
  wNoThunks :: Context -> Ref obj -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (DeRef obj
ref) = Context -> obj -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx obj
ref

deriving stock instance Generic (WeakRef obj)
deriving anyclass instance (NoThunks obj, Typeable obj) => NoThunks (WeakRef obj)

{-------------------------------------------------------------------------------
  kmerge
-------------------------------------------------------------------------------}

instance (NoThunks a, Typeable s, Typeable a) => NoThunks (MutableHeap s a) where
  showTypeOf :: Proxy (MutableHeap s a) -> [Char]
showTypeOf (Proxy (MutableHeap s a)
p :: Proxy (MutableHeap s a)) = TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep -> [Char]) -> TypeRep -> [Char]
forall a b. (a -> b) -> a -> b
$ Proxy (MutableHeap s a) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (MutableHeap s a)
p
  wNoThunks :: Context -> MutableHeap s a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx
    (MH (PrimVar s Int
a :: PrimVar s Int) (SmallMutableArray s a
b :: SmallMutableArray s a))
    = [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [
          Context -> PrimVar s Int -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx PrimVar s Int
a
          -- Check that the array is in WHNF
        , Context
-> OnlyCheckWhnf (SmallMutableArray s a) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx (SmallMutableArray s a -> OnlyCheckWhnf (SmallMutableArray s a)
forall a. a -> OnlyCheckWhnf a
OnlyCheckWhnf SmallMutableArray s a
b)
          -- Check that the array elements contain no thunks. The small array
          -- may contain undefined placeholder values after the first @n@
          -- elements in the array. The very first element of the array can also
          -- be undefined.
        , do
            Int
n <- ST s Int -> IO Int
forall s a. ST s a -> IO a
unsafeSTToIO (PrimVar (PrimState (ST s)) Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> m a
readPrimVar PrimVar s Int
PrimVar (PrimState (ST s)) Int
a)
            [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [
                ST s a -> IO a
forall s a. ST s a -> IO a
unsafeSTToIO (SmallMutableArray (PrimState (ST s)) a -> Int -> ST s a
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> m a
readSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
b Int
i) IO a -> (a -> IO (Maybe ThunkInfo)) -> IO (Maybe ThunkInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx' a
x
              | Int
i <- [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
              ]
        ]
    where
      ctx' :: Context
ctx' = Proxy (SmallMutableArray s a) -> [Char]
forall a. NoThunks a => Proxy a -> [Char]
showTypeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(SmallMutableArray s a)) [Char] -> Context -> Context
forall a. a -> [a] -> [a]
: Context
ctx

{-------------------------------------------------------------------------------
  IOLike
-------------------------------------------------------------------------------}

-- | 'NoThunks' constraints for IO-like monads
--
-- Some constraints, like @NoThunks (MutVar s a)@ and @NoThunks (StrictTVar m
-- a)@, can not be satisfied for arbitrary @m@\/@s@, and must be instantiated
-- for a concrete @m@\/@s@, like @IO@\/@RealWorld@.
class ( forall a. (NoThunks a, Typeable a) => NoThunks (StrictTVar m a)
      , forall a. (NoThunks a, Typeable a) => NoThunks (StrictMVar m a)
      ) => NoThunksIOLike' m s

instance NoThunksIOLike' IO RealWorld

type NoThunksIOLike m = NoThunksIOLike' m (PrimState m)

instance (NoThunks a, Typeable a) => NoThunks (StrictTVar IO a) where
  showTypeOf :: Proxy (StrictTVar IO a) -> [Char]
showTypeOf (Proxy (StrictTVar IO a)
p :: Proxy (StrictTVar IO a)) = TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep -> [Char]) -> TypeRep -> [Char]
forall a b. (a -> b) -> a -> b
$ Proxy (StrictTVar IO a) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (StrictTVar IO a)
p
  wNoThunks :: Context -> StrictTVar IO a -> IO (Maybe ThunkInfo)
wNoThunks Context
_ctx StrictTVar IO a
_var = do
    a
x <- StrictTVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar IO a
_var
    Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
_ctx a
x

-- TODO: in some cases, strict-mvar functions leave thunks behind, in particular
-- modifyMVarMasked and modifyMVarMasked_. So in some specific cases we evaluate
-- the contents of the MVar to WHNF, and keep checking nothunks from there. See
-- lsm-tree#444.
--
-- TODO: we tried using overlapping instances for @StrictMVar IO a@ and
-- @StrictMVar IO (MergingRunState IO h)@, but the quantified constraint in
-- NoThunksIOLike' will throw a compiler error telling us to mark the instances
-- for StrictMVar as incoherent. Marking them as incoherent makes the tests
-- fail... We are unsure if it can be overcome, but the current casting approach
-- works, so there is no priority to use rewrite this code to use overlapping
-- instances.
instance (NoThunks a, Typeable a) => NoThunks (StrictMVar IO a) where
  showTypeOf :: Proxy (StrictMVar IO a) -> [Char]
showTypeOf (Proxy (StrictMVar IO a)
p :: Proxy (StrictMVar IO a)) = TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep -> [Char]) -> TypeRep -> [Char]
forall a b. (a -> b) -> a -> b
$ Proxy (StrictMVar IO a) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (StrictMVar IO a)
p
  wNoThunks :: Context -> StrictMVar IO a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx StrictMVar IO a
var
    -- TODO: Revisit which of these cases are still needed.
    | Just (Proxy (MergingRunState LevelMergeType IO HandleIO)
Proxy :: Proxy (MergingRunState LevelMergeType IO HandleIO))
        <- Proxy a
-> Maybe (Proxy (MergingRunState LevelMergeType IO HandleIO))
forall {k} (a :: k) (b :: k) (c :: k -> *).
(Typeable a, Typeable b) =>
c a -> Maybe (c b)
gcast (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
    = IO (Maybe ThunkInfo)
workAroundCheck
    | Just (Proxy (MergingRunState TreeMergeType IO HandleIO)
Proxy :: Proxy (MergingRunState TreeMergeType IO HandleIO))
        <- Proxy a
-> Maybe (Proxy (MergingRunState TreeMergeType IO HandleIO))
forall {k} (a :: k) (b :: k) (c :: k -> *).
(Typeable a, Typeable b) =>
c a -> Maybe (c b)
gcast (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
    = IO (Maybe ThunkInfo)
workAroundCheck
    | Just (Proxy (MergingRunState LevelMergeType IO HandleMock)
Proxy :: Proxy (MergingRunState LevelMergeType IO HandleMock))
        <- Proxy a
-> Maybe (Proxy (MergingRunState LevelMergeType IO HandleMock))
forall {k} (a :: k) (b :: k) (c :: k -> *).
(Typeable a, Typeable b) =>
c a -> Maybe (c b)
gcast (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
    = IO (Maybe ThunkInfo)
workAroundCheck
    | Just (Proxy (MergingRunState TreeMergeType IO HandleMock)
Proxy :: Proxy (MergingRunState TreeMergeType IO HandleMock))
        <- Proxy a
-> Maybe (Proxy (MergingRunState TreeMergeType IO HandleMock))
forall {k} (a :: k) (b :: k) (c :: k -> *).
(Typeable a, Typeable b) =>
c a -> Maybe (c b)
gcast (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
    = IO (Maybe ThunkInfo)
workAroundCheck
    | Bool
otherwise
    = IO (Maybe ThunkInfo)
properCheck
    where
      properCheck :: IO (Maybe ThunkInfo)
properCheck = do
        a
x <- StrictMVar IO a -> IO a
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
readMVar StrictMVar IO a
var
        Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx a
x

      workAroundCheck :: IO (Maybe ThunkInfo)
workAroundCheck = do
        !a
x <- StrictMVar IO a -> IO a
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
readMVar StrictMVar IO a
var
        Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx a
x

{-------------------------------------------------------------------------------
  vector
-------------------------------------------------------------------------------}

-- TODO: upstream to @nothunks@
instance (NoThunks a, Typeable s, Typeable a) => NoThunks (VM.MVector s a) where
    showTypeOf :: Proxy (MVector s a) -> [Char]
showTypeOf (Proxy (MVector s a)
p :: Proxy (VM.MVector s a)) = TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep -> [Char]) -> TypeRep -> [Char]
forall a b. (a -> b) -> a -> b
$ Proxy (MVector s a) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (MVector s a)
p
    wNoThunks :: Context -> MVector s a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx MVector s a
v =
      [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [
          ST s (Maybe ThunkInfo) -> IO (Maybe ThunkInfo)
forall s a. ST s a -> IO a
unsafeSTToIO (MVector (PrimState (ST s)) a -> Int -> ST s a
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
VM.read MVector s a
MVector (PrimState (ST s)) a
v Int
i ST s a -> (a -> ST s (Maybe ThunkInfo)) -> ST s (Maybe ThunkInfo)
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ a
x -> IO (Maybe ThunkInfo) -> ST s (Maybe ThunkInfo)
forall a s. IO a -> ST s a
unsafeIOToST (Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx a
x))
        | Int
i <- [Int
0.. MVector s a -> Int
forall s a. MVector s a -> Int
VM.length MVector s a
vInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
        ]

-- TODO: https://github.com/input-output-hk/nothunks/issues/57
deriving via OnlyCheckWhnf (VP.Vector a)
    instance Typeable a => NoThunks (VP.Vector a)

-- TODO: upstream to @nothunks@
deriving via OnlyCheckWhnf (VUM.MVector s Word64)
    instance Typeable s => NoThunks (VUM.MVector s Word64)

-- TODO: upstream to @nothunks@
deriving via OnlyCheckWhnf (VUM.MVector s Bit)
    instance Typeable s => NoThunks (VUM.MVector s Bit)

-- TODO: upstream to @nothunks@
deriving via OnlyCheckWhnf (VP.MVector s Word8)
    instance Typeable s => NoThunks (VP.MVector s Word8)

{-------------------------------------------------------------------------------
  ST
-------------------------------------------------------------------------------}

-- TODO: upstream to @nothunks@
instance NoThunks a => NoThunks (STRef s a) where
  showTypeOf :: Proxy (STRef s a) -> [Char]
showTypeOf (Proxy (STRef s a)
_ :: Proxy (STRef s a)) = [Char]
"STRef"
  wNoThunks :: Context -> STRef s a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx STRef s a
ref = do
    a
x <- ST s a -> IO a
forall s a. ST s a -> IO a
unsafeSTToIO (ST s a -> IO a) -> ST s a -> IO a
forall a b. (a -> b) -> a -> b
$ STRef s a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef STRef s a
ref
    Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx a
x

{-------------------------------------------------------------------------------
  primitive
-------------------------------------------------------------------------------}

-- TODO: https://github.com/input-output-hk/nothunks/issues/56
instance NoThunks a => NoThunks (MutVar s a) where
  showTypeOf :: Proxy (MutVar s a) -> [Char]
showTypeOf (Proxy (MutVar s a)
_ :: Proxy (MutVar s a)) = [Char]
"MutVar"
  wNoThunks :: Context -> MutVar s a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx MutVar s a
var = do
      a
x <- ST s a -> IO a
forall s a. ST s a -> IO a
unsafeSTToIO (ST s a -> IO a) -> ST s a -> IO a
forall a b. (a -> b) -> a -> b
$ MutVar (PrimState (ST s)) a -> ST s a
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar s a
MutVar (PrimState (ST s)) a
var
      Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx a
x

-- TODO: https://github.com/input-output-hk/nothunks/issues/56
deriving via OnlyCheckWhnf (PrimVar s a)
    instance (Typeable s, Typeable a) => NoThunks (PrimVar s a)

-- TODO: https://github.com/input-output-hk/nothunks/issues/56
instance NoThunks a => NoThunks (SmallMutableArray s a) where
  showTypeOf :: Proxy (SmallMutableArray s a) -> [Char]
showTypeOf (Proxy (SmallMutableArray s a)
_ :: Proxy (SmallMutableArray s a)) = [Char]
"SmallMutableArray"
  wNoThunks :: Context -> SmallMutableArray s a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx SmallMutableArray s a
arr = do
      Int
n <- ST s Int -> IO Int
forall s a. ST s a -> IO a
unsafeSTToIO (ST s Int -> IO Int) -> ST s Int -> IO Int
forall a b. (a -> b) -> a -> b
$ SmallMutableArray (PrimState (ST s)) a -> ST s Int
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m Int
getSizeofSmallMutableArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
arr
      [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [
          ST s a -> IO a
forall s a. ST s a -> IO a
unsafeSTToIO (SmallMutableArray (PrimState (ST s)) a -> Int -> ST s a
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> m a
readSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
arr Int
i) IO a -> (a -> IO (Maybe ThunkInfo)) -> IO (Maybe ThunkInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx a
x
        | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
        ]

-- TODO: https://github.com/input-output-hk/nothunks/issues/56
deriving via OnlyCheckWhnf (MutablePrimArray s a)
    instance (Typeable s, Typeable a) => NoThunks (MutablePrimArray s a)

-- TODO: https://github.com/input-output-hk/nothunks/issues/56
deriving via OnlyCheckWhnf ByteArray
    instance NoThunks ByteArray

{-------------------------------------------------------------------------------
  bloomfilter
-------------------------------------------------------------------------------}

-- TODO: check heap?
deriving via OnlyCheckWhnf (Bloom a)
    instance Typeable a => NoThunks (Bloom a)

-- TODO: check heap?
deriving via OnlyCheckWhnf (MBloom s a)
    instance (Typeable s, Typeable a) => NoThunks (MBloom s a)

{-------------------------------------------------------------------------------
  fs-api and fs-sim
-------------------------------------------------------------------------------}

-- TODO: check heap?
deriving via OnlyCheckWhnf (HasFS m h)
    instance (Typeable m, Typeable h) => NoThunks (HasFS m h)

-- TODO: check heap?
deriving via OnlyCheckWhnf (Handle h)
    instance Typeable h => NoThunks (Handle h)

-- TODO: check heap?
deriving via OnlyCheckWhnf FsPath
    instance NoThunks FsPath

{-------------------------------------------------------------------------------
  blockio-api and blockio-sim
-------------------------------------------------------------------------------}

-- TODO: check heap?
deriving via OnlyCheckWhnf (HasBlockIO m h)
    instance (Typeable m, Typeable h) => NoThunks (HasBlockIO m h)

-- TODO: check heap?
deriving via OnlyCheckWhnf (LockFileHandle m)
    instance Typeable m => NoThunks (LockFileHandle m)

{-------------------------------------------------------------------------------
  contra-tracer
-------------------------------------------------------------------------------}

-- TODO: check heap?
deriving via OnlyCheckWhnf (Tracer m a)
    instance (Typeable m, Typeable a) => NoThunks (Tracer m a)