nothunks-0.1.5/0000755000000000000000000000000007346545000011557 5ustar0000000000000000nothunks-0.1.5/CHANGELOG.md0000644000000000000000000000143407346545000013372 0ustar0000000000000000# Revision history for nothunks ## next version ## 0.1.5 -- 2023-10-29 * `NoThunks ThreadId` instance. * `NoThunks Identity` instance * Fix tests on ghc 9.8. Andreas Abel * Tested with ghc 8.10 to 9.8. ## 0.1.4 -- 2023-03-27 * Made cabal flags manual. * Support ghc-9.2 to 9.6. * `ThunkInfo` is a newtype. ## 0.1.3 -- 2021-06-28 * Fix tests on ghc-9.0.1 Joe Hermaszewski * Make bytestring, text and vector optional dependencies Bodigrim ## 0.1.2 -- 2020-12-03 * Add IORef, MVar and TVar instances. Oleg Grenrus ## 0.1.1.0 -- 2020-09-29 * Export `Context` and `GWNoThunks` * Fix typos in Haddocks * Improve bounds (and add upper bounds) ## 0.1.0.0 -- 2020-09-09 * Initial public release nothunks-0.1.5/LICENSE0000644000000000000000000002367607346545000012602 0ustar0000000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS nothunks-0.1.5/NOTICE0000644000000000000000000000113307346545000012461 0ustar0000000000000000Copyright 2018-2023 Input Output Global Inc (IOG) Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. nothunks-0.1.5/nothunks.cabal0000644000000000000000000000524107346545000014416 0ustar0000000000000000cabal-version: 3.0 name: nothunks version: 0.1.5 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: Apache-2.0 license-files: LICENSE NOTICE bug-reports: https://github.com/input-output-hk/nothunks author: IOG maintainer: Marcin Szamotulski copyright: 2018-2023 Input Output Global Inc (IOG) category: Development extra-doc-files: CHANGELOG.md tested-with: GHC== { 8.10.7, 9.0.2, 9.2.5, 9.4.4, 9.6.1 } source-repository head type: git location: https://github.com/input-output-hk/nothunks flag bytestring description: Provide instances for bytestring default: True manual: True flag text description: Provide instances for text default: True manual: True flag vector description: Provide instances for vector default: True manual: True library exposed-modules: NoThunks.Class build-depends: base >= 4.12 && < 5 , containers >= 0.5 && < 0.7 , stm >= 2.5 && < 2.6 , time >= 1.5 && < 1.13 -- Whatever is bundled with ghc , ghc-heap if flag(bytestring) build-depends: bytestring >= 0.10 && < 0.13 if flag(text) build-depends: text >= 1.2 && < 1.3 || >= 2 && < 2.2 if flag(vector) build-depends: vector >= 0.12 && < 0.14 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 -- Self dependency , nothunks -- Dependencies shared with the lib , containers , stm -- Whatever is bundled with ghc , ghc-prim -- Additional dependencies , hedgehog >= 1.1 && < 1.5 , random >= 1.1 && < 1.3 , tasty >= 1.3 && < 1.6 , tasty-hedgehog >= 1.1 && < 1.5 hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall nothunks-0.1.5/src/NoThunks/0000755000000000000000000000000007346545000014117 5ustar0000000000000000nothunks-0.1.5/src/NoThunks/Class.hs0000644000000000000000000007336407346545000015535 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module NoThunks.Class ( -- * Check a value for unexpected thunks NoThunks(..) , ThunkInfo(..) , Context , unsafeNoThunks -- * Helpers for defining instances , allNoThunks , noThunksInValues , noThunksInKeysAndValues -- * Deriving-via wrappers , OnlyCheckWhnf(..) , OnlyCheckWhnfNamed(..) , InspectHeap(..) , InspectHeapNamed(..) , AllowThunk(..) , AllowThunksIn(..) -- * Generic class , GWNoThunks(..) ) 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 import GHC.Conc.Sync (ThreadId (..)) -- For instances import Data.Foldable (toList) import Data.Functor.Identity (Identity) import Data.Int import Data.IntMap (IntMap) import Data.Kind (Type) 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.Void (Void) import Data.Word import GHC.Stack -- base-4.16 exports 'Natural' from 'GHC.TypeLits' #if !MIN_VERSION_base(4,16,0) import Numeric.Natural #endif import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.STM.TVar as TVar import qualified Data.IntMap as IntMap import qualified Data.IORef as IORef import qualified Data.Map as Map import qualified Data.Set as Set #ifdef MIN_VERSION_bytestring import Data.ByteString.Short (ShortByteString) 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 #endif #ifdef MIN_VERSION_text 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 #endif #ifdef MIN_VERSION_vector import qualified Data.Vector as Vector.Boxed import qualified Data.Vector.Unboxed as Vector.Unboxed #endif {------------------------------------------------------------------------------- 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 == Nothing -- -- if and only if -- -- > checkContainsThunks 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 'ThunkInfo' for a detailed discussion of the type -- context. -- -- See also discussion of caveats listed for 'checkContainsThunks'. 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. newtype 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 -- > ["List","(,)"] the [Int] in the pair -- > ["Int","List","(,)"] an Int in the [Int] in the pair -- -- Note: prior to `ghc-9.6` a list was indicated by `[]`. thunkContext :: Context } deriving (Show) {-# NOINLINE unsafeNoThunks #-} -- | Call 'noThunks' in a pure context (relies on 'unsafePerformIO'). 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 _ = "" 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) , KnownSymbol fieldName ) => GWNoThunks a (S1 ('MetaSel ('Just fieldName) su ss ds) f) where gwNoThunks _ ctxt (M1 fp) = gwRecordField (Proxy @(Elem fieldName a)) (symbolVal @fieldName Proxy : 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 {------------------------------------------------------------------------------- Mutable Vars -------------------------------------------------------------------------------} instance NoThunks a => NoThunks (IORef.IORef a) where showTypeOf _ = "IORef" wNoThunks ctx ref = do val <- IORef.readIORef ref noThunks ctx val instance NoThunks a => NoThunks (MVar.MVar a) where showTypeOf _ = "MVar" wNoThunks ctx ref = do val <- MVar.tryReadMVar ref maybe (return Nothing) (noThunks ctx) val instance NoThunks a => NoThunks (TVar.TVar a) where showTypeOf _ = "TVar" wNoThunks ctx ref = do -- An alternative is to use -- -- val <- STM.atomically $ TVar.readTVar ref -- -- but that would cause nested atomically failures with -- unsafeNoThunks. Fortunately, readTVarIO doesn't make a transaction. -- -- See related tests. -- val <- TVar.readTVarIO ref noThunks ctx val {------------------------------------------------------------------------------- Time -------------------------------------------------------------------------------} 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 -------------------------------------------------------------------------------} #ifdef MIN_VERSION_bytestring -- | Instance for string bytestrings -- -- Strict bytestrings /shouldn't/ contain any thunks, but could, due to -- . 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' ] #endif {------------------------------------------------------------------------------- Instances for text types For consistency, we follow the same pattern as for @ByteString@. -------------------------------------------------------------------------------} #ifdef MIN_VERSION_text 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' ] #endif {------------------------------------------------------------------------------- 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 Void instance NoThunks () instance NoThunks a => NoThunks [a] instance NoThunks a => NoThunks (Identity a) instance NoThunks a => NoThunks (Maybe a) instance NoThunks a => NoThunks (NonEmpty a) instance (NoThunks a, NoThunks b) => NoThunks (Either a b) deriving via InspectHeap ThreadId instance NoThunks ThreadId {------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------} #ifdef MIN_VERSION_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 #endif {------------------------------------------------------------------------------- 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 'checkContainsThunks': 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 @'InspectHeap' (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 :: Type) 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 nothunks-0.1.5/test/0000755000000000000000000000000007346545000012536 5ustar0000000000000000nothunks-0.1.5/test/Main.hs0000644000000000000000000000031707346545000013757 0ustar0000000000000000module 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 nothunks-0.1.5/test/Test/NoThunks/0000755000000000000000000000000007346545000015226 5ustar0000000000000000nothunks-0.1.5/test/Test/NoThunks/Class.hs0000644000000000000000000006043707346545000016641 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# 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 qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM.TVar as TVar import qualified Data.IORef as IORef import Hedgehog import Hedgehog.Internal.Report (Result (..), reportStatus) import Hedgehog.Internal.Region (displayRegion) 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 ())) ] , testGroup "MutableVars" [ checkRef (Proxy :: Proxy IORef.IORef) , checkRef (Proxy :: Proxy MVar.MVar) , checkRef (Proxy :: Proxy TVar.TVar) ] ] -- | When using @InspectHeap@ we don't get a context, so merely check if -- 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 #if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) ctxt' = "Tuple2" : ctxt #else ctxt' = "(,)" : ctxt #endif 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 #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) ctxt' = "List" : ctxt #else ctxt' = "[]" : ctxt #endif 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 ("field1" : ctxt') a, modelIsNF ("field2" : ctxt') b] where ctxt' = "Record" : ctxt modelUnexpected ctxt = \case RecordThunk _ -> Just ctxt' RecordDefined _ y -> modelUnexpected ("field2" : 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 ()) {------------------------------------------------------------------------------- Mutable Vars -------------------------------------------------------------------------------} checkRef :: forall ref. (IsRef ref, NoThunks (ref Int)) => Proxy ref -> TestTree checkRef p = testGroup (show (typeRep p)) [ testProperty "NotNF" checkRefNotNF , testProperty "NF" checkRefNF , testProperty "NotNFPure" checkRefNotNFPure , testProperty "NFPure" checkRefNFPure , testProperty "NotNFAtomically" checkRefNotNFAtomically , testProperty "NFAtomically" checkRefNFAtomically ] where checkRefNotNF :: Property checkRefNotNF = checkNFClass False $ \k -> do ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int)) k ref where x :: Int x = 0 checkRefNF :: Property checkRefNF = checkNFClass True $ \k -> do !ref <- liftIO (newRef x :: IO (ref Int)) k ref where x :: Int !x = 0 checkRefNotNFPure :: Property checkRefNotNFPure = unsafeCheckNF False $ \k -> do ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int)) k ref where x :: Int x = 0 checkRefNFPure :: Property checkRefNFPure = unsafeCheckNF True $ \k -> do !ref <- liftIO (newRef x :: IO (ref Int)) k ref where x :: Int !x = 0 checkRefNotNFAtomically :: Property checkRefNotNFAtomically = unsafeCheckNFAtomically False $ \k -> do ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int)) k ref where x :: Int x = 0 checkRefNFAtomically :: Property checkRefNFAtomically = unsafeCheckNFAtomically True $ \k -> do !ref <- liftIO (newRef x :: IO (ref Int)) k ref where x :: Int !x = 0 class Typeable ref => IsRef ref where newRef :: a -> IO (ref a) instance IsRef IORef.IORef where newRef = IORef.newIORef instance IsRef MVar.MVar where newRef = MVar.newMVar instance IsRef TVar.TVar where newRef = TVar.newTVarIO checkNFClass :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property checkNFClass expectedNF k = withTests 1 $ property $ k $ \x -> do nf <- liftIO $ noThunks [] x isNothing nf === expectedNF {-# NOINLINE unsafeCheckNF #-} unsafeCheckNF :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property unsafeCheckNF expectedNF k = withTests 1 $ property $ k $ \x -> do let nf = unsafeNoThunks x isNothing nf === expectedNF {-# NOINLINE unsafeCheckNFAtomically #-} unsafeCheckNFAtomically :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property unsafeCheckNFAtomically expectedNF k = withTests 1 $ property $ k $ \x -> do tvar <- liftIO (TVar.newTVarIO True) true <- liftIO $ STM.atomically $ do val <- TVar.readTVar tvar -- the $! is essential to trigger NestedAtomically exception. return $! val && isNothing (unsafeNoThunks x) true === expectedNF {------------------------------------------------------------------------------- Hedgehog auxiliary -------------------------------------------------------------------------------} expectFailure :: Property -> Property expectFailure p = withTests 1 $ property $ do report <- liftIO $ displayRegion $ \r -> checkNamed r EnableColor (Just "EXPECTED FAILURE") Nothing 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))