nothunks (empty) → 0.1.0.0
raw patch · 6 files changed
+1393/−0 lines, 6 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, ghc-heap, ghc-prim, hedgehog, nothunks, random, tasty, tasty-hedgehog, text, time, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +19/−0
- nothunks.cabal +51/−0
- src/NoThunks/Class.hs +737/−0
- test/Main.hs +13/−0
- test/Test/NoThunks/Class.hs +568/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for nothunks++## 0.1.0.0 -- 2020-09-09++* Initial public release
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2018 IOHK++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to+do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ nothunks.cabal view
@@ -0,0 +1,51 @@+cabal-version: 2.4+name: nothunks+version: 0.1.0.0+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+ unexpected thunks, which can then be used in assertions.+ This can be invaluable in avoiding memory leaks, or tracking+ down existing ones.+license: MIT+license-file: LICENSE+bug-reports: https://github.com/input-output-hk/nothunks+author: IOHK+maintainer: operations@iohk.io+copyright: 2018-2020 IOHK+category: Development+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/input-output-hk/nothunks++library+ exposed-modules: NoThunks.Class+ build-depends: base >= 4.12 && < 5+ , bytestring >= 0.10+ , containers >= 0.6+ , ghc-heap >= 8.6+ , text >= 1.2+ , time >= 1.8+ , vector >= 0.12+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++test-suite nothunks-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Test.NoThunks.Class+ build-depends: base >= 4.12+ , containers >= 0.6+ , ghc-prim >= 0.5+ , hedgehog >= 1.0+ , random >= 1.1+ , tasty >= 1.2+ , tasty-hedgehog >= 1.0+ , text >= 1.2+ , nothunks+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -Wall
+ src/NoThunks/Class.hs view
@@ -0,0 +1,737 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}++module NoThunks.Class (+ -- * Check a value for unexpected thunks+ NoThunks(..)+ , ThunkInfo(..)+ , unsafeNoThunks+ -- * Helpders for defining instances+ , allNoThunks+ , noThunksInValues+ , noThunksInKeysAndValues+ -- * Deriving-via wrappers+ , OnlyCheckWhnf(..)+ , OnlyCheckWhnfNamed(..)+ , InspectHeap(..)+ , InspectHeapNamed(..)+ , AllowThunk(..)+ , AllowThunksIn(..)+ ) where++import Data.Proxy+import Data.Typeable+import System.IO.Unsafe (unsafePerformIO)++import GHC.Exts.Heap+import GHC.Generics+import GHC.Records+import GHC.TypeLits++-- For instances++import Data.ByteString.Short (ShortByteString)+import Data.Foldable (toList)+import Data.Int+import Data.IntMap (IntMap)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map (Map)+import Data.Ratio+import Data.Sequence (Seq)+import Data.Set (Set)+import Data.Time+import Data.Word+import GHC.Stack+import Numeric.Natural++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.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as Text.Strict+import qualified Data.Text.Internal.Lazy as Text.Lazy.Internal+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Vector as Vector.Boxed+import qualified Data.Vector.Unboxed as Vector.Unboxed++{-------------------------------------------------------------------------------+ Check a value for unexpected thunks+-------------------------------------------------------------------------------}++-- | Check a value for unexpected thunks+class NoThunks a where+ -- | Check if the argument does not contain any unexpected thunks+ --+ -- For most datatypes, we should have that+ --+ -- > noThunks ctxt x == NoThunks+ --+ -- if and only if+ --+ -- > containsThunks x+ --+ -- For some datatypes however, some thunks are expected. For example, the+ -- internal fingertree 'Data.Sequence.Sequence' might contain thunks (this is+ -- important for the asymptotic complexity of this data structure). However,+ -- we should still check that the /values/ in the sequence don't contain any+ -- unexpected thunks.+ --+ -- This means that we need to traverse the sequence, which might force some of+ -- the thunks in the tree. In general, it is acceptable for+ -- 'noThunks' to force such "expected thunks", as long as it always+ -- reports the /unexpected/ thunks.+ --+ -- The default implementation of 'noThunks' checks that the argument+ -- is in WHNF, and if so, adds the type into the context (using 'showTypeOf'),+ -- and calls 'wNoThunks'. See 'UnexpectedThunkInfo' for a+ -- detailed discussion of the type context.+ --+ -- See also discussion of caveats listed for 'NF.containsThunks'.+ noThunks :: Context -> a -> IO (Maybe ThunkInfo)+ noThunks ctxt x = do+ isThunk <- checkIsThunk x+ if isThunk+ then return $ Just ThunkInfo { thunkContext = ctxt' }+ else wNoThunks ctxt' x+ where+ ctxt' :: Context+ ctxt' = showTypeOf (Proxy @a) : ctxt++ -- | Check that the argument is in normal form, assuming it is in WHNF.+ --+ -- The context will already have been extended with the type we're looking at,+ -- so all that's left is to look at the thunks /inside/ the type. The default+ -- implementation uses GHC Generics to do this.+ wNoThunks :: Context -> a -> IO (Maybe ThunkInfo)+ default wNoThunks :: (Generic a, GWNoThunks '[] (Rep a))+ => Context -> a -> IO (Maybe ThunkInfo)+ wNoThunks ctxt x = gwNoThunks (Proxy @'[]) ctxt fp+ where+ -- Force the result of @from@ to WHNF: we are not interested in thunks+ -- that arise from the translation to the generic representation.+ fp :: Rep a x+ !fp = from x++ -- | Show type @a@ (to add to the context)+ --+ -- We try hard to avoid 'Typeable' constraints in this module: there are types+ -- with no 'Typeable' instance but with a 'NoThunks' instance (most+ -- important example are types such as @ST s@ which rely on parametric+ -- polymorphism). By default we should therefore only show the "outer layer";+ -- for example, if we have a type+ --+ -- > Seq (ST s ())+ --+ -- then 'showTypeOf' should just give @Seq@, leaving it up to the instance for+ -- @ST@ to decide how to implement 'showTypeOf'; this keeps things+ -- compositional. The default implementation does precisely this using the+ -- metadata that GHC Generics provides.+ --+ -- For convenience, however, some of the @deriving via@ newtype wrappers we+ -- provide /do/ depend on @Typeable@; see below.+ showTypeOf :: Proxy a -> String+ default showTypeOf :: (Generic a, GShowTypeOf (Rep a)) => Proxy a -> String+ showTypeOf _ = gShowTypeOf (from x)+ where+ x :: a+ x = x++-- | Context where a thunk was found+--+-- This is intended to give a hint about which thunk was found. For example,+-- a thunk might be reported with context+--+-- > ["Int", "(,)", "Map", "AppState"]+--+-- telling you that you have an @AppState@ containing a @Map@ containing a pair,+-- all of which weren't thunks (were in WHNF), but that pair contained an+-- @Int@ which was a thunk.+type Context = [String]++{-------------------------------------------------------------------------------+ Results of the check+-------------------------------------------------------------------------------}++-- | Information about unexpected thunks+--+-- TODO: The ghc-debug work by Matthew Pickering includes some work that allows+-- to get source spans from closures. If we could take advantage of that, we+-- could not only show the type of the unexpected thunk, but also where it got+-- allocated.+data ThunkInfo = ThunkInfo {+ -- The @Context@ argument is intended to give a clue to add debugging.+ -- For example, suppose we have something of type @(Int, [Int])@. The+ -- various contexts we might get are+ --+ -- > Context The thunk is..+ -- > ---------------------------------------------------------------------+ -- > ["(,)"] the pair itself+ -- > ["Int","(,)"] the Int in the pair+ -- > ["[]","(,)"] the [Int] in the pair+ -- > ["Int","[]","(,)"] an Int in the [Int] in the pair+ thunkContext :: Context+ }+ deriving (Show)++{-# NOINLINE unsafeNoThunks #-}+unsafeNoThunks :: NoThunks a => a -> Maybe ThunkInfo+unsafeNoThunks a = unsafePerformIO $ noThunks [] a++{-------------------------------------------------------------------------------+ Helpers for defining NoThunks instances+-------------------------------------------------------------------------------}++-- | Short-circuit a list of checks+allNoThunks :: [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)+allNoThunks = go+ where+ go :: [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)+ go [] = return Nothing+ go (a:as) = do+ nf <- a+ case nf of+ Nothing -> go as+ Just thunk -> return $ Just thunk++-- | Check that all elements in the list are thunk-free+--+-- Does not check the list itself. Useful for checking the elements of a+-- container.+--+-- See also 'noThunksInKeysAndValues'+noThunksInValues :: NoThunks a => Context -> [a] -> IO (Maybe ThunkInfo)+noThunksInValues ctxt = allNoThunks . map (noThunks ctxt)++-- | Variant on 'noThunksInValues' for keyed containers.+--+-- Neither the list nor the tuples are checked for thunks.+noThunksInKeysAndValues :: (NoThunks k, NoThunks v)+ => Context -> [(k, v)] -> IO (Maybe ThunkInfo)+noThunksInKeysAndValues ctxt =+ allNoThunks+ . concatMap (\(k, v) -> [ noThunks ctxt k+ , noThunks ctxt v+ ])++{-------------------------------------------------------------------------------+ Newtype wrappers for deriving via+-------------------------------------------------------------------------------}++-- | Newtype wrapper for use with @deriving via@ to check for WHNF only+--+-- For some types we don't want to check for nested thunks, and we only want+-- check if the argument is in WHNF, not in NF. A typical example are functions;+-- see the instance of @(a -> b)@ for detailed discussion. This should be used+-- sparingly.+--+-- Example:+--+-- > deriving via OnlyCheckWhnf T instance NoThunks T+newtype OnlyCheckWhnf a = OnlyCheckWhnf a++-- | Variant on 'OnlyCheckWhnf' that does not depend on 'Generic'+--+-- Example:+--+-- > deriving via OnlyCheckWhnfNamed "T" T instance NoThunks T+newtype OnlyCheckWhnfNamed (name :: Symbol) a = OnlyCheckWhnfNamed a++-- | Newtype wrapper for values that should be allowed to be a thunk+--+-- This should be used /VERY/ sparingly, and should /ONLY/ be used on values+-- (or, even rarer, types) which you are /SURE/ cannot retain any data that they+-- shouldn't. Bear in mind allowing a value of type @T@ to be a thunk might+-- cause a value of type @S@ to be retained if @T@ was computed from @S@.+newtype AllowThunk a = AllowThunk a++-- | Newtype wrapper for records where some of the fields are allowed to be+-- thunks.+--+-- Example:+--+-- > deriving via AllowThunksIn '["foo","bar"] T instance NoThunks T+--+-- This will create an instance that skips the thunk checks for the "foo" and+-- "bar" fields.+newtype AllowThunksIn (fields :: [Symbol]) a = AllowThunksIn a++-- | Newtype wrapper for use with @deriving via@ to inspect the heap directly+--+-- This bypasses the class instances altogether, and inspects the GHC heap+-- directly, checking that the value does not contain any thunks _anywhere_.+-- Since we can do this without any type classes instances, this is useful for+-- types that contain fields for which 'NoThunks' instances are not available.+--+-- Since the primary use case for 'InspectHeap' then is to give instances+-- for 'NoThunks' from third party libraries, we also don't want to+-- rely on a 'Generic' instance, which may likewise not be available. Instead,+-- we will rely on 'Typeable', which is available for /all/ types. However, as+-- 'showTypeOf' explains, requiring 'Typeable' may not always be suitable; if+-- it isn't, 'InspectHeapNamed' can be used.+--+-- Example:+--+-- > deriving via InspectHeap T instance NoThunks T+newtype InspectHeap a = InspectHeap a++-- | Variant on 'InspectHeap' that does not depend on 'Typeable'.+--+-- > deriving via InspectHeapNamed "T" T instance NoUnexpecedThunks T+newtype InspectHeapNamed (name :: Symbol) a = InspectHeapNamed a++{-------------------------------------------------------------------------------+ Internal: instances for the deriving-via wrappers+-------------------------------------------------------------------------------}++instance Typeable a => NoThunks (OnlyCheckWhnf a) where+ showTypeOf _ = show $ typeRep (Proxy @a)+ wNoThunks _ _ = return Nothing++instance KnownSymbol name => NoThunks (OnlyCheckWhnfNamed name a) where+ showTypeOf _ = symbolVal (Proxy @name)+ wNoThunks _ _ = return Nothing++instance NoThunks (AllowThunk a) where+ showTypeOf _ = "<never used since never fails>"+ noThunks _ _ = return Nothing+ wNoThunks = noThunks++instance (HasFields s a, Generic a, Typeable a, GWNoThunks s (Rep a))+ => NoThunks (AllowThunksIn s a) where+ showTypeOf _ = show $ typeRep (Proxy @a)+ wNoThunks ctxt (AllowThunksIn x) = gwNoThunks (Proxy @s) ctxt fp+ where+ fp :: Rep a x+ !fp = from x++instance Typeable a => NoThunks (InspectHeap a) where+ showTypeOf _ = show $ typeRep (Proxy @a)+ wNoThunks = inspectHeap++instance KnownSymbol name => NoThunks (InspectHeapNamed name a) where+ showTypeOf _ = symbolVal (Proxy @name)+ wNoThunks = inspectHeap++-- | Internal: implementation of 'wNoThunks' for 'InspectHeap'+-- and 'InspectHeapNamed'+inspectHeap :: Context -> a -> IO (Maybe ThunkInfo)+inspectHeap ctxt x = do+ containsThunks <- checkContainsThunks x+ return $ if containsThunks+ then Just $ ThunkInfo { thunkContext = "..." : ctxt }+ else Nothing++{-------------------------------------------------------------------------------+ Internal: generic infrastructure+-------------------------------------------------------------------------------}++-- | Generic infrastructure for checking for unexpected thunks+--+-- The @a@ argument records which record fields are allowed to contain thunks;+-- see 'AllowThunksIn' and 'GWRecordField', below.+class GWNoThunks (a :: [Symbol]) f where+ -- | Check that the argument does not contain any unexpected thunks+ --+ -- Precondition: the argument is in WHNF.+ gwNoThunks :: proxy a -> Context -> f x -> IO (Maybe ThunkInfo)++instance GWNoThunks a f => GWNoThunks a (D1 c f) where+ gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp++instance GWNoThunks a f => GWNoThunks a (C1 c f) where+ gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp++instance GWNoThunks a f => GWNoThunks a (S1 ('MetaSel ('Nothing) su ss ds) f) where+ gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp++instance (GWNoThunks a f, GWNoThunks a g) => GWNoThunks a (f :*: g) where+ gwNoThunks a ctxt (fp :*: gp) = allNoThunks [+ gwNoThunks a ctxt fp+ , gwNoThunks a ctxt gp+ ]++instance (GWNoThunks a f, GWNoThunks a g) => GWNoThunks a (f :+: g) where+ gwNoThunks a ctxt (L1 fp) = gwNoThunks a ctxt fp+ gwNoThunks a ctxt (R1 gp) = gwNoThunks a ctxt gp++instance NoThunks c => GWNoThunks a (K1 i c) where+ gwNoThunks _a ctxt (K1 c) = noThunks ctxt' c+ where+ -- If @c@ is a recursive occurrence of the type itself, we want to avoid+ -- accumulating context. For example, suppose we are dealing with @[Int]@,+ -- and we have an unexpected thunk as the third @Int@ in the list. If+ -- we use the generic instance, then without this correction, the final+ -- context will look something like+ --+ -- > ["Int", "[]", "[]", "[]"]+ --+ -- While that is more informative (it's the /third/ element that is a+ -- thunk), it's not that helpful (typically we just want /all/ elements+ -- to be in NF). We strip the context here so that we just get+ --+ -- > ["Int", "[]"]+ --+ -- which is a bit easier to interpret.+ ctxt' = case ctxt of+ hd : tl | hd == showTypeOf (Proxy @c) -> tl+ _otherwise -> ctxt++instance GWNoThunks a U1 where+ gwNoThunks _a _ctxt U1 = return Nothing++instance GWNoThunks a V1 where+ -- By assumption, the argument is already in WHNF. Since every inhabitant of+ -- this type is bottom, this code is therefore unreachable.+ gwNoThunks _a _ctxt _ = error "unreachable gwNoThunks @V1"++{-------------------------------------------------------------------------------+ Skip fields with allowed thunks+-------------------------------------------------------------------------------}++-- | If @fieldName@ is allowed to contain thunks, skip it.+instance GWRecordField f (Elem fieldName a)+ => GWNoThunks a (S1 ('MetaSel ('Just fieldName) su ss ds) f) where+ gwNoThunks _ ctxt (M1 fp) =+ gwRecordField (Proxy @(Elem fieldName a)) ctxt fp++class GWRecordField f (b :: Bool) where+ gwRecordField :: proxy b -> Context -> f x -> IO (Maybe ThunkInfo)++-- | If the field is allowed to contain thunks, don't check anything.+instance GWRecordField f 'True where+ gwRecordField _ _ _ = return Nothing++instance GWNoThunks '[] f => GWRecordField f 'False where+ gwRecordField _ ctxt f = gwNoThunks (Proxy @'[]) ctxt f++{-------------------------------------------------------------------------------+ Internal: generic function to get name of a type+-------------------------------------------------------------------------------}++class GShowTypeOf f where+ gShowTypeOf :: f x -> String++instance Datatype c => GShowTypeOf (D1 c f) where+ gShowTypeOf = datatypeName++{-------------------------------------------------------------------------------+ Instances for primitive types+-------------------------------------------------------------------------------}++deriving via OnlyCheckWhnf Bool instance NoThunks Bool+deriving via OnlyCheckWhnf Natural instance NoThunks Natural+deriving via OnlyCheckWhnf Integer instance NoThunks Integer+deriving via OnlyCheckWhnf Float instance NoThunks Float+deriving via OnlyCheckWhnf Double instance NoThunks Double+deriving via OnlyCheckWhnf Char instance NoThunks Char++deriving via OnlyCheckWhnf Int instance NoThunks Int+deriving via OnlyCheckWhnf Int8 instance NoThunks Int8+deriving via OnlyCheckWhnf Int16 instance NoThunks Int16+deriving via OnlyCheckWhnf Int32 instance NoThunks Int32+deriving via OnlyCheckWhnf Int64 instance NoThunks Int64++deriving via OnlyCheckWhnf Word instance NoThunks Word+deriving via OnlyCheckWhnf Word8 instance NoThunks Word8+deriving via OnlyCheckWhnf Word16 instance NoThunks Word16+deriving via OnlyCheckWhnf Word32 instance NoThunks Word32+deriving via OnlyCheckWhnf Word64 instance NoThunks Word64++{-------------------------------------------------------------------------------+ Time+-------------------------------------------------------------------------------}++deriving via InspectHeap Day instance NoThunks Day+deriving via InspectHeap DiffTime instance NoThunks DiffTime+deriving via InspectHeap LocalTime instance NoThunks LocalTime+deriving via InspectHeap NominalDiffTime instance NoThunks NominalDiffTime+deriving via InspectHeap TimeLocale instance NoThunks TimeLocale+deriving via InspectHeap TimeOfDay instance NoThunks TimeOfDay+deriving via InspectHeap TimeZone instance NoThunks TimeZone+deriving via InspectHeap UniversalTime instance NoThunks UniversalTime+deriving via InspectHeap UTCTime instance NoThunks UTCTime+deriving via InspectHeap ZonedTime instance NoThunks ZonedTime++{-------------------------------------------------------------------------------+ ByteString+-------------------------------------------------------------------------------}++-- | Instance for string bytestrings+--+-- Strict bytestrings /shouldn't/ contain any thunks, but could, due to+-- <https://gitlab.haskell.org/ghc/ghc/issues/17290>. However, such thunks can't+-- retain any data that they shouldn't, and so it's safe to ignore such thunks.+deriving via OnlyCheckWhnfNamed "Strict.ByteString" BS.Strict.ByteString+ instance NoThunks BS.Strict.ByteString++-- | Instance for short bytestrings+--+-- We have+--+-- > data ShortByteString = SBS ByteArray#+--+-- Values of this type consist of a tag followed by an _unboxed_ byte array,+-- which can't contain thunks. Therefore we only check WHNF.+deriving via OnlyCheckWhnfNamed "ShortByteString" ShortByteString+ instance NoThunks ShortByteString++-- | Instance for lazy bytestrings+--+-- Defined manually so that it piggy-backs on the one for strict bytestrings.+instance NoThunks BS.Lazy.ByteString where+ showTypeOf _ = "Lazy.ByteString"+ wNoThunks ctxt bs =+ case bs of+ BS.Lazy.Internal.Empty -> return Nothing+ BS.Lazy.Internal.Chunk chunk bs' -> allNoThunks [+ noThunks ctxt chunk+ , noThunks ctxt bs'+ ]++{-------------------------------------------------------------------------------+ Instances for text types++ For consistency, we follow the same pattern as for @ByteString@.+-------------------------------------------------------------------------------}++deriving via OnlyCheckWhnfNamed "Strict.Text" Text.Strict.Text+ instance NoThunks Text.Strict.Text++instance NoThunks Text.Lazy.Text where+ showTypeOf _ = "Lazy.Text"+ wNoThunks ctxt bs =+ case bs of+ Text.Lazy.Internal.Empty -> return Nothing+ Text.Lazy.Internal.Chunk chunk bs' -> allNoThunks [+ noThunks ctxt chunk+ , noThunks ctxt bs'+ ]++{-------------------------------------------------------------------------------+ Tuples+-------------------------------------------------------------------------------}++instance ( NoThunks a+ , NoThunks b+ ) => NoThunks (a, b)++instance ( NoThunks a+ , NoThunks b+ , NoThunks c+ ) => NoThunks (a, b, c)++instance ( NoThunks a+ , NoThunks b+ , NoThunks c+ , NoThunks d+ ) => NoThunks (a, b, c, d)++instance ( NoThunks a+ , NoThunks b+ , NoThunks c+ , NoThunks d+ , NoThunks e+ ) => NoThunks (a, b, c, d, e)++instance ( NoThunks a+ , NoThunks b+ , NoThunks c+ , NoThunks d+ , NoThunks e+ , NoThunks f+ ) => NoThunks (a, b, c, d, e, f)++instance ( NoThunks a+ , NoThunks b+ , NoThunks c+ , NoThunks d+ , NoThunks e+ , NoThunks f+ , NoThunks g+ ) => NoThunks (a, b, c, d, e, f, g)++{-------------------------------------------------------------------------------+ Base types (other than tuples)+-------------------------------------------------------------------------------}++instance NoThunks ()++instance NoThunks a => NoThunks [a]+instance NoThunks a => NoThunks (Maybe a)+instance NoThunks a => NoThunks (NonEmpty a)++instance (NoThunks a, NoThunks b) => NoThunks (Either a b)++{-------------------------------------------------------------------------------+ Spine-strict container types++ Such types can /only/ contain thunks in the values, so that's all we check.+ Note that containers using keys are typically strict in those keys, but that+ forces them to WHNF only, not NF; in /most/ cases the @Ord@ instance on those+ keys will force them to NF, but not /always/ (for example, when using lists+ as keys); this means we must check keys for thunks to be sure.+-------------------------------------------------------------------------------}++instance (NoThunks k, NoThunks v) => NoThunks (Map k v) where+ showTypeOf _ = "Map"+ wNoThunks ctxt = noThunksInKeysAndValues ctxt . Map.toList++instance NoThunks a => NoThunks (Set a) where+ showTypeOf _ = "Set"+ wNoThunks ctxt = noThunksInValues ctxt . Set.toList++instance NoThunks a => NoThunks (IntMap a) where+ showTypeOf _ = "IntMap"+ wNoThunks ctxt = noThunksInValues ctxt . IntMap.toList++{-------------------------------------------------------------------------------+ Vector+-------------------------------------------------------------------------------}++instance NoThunks a => NoThunks (Vector.Boxed.Vector a) where+ showTypeOf _ = "Boxed.Vector"+ wNoThunks ctxt = noThunksInValues ctxt . Vector.Boxed.toList++-- | Unboxed vectors can't contain thunks+--+-- Implementation note: defined manually rather than using 'OnlyCheckWhnf'+-- due to ghc limitation in deriving via, making it impossible to use with it+-- with data families.+instance NoThunks (Vector.Unboxed.Vector a) where+ showTypeOf _ = "Unboxed.Vector"+ wNoThunks _ _ = return Nothing++{-------------------------------------------------------------------------------+ Function types+-------------------------------------------------------------------------------}++-- | We do NOT check function closures for captured thunks by default+--+-- Since we have no type information about the values captured in a thunk,+-- the only check we could possibly do is 'containsThunks': we can't recursively+-- call 'noThunks' on those captured values, which is problematic if+-- any of those captured values /requires/ a custom instance (for example,+-- data types that depend on laziness, such as 'Seq').+--+-- By default we therefore /only/ check if the function is in WHNF, and don't+-- check the captured values at all. If you want a stronger check, you can+-- use @IsNormalForm (a -> b)@ instead.+deriving via OnlyCheckWhnfNamed "->" (a -> b) instance NoThunks (a -> b)++-- | We do not check IO actions for captured thunks by default+--+-- See instance for @(a -> b)@ for detailed discussion.+deriving via OnlyCheckWhnfNamed "IO" (IO a) instance NoThunks (IO a)++{-------------------------------------------------------------------------------+ Special cases+-------------------------------------------------------------------------------}++-- | Since CallStacks can't retain application data, we don't want to check+-- them for thunks /at all/+deriving via AllowThunk CallStack instance NoThunks CallStack++-- | Instance for 'Seq' checks elements only+--+-- The internal fingertree in 'Seq' might have thunks, which is essential for+-- its asymptotic complexity.+instance NoThunks a => NoThunks (Seq a) where+ showTypeOf _ = "Seq"+ wNoThunks ctxt = noThunksInValues ctxt . toList++instance NoThunks a => NoThunks (Ratio a) where+ showTypeOf _ = "Ratio"+ wNoThunks ctxt r = noThunksInValues ctxt [n, d]+ where+ -- The 'Ratio' constructor is not exported: we only have two accessor+ -- functions. However, @numerator r@ is obviously trivially a trunk+ -- (due to the unevaluated call to @numerator@). By forcing the values of+ -- @n@ and @d@ where we get rid of these function calls, leaving only the+ -- values inside the @Ratio@. Note that @Ratio@ is strict in both of these+ -- fields, so forcing them to WHNF won't change them.+ !n = numerator r+ !d = denominator r++{-------------------------------------------------------------------------------+ Type level symbol comparison logic+-------------------------------------------------------------------------------}++type family Same s t where+ Same s t = IsSame (CmpSymbol s t)++type family IsSame (o :: Ordering) where+ IsSame 'EQ = 'True+ IsSame _x = 'False++type family Or (a :: Bool) (b :: Bool) where+ Or 'False 'False = 'False+ Or _a _b = 'True++type family Elem (s :: Symbol) (xs :: [Symbol]) where+ Elem s (x ': xs) = Or (Same s x) (Elem s xs)+ Elem _s '[] = 'False++{-------------------------------------------------------------------------------+ Check that all mentioned record fields are known fields+-------------------------------------------------------------------------------}++-- | Check that type @a@ has all record fields listed in @s@+--+-- This exists to catch mismatches between the arguments to `AllowThunksIn` and+-- the fields of a record. If any of the symbols is not the name of a field then+-- this constraint won't be satisfied.+class HasFields (s :: [Symbol]) (a :: *)+instance HasFields '[] a+instance (HasField x a t, HasFields xs a) => HasFields (x ': xs) a++{-------------------------------------------------------------------------------+ Internal: low level magic+-------------------------------------------------------------------------------}++-- | Is the argument a (top-level thunk)?+checkIsThunk :: a -> IO Bool+checkIsThunk x = closureIsThunk <$> getBoxedClosureData (asBox x)++-- | Is the argument a thunk, or does it (recursively) contain any?+checkContainsThunks :: a -> IO Bool+checkContainsThunks x = go (asBox x)+ where+ go :: Box -> IO Bool+ go b = do+ c <- getBoxedClosureData b+ if closureIsThunk c then+ return True+ else do+ c' <- getBoxedClosureData b+ anyM go (allClosures c')++-- | Check if the given 'Closure' is a thunk.+--+-- Indirections are not considered to be thunks.+closureIsThunk :: Closure -> Bool+closureIsThunk ThunkClosure{} = True+closureIsThunk APClosure{} = True+closureIsThunk SelectorClosure{} = True+closureIsThunk BCOClosure{} = True+closureIsThunk _ = False++anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM _ [] = return False+anyM p (x : xs) = do+ q <- p x+ if q then return True+ else anyM p xs
+ test/Main.hs view
@@ -0,0 +1,13 @@+module Main (main) where++import Test.Tasty++import qualified Test.NoThunks.Class++tests :: TestTree+tests = testGroup "Tests" [+ Test.NoThunks.Class.tests+ ]++main :: IO ()+main = defaultMain tests
+ test/Test/NoThunks/Class.hs view
@@ -0,0 +1,568 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++-- | Tests for 'NoThunks.Class'+--+-- These tests are tricky, since we want to have precisely control over where+-- there are and aren't thunks, without letting ghc ruin things (normally of+-- course ghc should be free to change a lot of that behaviour).+--+-- We avoid bang patterns as well as the use of '($!)', to make sure that these+-- tests pass with @-O0@.+module Test.NoThunks.Class (tests) where++import Control.Monad.IO.Class+import Data.Kind+import Data.Maybe (isNothing)+import Data.Proxy+import Data.Sequence (Seq)+import Data.Typeable+import GHC.Generics (Generic)+import GHC.Types+import System.Random+import Test.Tasty+import Test.Tasty.Hedgehog++import qualified Data.Sequence as Seq+import qualified Data.Sequence.Internal as Seq.Internal++import Hedgehog+import Hedgehog.Internal.Report (Result (..), reportStatus)+import Hedgehog.Internal.Region (displayRegion)+import Hedgehog.Internal.Runner (checkNamed)+import Hedgehog.Internal.Config (UseColor (..))++import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import NoThunks.Class++{-------------------------------------------------------------------------------+ Top-level+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "NoThunks.Class" [+ testGroup "Sanity" [+ testProperty "IntNotNF" sanityCheckIntNotNF+ , testProperty "IntIsNF" sanityCheckIntIsNF+ , testProperty "Pair" sanityCheckPair+ , testProperty "Fn" sanityCheckFn+ , testProperty "IO" sanityCheckIO+ ]+ , testGroup "InspectHeap" [+ testProperty "Int" $ testWithModel agreeOnNF $ Proxy @(InspectHeap Int)+ , testProperty "IntInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Int, Int))+ , testProperty "ListInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap [Int])+ , testProperty "IntListInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Int, [Int]))+ , testProperty "SeqInt" $ expectFailure $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Seq Int))+ ]+ , testGroup "Model" [+ testProperty "Int" $ testWithModel agreeOnContext $ Proxy @Int+ , testProperty "IntInt" $ testWithModel agreeOnContext $ Proxy @(Int, Int)+ , testProperty "ListInt" $ testWithModel agreeOnContext $ Proxy @[Int]+ , testProperty "IntListInt" $ testWithModel agreeOnContext $ Proxy @(Int, [Int])+ , testProperty "SeqInt" $ testWithModel agreeOnContext $ Proxy @(Seq Int)+ , testProperty "AllowThunksIn" $ testWithModel agreeOnContext $ Proxy @(AllowThunksIn '["field1"] Record)+ , testProperty "Fn" $ testWithModel agreeOnContext $ Proxy @(Int -> Int)+ , testProperty "IO" $ testWithModel agreeOnContext $ Proxy @(IO ())+ , testProperty "ThunkFreeFn" $ testWithModel agreeOnContext $ Proxy @(ThunkFree "->" (Int -> Int))+ , testProperty "ThunkFreeIO" $ testWithModel agreeOnContext $ Proxy @(ThunkFree "IO" (IO ()))+ ]+ ]++-- | When using @InspectHeap@ we don't get a context, so merely check if+-- both the model and the implementation agree whether or not the value is+-- in NF+agreeOnNF :: Maybe ThunkInfo -> Maybe [String] -> Bool+agreeOnNF mThunk mCtxt = isNothing mThunk == isNothing mCtxt++-- | Check whether the model and the implementation agree on whether the value+-- is in NF, and if not, what the context of the thunk is.+agreeOnContext :: Maybe ThunkInfo -> Maybe [String] -> Bool+agreeOnContext mThunk mCtxt = (thunkContext <$> mThunk) == mCtxt++{-------------------------------------------------------------------------------+ Infrastructure+-------------------------------------------------------------------------------}++-- | The model for a value describes that value, being explicit where we+-- can expect thunks in the value.+class (NoThunks a, Show (Model a)) => FromModel a where+ data Model a :: Type++ -- | Generate model value (see below for examples)+ genModel :: Gen (Model a)++ -- | Does the model describe a value in NF?+ modelIsNF :: [String] -> Model a -> IsNormalForm [String]++ -- | Context as it should be returned by 'noThunks'+ --+ -- This has a default implementation in terms of 'modelIsNF': there are+ -- unexpected thunks iff the model is not fully in NF.+ modelUnexpected :: [String] -> Model a -> Maybe [String]+ modelUnexpected ctxt m =+ case modelIsNF ctxt m of+ IsNF -> Nothing+ IsWHNF c -> Just c+ NotWHNF c -> Just c++ -- | Translate from the model to an actual value+ --+ -- The @a@ thunk should contain no unevaluated calls to 'fromModel'.+ fromModel :: forall r. Model a -> (a -> r) -> r++-- | Is a value in normal form?+data IsNormalForm a =+ IsNF -- ^ Value completely in normal form+ | IsWHNF a -- ^ Value is in WHNF, but not NF. Record information about thunk.+ | NotWHNF a -- ^ Value is not in WHNF. Record information about thunk.+ deriving (Show, Functor)++-- | 'IsNormalForm' for a constructor applied to arguments+--+-- A constructor applied to arguments is always in WHNF; it is in NF iff all+-- arguments are.+constrNF :: forall a. [IsNormalForm a] -> IsNormalForm a+constrNF args =+ case firstNotNF args of+ Nothing -> IsNF+ Just a -> IsWHNF a+ where+ firstNotNF :: [IsNormalForm a] -> Maybe a+ firstNotNF [] = Nothing+ firstNotNF (NotWHNF a : _ ) = Just a+ firstNotNF (IsWHNF a : _ ) = Just a+ firstNotNF (IsNF : args') = firstNotNF args'++testWithModel :: forall a. FromModel a+ => (Maybe ThunkInfo -> Maybe [String] -> Bool)+ -> Proxy a+ -- ^ Compare @ThunkInfo@. When we use 'noThunks' this+ -- can just be @(==)@; however, when we use 'isNormalForm', the+ -- context we will get from the model will be too detailed.+ -> Property+testWithModel compareInfo _proxy = withTests 1000 $ property $ do+ m :: Model a <- forAll genModel+ collect $ modelUnexpected [] m+ fromModel m $ \a -> do+ annotate $ show $ modelIsNF [] m+ isNF <- liftIO $ noThunks [] a+ Hedgehog.diff isNF compareInfo (modelUnexpected [] m)++{-------------------------------------------------------------------------------+ Int+-------------------------------------------------------------------------------}++instance FromModel Int where+ data Model Int =+ IntThunk (Model Int)+ | IntValue Int+ deriving (Show)++ -- for integers there is no difference between NF/WHNF+ modelIsNF ctxt = \case+ IntThunk _ -> NotWHNF ctxt'+ IntValue _ -> IsNF+ where+ ctxt' = "Int" : ctxt++ fromModel (IntThunk i) k = fromModel i $ \i' -> k (if ack 3 3 > 0 then i' else i')+ fromModel (IntValue n) k = case n of I# result -> k (I# result)++ genModel = Gen.choice [+ IntValue <$> Gen.int Range.linearBounded+ , IntThunk <$> genModel+ ]++{-------------------------------------------------------------------------------+ Pairs+-------------------------------------------------------------------------------}++instance (FromModel a, FromModel b) => FromModel (a, b) where+ data Model (a, b) =+ PairThunk (Model (a, b))+ | PairDefined (Model a) (Model b)++ modelIsNF ctxt = \case+ PairThunk _ -> NotWHNF ctxt'+ PairDefined a b -> constrNF [modelIsNF ctxt' a, modelIsNF ctxt' b]+ where+ ctxt' = "(,)" : ctxt++ fromModel (PairThunk p) k = fromModel p $ \p' -> k (if ack 3 3 > 0 then p' else p')+ fromModel (PairDefined a b) k = fromModel a $ \a' ->+ fromModel b $ \b' ->+ k (a', b')++ genModel = Gen.choice [+ PairDefined <$> genModel <*> genModel+ , PairThunk <$> genModel+ ]++deriving instance (Show (Model a), Show (Model b)) => Show (Model (a, b))++{-------------------------------------------------------------------------------+ Lists+-------------------------------------------------------------------------------}++instance FromModel a => FromModel [a] where+ data Model [a] =+ ListThunk (Model [a])+ | ListNil+ | ListCons (Model a) (Model [a])++ modelIsNF ctxt = \case+ ListThunk _ -> NotWHNF ctxt'+ ListNil -> IsNF+ ListCons x xs' -> constrNF [modelIsNF ctxt' x, modelIsNF ctxt xs']+ where+ ctxt' = "[]" : ctxt++ fromModel (ListThunk xs) k = fromModel xs $ \xs' -> k (if ack 3 3 > 0 then xs' else xs')+ fromModel ListNil k = k []+ fromModel (ListCons x xs) k = fromModel x $ \x' ->+ fromModel xs $ \xs' ->+ k (x' : xs')++ genModel = do+ sz <- Gen.int $ Range.linear 0 10+ go sz+ where+ go :: Int -> Gen (Model [a])+ go 0 = pure ListNil+ go n = Gen.choice [+ ListCons <$> genModel <*> go (n - 1)+ , ListThunk <$> go (n - 1)+ ]++deriving instance Show (Model a) => Show (Model [a])++{-------------------------------------------------------------------------------+ Seq+-------------------------------------------------------------------------------}++instance FromModel (Seq Int) where+ data Model (Seq Int) = SeqEmpty | SeqEnqueue (Model Int) (Model (Seq Int))+ deriving (Show)++ modelIsNF ctxt = \case+ SeqEmpty -> IsNF+ SeqEnqueue x xs -> constrNF [modelIsNF ctxt' x, modelIsNF ctxt xs]+ where+ ctxt' = "Seq" : ctxt++ fromModel m = \k -> go m $ \s -> forceSeqToWhnf s k+ where+ go :: Model (Seq Int) -> (Seq Int -> r) -> r+ go SeqEmpty k = k Seq.empty+ go (SeqEnqueue x xs) k =+ fromModel x $ \x' ->+ go xs $ \xs' ->+ k (x' Seq.<| xs')++ genModel = do+ sz <- Gen.int $ Range.linear 0 100+ -- It is important that we have a good probability of generating sequences+ -- that the model considers to be in normal form: for such sequences the+ -- model and the 'isNormalForm' check (but not the 'noThunks'+ -- check) can diverge, because the internal @FingerTree@ may not be+ -- fully evaluated.+ Gen.choice [+ go (pure $ IntValue 0) sz+ , go genModel sz+ ]+ where+ go :: Gen (Model Int) -> Int -> Gen (Model (Seq Int))+ go _ 0 = return SeqEmpty+ go genInt n = SeqEnqueue <$> genInt <*> go genInt (n - 1)++forceSeqToWhnf :: Seq a -> (Seq a -> r) -> r+forceSeqToWhnf xs k =+ case xs of+ Seq.Internal.Seq Seq.Internal.EmptyT ->+ k (Seq.Internal.Seq Seq.Internal.EmptyT)+ Seq.Internal.Seq (Seq.Internal.Single a) ->+ k (Seq.Internal.Seq (Seq.Internal.Single a))+ Seq.Internal.Seq (Seq.Internal.Deep n l ft r) ->+ k (Seq.Internal.Seq (Seq.Internal.Deep n l ft r))++{-------------------------------------------------------------------------------+ AllowThunksIn+-------------------------------------------------------------------------------}++data Record = Record {+ field1 :: [Int]+ , field2 :: Int+ }+ deriving (Generic, Show)++instance FromModel (AllowThunksIn '["field1"] Record) where+ data Model (AllowThunksIn '["field1"] Record) =+ RecordThunk (Model (AllowThunksIn '["field1"] Record))+ | RecordDefined (Model [Int]) (Model Int)++ modelIsNF ctxt = \case+ RecordThunk _ -> NotWHNF ctxt'+ RecordDefined a b -> constrNF [modelIsNF ctxt' a, modelIsNF ctxt' b]+ where+ ctxt' = "Record" : ctxt++ modelUnexpected ctxt = \case+ RecordThunk _ -> Just ctxt'+ RecordDefined _ y -> modelUnexpected ctxt' y+ where+ ctxt' = "Record" : ctxt++ fromModel (RecordThunk r) k = fromModel r $ \r' -> k (if ack 3 3 > 0 then r' else r')+ fromModel (RecordDefined a b) k =+ fromModel a $ \a' ->+ fromModel b $ \b' ->+ k (AllowThunksIn (Record a' b'))++ genModel = Gen.choice [+ RecordDefined <$> genModel <*> genModel+ , RecordThunk <$> genModel+ ]++deriving instance Show (Model (AllowThunksIn '["field1"] Record))++{-------------------------------------------------------------------------------+ Special case: function closures++ Since we don't traverse the function closure, we should only check if+ the function itself is in WHNF or not.++ We have to be careful here exactly how we phrase this test to avoid the GHC+ optimizer being too smart, turning what we think ought to be thunks into+ top-level CAFs.+-------------------------------------------------------------------------------}++-- | Function which is not strict in either 'Int' argument+{-# NOINLINE notStrict #-}+notStrict :: Bool -> Int -> Int -> Int+notStrict False x _ = x+notStrict True _ y = y++definitelyInNF :: Int -> Int+definitelyInNF n = n++instance FromModel (Int -> Int) where+ data Model (Int -> Int) =+ FnInNF -- Function in NF+ | FnNotInNF Bool Int -- Function in WHNF but not in NF+ | FnNotInWHNF (Model (Int -> Int)) -- Function not in WHNF+ | FnToWHNF (Model (Int -> Int)) -- Force function to WHNF+ deriving (Show)++ fromModel FnInNF k = k definitelyInNF+ fromModel (FnNotInNF b n) k = k (\x -> notStrict b (ack 5 n) x) -- Lambda is in WHNF+ fromModel (FnNotInWHNF f) k = fromModel f $ \f' -> k (if ack 3 3 > 0 then f' else f')+ fromModel (FnToWHNF f) k = fromModel f $ \f' -> f' `seq` k f'++ -- By default we don't distinguish between NF and WHNF for functions+ modelUnexpected ctxt m =+ case modelIsNF ctxt m of+ IsNF -> Nothing+ IsWHNF _ -> Nothing+ NotWHNF c -> Just c++ modelIsNF ctxt = \case+ FnInNF -> IsNF+ FnNotInNF _ _ -> IsWHNF ctxt'+ FnNotInWHNF _ -> NotWHNF ctxt'+ FnToWHNF f ->+ case f of+ -- Forcing a function already in NF leaves it in NF+ FnInNF -> IsNF++ -- Forcing a function which is already in WHNF (but not in NF)+ -- leaves it in WHNF+ FnNotInNF _ _ -> IsWHNF ctxt'++ -- Forcing a computation reveals what's underneath it.+ -- We leave the 'FnToWHNF' constructor at the top because+ -- It doens't matter quite how many computations are underneath,+ -- a single force forces them all.+ FnNotInWHNF f' -> modelIsNF ctxt (FnToWHNF f')++ -- Forcing twice is the same as forcing once+ FnToWHNF f' -> modelIsNF ctxt (FnToWHNF f')+ where+ ctxt' = ("->" : ctxt)++ genModel = Gen.choice [+ pure FnInNF+ , FnNotInNF <$> Gen.bool <*> Gen.int Range.linearBounded+ , FnNotInWHNF <$> genModel+ , FnToWHNF <$> genModel+ ]++{-------------------------------------------------------------------------------+ Special case: IO++ Similar kind of thing as for function closures. Here we have to be even more+ careful in our choice of examples to get something that works both with @-O0@+ and @-O1@.+-------------------------------------------------------------------------------}++-- IO action which is definitely in NF+doNothing :: IO ()+doNothing = IO (\w -> (# w, () #) )++instance FromModel (IO ()) where+ -- We reuse the model we use for functions, we do the same 4 types+ newtype Model (IO ()) = ModelIO (Model (Int -> Int))+ deriving Show++ fromModel (ModelIO m) = go m+ where+ go :: Model (Int -> Int) -> (IO () -> r) -> r+ go FnInNF k = k doNothing+ go (FnNotInNF b n) k = k (IO (\w -> let x = notStrict b (ack 5 n) 6+ in x `seq` (# w, () #) ))+ go (FnNotInWHNF f) k = go f $ \f' -> k (if ack 3 3 > 0 then f' else f')+ go (FnToWHNF f) k = go f $ \f' -> f' `seq` k f'++ modelUnexpected ctxt (ModelIO f) = fnToIOContext <$> modelUnexpected ctxt f+ modelIsNF ctxt (ModelIO f) = fnToIOContext <$> modelIsNF ctxt f+ genModel = ModelIO <$> genModel++fnToIOContext :: [String] -> [String]+fnToIOContext ("->" : ctxt) = "IO" : ctxt+fnToIOContext ("..." : "->" : ctxt) = "..." : "IO" : ctxt+fnToIOContext ctxt = ctxt++{-------------------------------------------------------------------------------+ Check that we /can/ check functions and IO actions for nested thunks+-------------------------------------------------------------------------------}++newtype ThunkFree (name :: Symbol) a = ThunkFree a+ deriving NoThunks via InspectHeapNamed name a++instance FromModel (ThunkFree "->" (Int -> Int)) where+ newtype Model (ThunkFree "->" (Int -> Int)) = ThunkFreeFn (Model (Int -> Int))+ deriving (Show)++ genModel = ThunkFreeFn <$> genModel+ fromModel (ThunkFreeFn f) k = fromModel f $ \f' -> k (ThunkFree f')+ modelIsNF ctxt (ThunkFreeFn f) = modelIsNF ctxt f++ modelUnexpected ctxt m =+ case modelIsNF ctxt m of+ IsNF -> Nothing+ IsWHNF _ -> Just ["...", "->"]+ NotWHNF _ -> Just ["->"]++instance FromModel (ThunkFree "IO" (IO ())) where+ newtype Model (ThunkFree "IO" (IO ())) = ThunkFreeIO (Model (Int -> Int))+ deriving (Show)++ genModel =+ ThunkFreeIO <$> genModel+ fromModel (ThunkFreeIO m) k =+ fromModel (ModelIO m) $ \f -> k (ThunkFree f)+ modelIsNF ctxt (ThunkFreeIO f) =+ fnToIOContext <$> modelIsNF ctxt (ThunkFreeFn f)+ modelUnexpected ctxt (ThunkFreeIO f) =+ fnToIOContext <$> modelUnexpected ctxt (ThunkFreeFn f)++{-------------------------------------------------------------------------------+ Using the standard 'isNormalForm' check+-------------------------------------------------------------------------------}++instance (FromModel a, Typeable a) => FromModel (InspectHeap a) where+ newtype Model (InspectHeap a) = Wrap { unwrap :: Model a }++ genModel = Wrap <$> genModel+ modelUnexpected ctxt = modelUnexpected ctxt . unwrap+ modelIsNF ctxt = modelIsNF ctxt . unwrap+ fromModel m k = fromModel (unwrap m) $ \x -> k (InspectHeap x)++deriving instance Show (Model a) => Show (Model (InspectHeap a))++{-------------------------------------------------------------------------------+ Some sanity checks++ These are primarily designed to check that we can distinguish between+ functions with nested thunks and functions without.+-------------------------------------------------------------------------------}++{-# NOINLINE checkNF #-}+checkNF :: Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property+checkNF expectedNF k = withTests 1 $ property $ k $ \x -> do+ nf <- liftIO $ noThunks [] (InspectHeapNamed @"a" x)+ isNothing nf === expectedNF++{-# NOINLINE sanityCheckIntNotNF #-}+sanityCheckIntNotNF :: Property+sanityCheckIntNotNF = checkNF False (\k -> k (if ack 3 3 > 0 then x else x))+ where+ x :: Int+ x = 0++{-# NOINLINE sanityCheckIntIsNF #-}+sanityCheckIntIsNF :: Property+sanityCheckIntIsNF = x `seq` checkNF True (\k -> k x)+ where+ x :: Int+ x = I# 0#++{-# NOINLINE sanityCheckPair #-}+sanityCheckPair :: Property+sanityCheckPair = checkNF False (\k -> k (if ack 3 3 > 0 then x else x))+ where+ x :: (Int, Bool)+ x = (0, True)++{-# NOINLINE sanityCheckFn #-}+sanityCheckFn :: Property+sanityCheckFn = checkNF False $ \k -> do+ b <- liftIO $ randomRIO (False, True)+ n <- liftIO $ ack 5 <$> randomRIO (0, 10)+ k (notStrict b n :: Int -> Int)++{-# NOINLINE sanityCheckIO #-}+sanityCheckIO :: Property+sanityCheckIO = checkNF False $ \k -> do+ b <- liftIO $ randomRIO (False, True)+ n <- liftIO $ ack 5 <$> randomRIO (0, 10)+ k (print (notStrict b n 6) :: IO ())++{-------------------------------------------------------------------------------+ Hedgehog auxiliary+-------------------------------------------------------------------------------}++expectFailure :: Property -> Property+expectFailure p = withTests 1 $ property $ do+ report <- liftIO $ displayRegion $ \r ->+ checkNamed r EnableColor (Just "EXPECTED FAILURE") p+ case reportStatus report of+ Failed _ ->+ success+ _otherwise -> do+ footnote "The test passed, but we expected it to fail."+ failure++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++-- | Ackermann (anything that ghc won't just optimize away..)+ack :: Int -> Int -> Int+ack 0 n = succ n+ack m 0 = ack (pred m) 1+ack m n = ack (pred m) (ack m (pred n))