From: Ilias Tsitsimpis Date: Fri, 4 Oct 2024 10:34:38 +0000 (+0300) Subject: Import haskell-nothunks_0.1.5.orig.tar.gz X-Git-Tag: archive/raspbian/0.3.1-3+rpi1~4 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=8ca8a7a0aa756c17119ba0c02e5ed4a30c56400d;p=haskell-nothunks.git Import haskell-nothunks_0.1.5.orig.tar.gz [dgit import orig haskell-nothunks_0.1.5.orig.tar.gz] --- 8ca8a7a0aa756c17119ba0c02e5ed4a30c56400d diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..4ad06ba --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,39 @@ +# 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 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f433b1a --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + 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 diff --git a/NOTICE b/NOTICE new file mode 100644 index 0000000..1832755 --- /dev/null +++ b/NOTICE @@ -0,0 +1,14 @@ +Copyright 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. + diff --git a/nothunks.cabal b/nothunks.cabal new file mode 100644 index 0000000..cdefccd --- /dev/null +++ b/nothunks.cabal @@ -0,0 +1,87 @@ +cabal-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 diff --git a/src/NoThunks/Class.hs b/src/NoThunks/Class.hs new file mode 100644 index 0000000..443fabe --- /dev/null +++ b/src/NoThunks/Class.hs @@ -0,0 +1,812 @@ +{-# 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..2c52486 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Test/NoThunks/Class.hs b/test/Test/NoThunks/Class.hs new file mode 100644 index 0000000..64b7189 --- /dev/null +++ b/test/Test/NoThunks/Class.hs @@ -0,0 +1,677 @@ +{-# 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))