--- /dev/null
+# 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 <andreas.abel@gu.se>
+* 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 <git@monoid.al>
+* Make bytestring, text and vector optional dependencies
+ Bodigrim <andrew.lelechenko@gmail.com>
+
+## 0.1.2 -- 2020-12-03
+
+* Add IORef, MVar and TVar instances.
+ Oleg Grenrus <oleg.grenrus@iki.fi>
+
+## 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
--- /dev/null
+
+ 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
--- /dev/null
+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.
+
--- /dev/null
+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 <coot@coot.me>
+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
--- /dev/null
+{-# 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 _ = "<never used since never fails>"
+ noThunks _ _ = return Nothing
+ wNoThunks = noThunks
+
+instance (HasFields s a, Generic a, Typeable a, GWNoThunks s (Rep a))
+ => NoThunks (AllowThunksIn s a) where
+ showTypeOf _ = show $ typeRep (Proxy @a)
+ wNoThunks ctxt (AllowThunksIn x) = gwNoThunks (Proxy @s) ctxt fp
+ where
+ fp :: Rep a x
+ !fp = from x
+
+instance Typeable a => NoThunks (InspectHeap a) where
+ showTypeOf _ = show $ typeRep (Proxy @a)
+ wNoThunks = inspectHeap
+
+instance KnownSymbol name => NoThunks (InspectHeapNamed name a) where
+ showTypeOf _ = symbolVal (Proxy @name)
+ wNoThunks = inspectHeap
+
+-- | Internal: implementation of 'wNoThunks' for 'InspectHeap'
+-- and 'InspectHeapNamed'
+inspectHeap :: Context -> a -> IO (Maybe ThunkInfo)
+inspectHeap ctxt x = do
+ containsThunks <- checkContainsThunks x
+ return $ if containsThunks
+ then Just $ ThunkInfo { thunkContext = "..." : ctxt }
+ else Nothing
+
+{-------------------------------------------------------------------------------
+ Internal: generic infrastructure
+-------------------------------------------------------------------------------}
+
+-- | Generic infrastructure for checking for unexpected thunks
+--
+-- The @a@ argument records which record fields are allowed to contain thunks;
+-- see 'AllowThunksIn' and 'GWRecordField', below.
+class GWNoThunks (a :: [Symbol]) f where
+ -- | Check that the argument does not contain any unexpected thunks
+ --
+ -- Precondition: the argument is in WHNF.
+ gwNoThunks :: proxy a -> Context -> f x -> IO (Maybe ThunkInfo)
+
+instance GWNoThunks a f => GWNoThunks a (D1 c f) where
+ gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp
+
+instance GWNoThunks a f => GWNoThunks a (C1 c f) where
+ gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp
+
+instance GWNoThunks a f => GWNoThunks a (S1 ('MetaSel ('Nothing) su ss ds) f) where
+ gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp
+
+instance (GWNoThunks a f, GWNoThunks a g) => GWNoThunks a (f :*: g) where
+ gwNoThunks a ctxt (fp :*: gp) = allNoThunks [
+ gwNoThunks a ctxt fp
+ , gwNoThunks a ctxt gp
+ ]
+
+instance (GWNoThunks a f, GWNoThunks a g) => GWNoThunks a (f :+: g) where
+ gwNoThunks a ctxt (L1 fp) = gwNoThunks a ctxt fp
+ gwNoThunks a ctxt (R1 gp) = gwNoThunks a ctxt gp
+
+instance NoThunks c => GWNoThunks a (K1 i c) where
+ gwNoThunks _a ctxt (K1 c) = noThunks ctxt' c
+ where
+ -- If @c@ is a recursive occurrence of the type itself, we want to avoid
+ -- accumulating context. For example, suppose we are dealing with @[Int]@,
+ -- and we have an unexpected thunk as the third @Int@ in the list. If
+ -- we use the generic instance, then without this correction, the final
+ -- context will look something like
+ --
+ -- > ["Int", "[]", "[]", "[]"]
+ --
+ -- While that is more informative (it's the /third/ element that is a
+ -- thunk), it's not that helpful (typically we just want /all/ elements
+ -- to be in NF). We strip the context here so that we just get
+ --
+ -- > ["Int", "[]"]
+ --
+ -- which is a bit easier to interpret.
+ ctxt' = case ctxt of
+ hd : tl | hd == showTypeOf (Proxy @c) -> tl
+ _otherwise -> ctxt
+
+instance GWNoThunks a U1 where
+ gwNoThunks _a _ctxt U1 = return Nothing
+
+instance GWNoThunks a V1 where
+ -- By assumption, the argument is already in WHNF. Since every inhabitant of
+ -- this type is bottom, this code is therefore unreachable.
+ gwNoThunks _a _ctxt _ = error "unreachable gwNoThunks @V1"
+
+{-------------------------------------------------------------------------------
+ Skip fields with allowed thunks
+-------------------------------------------------------------------------------}
+
+-- | If @fieldName@ is allowed to contain thunks, skip it.
+instance ( GWRecordField f (Elem fieldName a)
+ , 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
+-- <https://gitlab.haskell.org/ghc/ghc/issues/17290>. However, such thunks can't
+-- retain any data that they shouldn't, and so it's safe to ignore such thunks.
+deriving via OnlyCheckWhnfNamed "Strict.ByteString" BS.Strict.ByteString
+ instance NoThunks BS.Strict.ByteString
+
+-- | Instance for short bytestrings
+--
+-- We have
+--
+-- > data ShortByteString = SBS ByteArray#
+--
+-- Values of this type consist of a tag followed by an _unboxed_ byte array,
+-- which can't contain thunks. Therefore we only check WHNF.
+deriving via OnlyCheckWhnfNamed "ShortByteString" ShortByteString
+ instance NoThunks ShortByteString
+
+-- | Instance for lazy bytestrings
+--
+-- Defined manually so that it piggy-backs on the one for strict bytestrings.
+instance NoThunks BS.Lazy.ByteString where
+ showTypeOf _ = "Lazy.ByteString"
+ wNoThunks ctxt bs =
+ case bs of
+ BS.Lazy.Internal.Empty -> return Nothing
+ BS.Lazy.Internal.Chunk chunk bs' -> allNoThunks [
+ noThunks ctxt chunk
+ , noThunks ctxt bs'
+ ]
+
+#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
--- /dev/null
+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
--- /dev/null
+{-# 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))
projects / haskell-nothunks.git / commitdiff