├── .github └── workflows │ ├── checks.yml │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── NOTICE ├── README.md ├── cabal.project ├── nothunks.cabal ├── scripts └── check-changelogs.sh ├── src └── NoThunks │ └── Class.hs └── test ├── Main.hs └── Test └── NoThunks └── Class.hs /.github/workflows/checks.yml: -------------------------------------------------------------------------------- 1 | name: Checks 2 | on: 3 | pull_request: 4 | types: 5 | - opened 6 | - synchronize 7 | merge_group: 8 | jobs: 9 | check-changelogs: 10 | name: Check changelogs 11 | runs-on: ubuntu-latest 12 | defaults: 13 | run: 14 | shell: bash 15 | 16 | steps: 17 | - name: Install dependencies 18 | run: sudo apt install -y fd-find 19 | 20 | - uses: actions/checkout@v4 21 | 22 | - name: git fetch 23 | run: git fetch origin master:master 24 | 25 | - name: Check changelogs 26 | run: ./scripts/check-changelogs.sh 27 | 28 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | merge_group: 11 | jobs: 12 | build: 13 | runs-on: ubuntu-latest 14 | strategy: 15 | matrix: 16 | ghc: ["8.10", "9.0", "9.2", "9.4", "9.6", "9.8", "9.10", "9.12"] 17 | steps: 18 | - uses: actions/checkout@v4 19 | - name: "Setup haskell" 20 | uses: haskell-actions/setup@v2 21 | id: setup-haskell 22 | with: 23 | ghc-version: ${{ matrix.ghc }} 24 | cabal-version: latest 25 | cabal-update: true 26 | - run: | 27 | cabal configure --enable-tests --disable-documentation 28 | cabal build --dry-run 29 | # The latter generates dist-newstyle/cache/plan.json which serves as cache key. 30 | - uses: actions/cache@v3 31 | with: 32 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 33 | key: ${{ runner.os }}-${{ steps.setup-haskell.outputs.ghc-version }}-${{ hashFiles('dist-newstyle/cache/plan.json') }} 34 | restore-keys: | 35 | ${{ runner.os }}-${{ steps.setup-haskell.outputs.ghc-version }}- 36 | - run: cabal build 37 | - run: cabal test 38 | - run: cabal haddock 39 | - run: cabal sdist 40 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | tags 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for nothunks 2 | 3 | ## Unreleased 4 | 5 | * Added support for: 6 | * `containers-0.8` 7 | * `random-1.3.0` 8 | 9 | ## 0.3.1 -- 2025-01-06 10 | 11 | * Make it build with ghc-9.12. 12 | 13 | ## 0.3.0 -- 2024-08-13 14 | 15 | * Include _both_ `Context` _and_ `Info` in `ThunkInfo` (#54) 16 | 17 | ## 0.2.1.0 -- 2024-02-06 18 | 19 | * Exported `mkThunkInfo`. 20 | * Test support of `ghc-9.10`. 21 | 22 | ## 0.2.1.0 -- 2024-02-06 23 | 24 | * Support `wherefrom` with `GHC-9.2` or newer. (Teo Camarasu, [#49](https://github.com/input-output-hk/nothunks/pull/49)) 25 | 26 | ## 0.2.0 -- 2024-01-27 27 | 28 | * Use `whereFrom` to get source information, which is avialable when the source 29 | is compiled with `GHC-9.6` (or newer) and with `-finfo-table-map` (and even 30 | more accurate when `-fdistinct-constructor-table` is passed). 31 | For that reason the `ThunkInfo` type has changed. 32 | * `NoThunks` instance for `Data.Tuple.Solo`. 33 | * `NoThunks` instances for `Data.Semigroup` and `Data.Monoid` newtype wrappers. 34 | 35 | ## 0.1.5 -- 2023-10-29 36 | 37 | * `NoThunks ThreadId` instance. 38 | * `NoThunks Identity` instance 39 | * Fix tests on ghc 9.8. 40 | Andreas Abel 41 | * Tested with ghc 8.10 to 9.8. 42 | 43 | ## 0.1.4 -- 2023-03-27 44 | 45 | * Made cabal flags manual. 46 | * Support ghc-9.2 to 9.6. 47 | * `ThunkInfo` is a newtype. 48 | 49 | ## 0.1.3 -- 2021-06-28 50 | 51 | * Fix tests on ghc-9.0.1 52 | Joe Hermaszewski 53 | * Make bytestring, text and vector optional dependencies 54 | Bodigrim 55 | 56 | ## 0.1.2 -- 2020-12-03 57 | 58 | * Add IORef, MVar and TVar instances. 59 | Oleg Grenrus 60 | 61 | ## 0.1.1.0 -- 2020-09-29 62 | 63 | * Export `Context` and `GWNoThunks` 64 | * Fix typos in Haddocks 65 | * Improve bounds (and add upper bounds) 66 | 67 | ## 0.1.0.0 -- 2020-09-09 68 | 69 | * Initial public release 70 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | Copyright 2018-2025 Input Output Global Inc (IOG) 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # nothunks 2 | 3 | [![CI Tests](https://github.com/input-output-hk/nothunks/actions/workflows/ci.yml/badge.svg)](https://github.com/input-output-hk/nothunks/actions/workflows/ci.yml) 4 | 5 | 6 | Long lived application data typically should not contain any thunks. This 7 | library can be used to examine values for unexpected thunks, which can then be 8 | used in assertions. This can be invaluable in avoiding memory leaks, or tracking 9 | down existing ones. 10 | 11 | See my presentation 12 | [MuniHac 2020: Being lazy without being bloated](https://www.youtube.com/watch?v=7t6wt7ByBWg) 13 | for an overview, motivating the library and explaining how it is intended to be 14 | used and how it works internally. 15 | 16 | 17 | `nothunks` will try to get source information from info tables. For that one 18 | needs to use `GHC` `9.2` or newer and compile the code with 19 | `-finfo-table-map`. More precise information will be available if 20 | `-fdistinct-constructor-tables` flag is used as well. 21 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: nothunks.cabal 2 | 3 | package nothunks 4 | tests: True 5 | 6 | test-show-details: direct 7 | 8 | if impl (ghc >= 9.12) 9 | allow-newer: 10 | , filepath:template-haskell 11 | , hedgehog:template-haskell 12 | , text:template-haskell 13 | -------------------------------------------------------------------------------- /nothunks.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: nothunks 3 | version: 0.3.1 4 | synopsis: Examine values for unexpected thunks 5 | description: Long lived application data typically should not contain 6 | any thunks. This library can be used to examine values for 7 | unexpected thunks, which can then be used in assertions. 8 | This can be invaluable in avoiding memory leaks, or tracking 9 | down existing ones. 10 | license: Apache-2.0 11 | license-files: LICENSE 12 | NOTICE 13 | bug-reports: https://github.com/input-output-hk/nothunks 14 | author: IOG 15 | maintainer: Marcin Szamotulski 16 | copyright: 2018-2025 Input Output Global Inc (IOG) 17 | category: Development 18 | extra-doc-files: README.md CHANGELOG.md 19 | tested-with: GHC == {8.10, 9.0, 9.2, 9.4, 9.6, 9.8, 9.10, 9.12} 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/input-output-hk/nothunks 24 | 25 | flag bytestring 26 | description: Provide instances for bytestring 27 | default: True 28 | manual: True 29 | 30 | flag text 31 | description: Provide instances for text 32 | default: True 33 | manual: True 34 | 35 | flag vector 36 | description: Provide instances for vector 37 | default: True 38 | manual: True 39 | 40 | library 41 | exposed-modules: NoThunks.Class 42 | 43 | build-depends: base >= 4.12 && < 5 44 | , containers >= 0.5 && < 0.9 45 | , stm >= 2.5 && < 2.6 46 | , time >= 1.5 && < 1.15 47 | 48 | -- Whatever is bundled with ghc 49 | , ghc-heap 50 | 51 | if impl(ghc >= 9.2) 52 | build-depends: wherefrom-compat ^>= 0.2 53 | 54 | if flag(bytestring) 55 | build-depends: bytestring >= 0.10 && < 0.13 56 | if flag(text) 57 | build-depends: text >= 1.2 && < 1.3 || >= 2 && < 2.2 58 | if flag(vector) 59 | build-depends: vector >= 0.12 && < 0.14 60 | 61 | hs-source-dirs: src 62 | default-language: Haskell2010 63 | ghc-options: -Wall 64 | 65 | test-suite nothunks-test 66 | type: exitcode-stdio-1.0 67 | main-is: Main.hs 68 | other-modules: Test.NoThunks.Class 69 | 70 | build-depends: base 71 | 72 | -- Self dependency 73 | , nothunks 74 | 75 | -- Dependencies shared with the lib 76 | , containers 77 | , stm 78 | 79 | -- Whatever is bundled with ghc 80 | , ghc-prim 81 | 82 | -- Additional dependencies 83 | , hedgehog >= 1.1 && < 1.6 84 | , random >= 1.1 && < 1.4 85 | , tasty >= 1.3 && < 1.6 86 | , tasty-hedgehog >= 1.1 && < 1.5 87 | 88 | hs-source-dirs: test 89 | default-language: Haskell2010 90 | ghc-options: -Wall 91 | -------------------------------------------------------------------------------- /scripts/check-changelogs.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | FD="$(which fdfind 2>/dev/null || which fd 2>/dev/null)" 4 | 5 | set -eo pipefail 6 | 7 | function check_project () { 8 | project=$1 9 | n=$() 10 | if [[ -n $(git diff --name-only origin/master..HEAD -- $project) ]];then 11 | if [[ -z $(git diff --name-only origin/master..HEAD -- $project/CHANGELOG.md) ]]; then 12 | echo "$project was modified but its CHANGELOG was not updated" 13 | exit 1 14 | fi 15 | fi 16 | } 17 | 18 | for cbl in $($FD -e 'cabal'); do 19 | check_project $(dirname $cbl) 20 | done 21 | 22 | -------------------------------------------------------------------------------- /src/NoThunks/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE DerivingVia #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module NoThunks.Class ( 18 | -- * Check a value for unexpected thunks 19 | NoThunks(..) 20 | , ThunkInfo(..) 21 | , mkThunkInfo 22 | , Context 23 | , Info 24 | , unsafeNoThunks 25 | -- * Helpers for defining instances 26 | , allNoThunks 27 | , noThunksInValues 28 | , noThunksInKeysAndValues 29 | -- * Deriving-via wrappers 30 | , OnlyCheckWhnf(..) 31 | , OnlyCheckWhnfNamed(..) 32 | , InspectHeap(..) 33 | , InspectHeapNamed(..) 34 | , AllowThunk(..) 35 | , AllowThunksIn(..) 36 | -- * Generic class 37 | , GWNoThunks(..) 38 | ) where 39 | 40 | import Data.Proxy 41 | import Data.Typeable 42 | import System.IO.Unsafe (unsafePerformIO) 43 | 44 | import GHC.Exts.Heap 45 | import GHC.Generics 46 | import GHC.Records 47 | import GHC.TypeLits 48 | import GHC.Conc.Sync (ThreadId (..)) 49 | 50 | -- For instances 51 | 52 | import Data.Foldable (toList) 53 | import Data.Functor.Identity (Identity) 54 | import Data.Int 55 | import Data.IntMap (IntMap) 56 | import Data.Kind (Type) 57 | import Data.List.NonEmpty (NonEmpty (..)) 58 | import Data.Map (Map) 59 | import Data.Ratio 60 | import Data.Sequence (Seq) 61 | import Data.Set (Set) 62 | import Data.Time 63 | #if MIN_VERSION_base(4,16,0) 64 | import Data.Tuple (Solo (..)) 65 | #endif 66 | import Data.Void (Void) 67 | import Data.Word 68 | import GHC.Stack 69 | -- base-4.16 exports 'Natural' from 'GHC.TypeLits' 70 | #if !MIN_VERSION_base(4,16,0) 71 | import Numeric.Natural 72 | #endif 73 | 74 | #if MIN_VERSION_base(4,16,0) 75 | import GHC.InfoProv.Compat 76 | #endif 77 | 78 | import qualified Control.Concurrent.MVar as MVar 79 | import qualified Control.Concurrent.STM.TVar as TVar 80 | import qualified Data.IntMap as IntMap 81 | import qualified Data.IORef as IORef 82 | import qualified Data.Map as Map 83 | import qualified Data.Set as Set 84 | import qualified Data.Monoid as Monoid 85 | import qualified Data.Semigroup as Semigroup 86 | 87 | #ifdef MIN_VERSION_bytestring 88 | import Data.ByteString.Short (ShortByteString) 89 | import qualified Data.ByteString as BS.Strict 90 | import qualified Data.ByteString.Lazy as BS.Lazy 91 | import qualified Data.ByteString.Lazy.Internal as BS.Lazy.Internal 92 | #endif 93 | 94 | #ifdef MIN_VERSION_text 95 | import qualified Data.Text as Text.Strict 96 | import qualified Data.Text.Internal.Lazy as Text.Lazy.Internal 97 | import qualified Data.Text.Lazy as Text.Lazy 98 | #endif 99 | 100 | #ifdef MIN_VERSION_vector 101 | import qualified Data.Vector as Vector.Boxed 102 | import qualified Data.Vector.Unboxed as Vector.Unboxed 103 | #endif 104 | 105 | {------------------------------------------------------------------------------- 106 | Check a value for unexpected thunks 107 | -------------------------------------------------------------------------------} 108 | 109 | -- | Check a value for unexpected thunks 110 | class NoThunks a where 111 | -- | Check if the argument does not contain any unexpected thunks 112 | -- 113 | -- For most datatypes, we should have that 114 | -- 115 | -- > noThunks ctxt x == Nothing 116 | -- 117 | -- if and only if 118 | -- 119 | -- > checkContainsThunks x 120 | -- 121 | -- For some datatypes however, some thunks are expected. For example, the 122 | -- internal fingertree 'Data.Sequence.Sequence' might contain thunks (this is 123 | -- important for the asymptotic complexity of this data structure). However, 124 | -- we should still check that the /values/ in the sequence don't contain any 125 | -- unexpected thunks. 126 | -- 127 | -- This means that we need to traverse the sequence, which might force some of 128 | -- the thunks in the tree. In general, it is acceptable for 129 | -- 'noThunks' to force such "expected thunks", as long as it always 130 | -- reports the /unexpected/ thunks. 131 | -- 132 | -- The default implementation of 'noThunks' checks that the argument is in 133 | -- WHNF, and if so, adds the type into the context (using 'showTypeOf' or 134 | -- 'whereFrom' if available), and calls 'wNoThunks'. See 'ThunkInfo' for 135 | -- a detailed discussion of the type context. 136 | -- 137 | -- 138 | -- See also discussion of caveats listed for 'checkContainsThunks'. 139 | noThunks :: Context -> a -> IO (Maybe ThunkInfo) 140 | noThunks ctxt x = do 141 | isThunk <- checkIsThunk x 142 | let ctxt' = showTypeOf (Proxy @a) : ctxt 143 | thunkInfo <- mkThunkInfo ctxt' x 144 | if isThunk 145 | then return $ Just thunkInfo 146 | else wNoThunks ctxt' x 147 | 148 | -- | Check that the argument is in normal form, assuming it is in WHNF. 149 | -- 150 | -- The context will already have been extended with the type we're looking at, 151 | -- so all that's left is to look at the thunks /inside/ the type. The default 152 | -- implementation uses GHC Generics to do this. 153 | wNoThunks :: Context -> a -> IO (Maybe ThunkInfo) 154 | default wNoThunks :: (Generic a, GWNoThunks '[] (Rep a)) 155 | => Context -> a -> IO (Maybe ThunkInfo) 156 | wNoThunks ctxt x = gwNoThunks (Proxy @'[]) ctxt fp 157 | where 158 | -- Force the result of @from@ to WHNF: we are not interested in thunks 159 | -- that arise from the translation to the generic representation. 160 | fp :: Rep a x 161 | !fp = from x 162 | 163 | -- | Show type @a@ (to add to the context) 164 | -- 165 | -- We try hard to avoid 'Typeable' constraints in this module: there are types 166 | -- with no 'Typeable' instance but with a 'NoThunks' instance (most 167 | -- important example are types such as @ST s@ which rely on parametric 168 | -- polymorphism). By default we should therefore only show the "outer layer"; 169 | -- for example, if we have a type 170 | -- 171 | -- > Seq (ST s ()) 172 | -- 173 | -- then 'showTypeOf' should just give @Seq@, leaving it up to the instance for 174 | -- @ST@ to decide how to implement 'showTypeOf'; this keeps things 175 | -- compositional. The default implementation does precisely this using the 176 | -- metadata that GHC Generics provides. 177 | -- 178 | -- For convenience, however, some of the @deriving via@ newtype wrappers we 179 | -- provide /do/ depend on @Typeable@; see below. 180 | showTypeOf :: Proxy a -> String 181 | default showTypeOf :: (Generic a, GShowTypeOf (Rep a)) => Proxy a -> String 182 | showTypeOf _ = gShowTypeOf (from x) 183 | where 184 | x :: a 185 | x = x 186 | 187 | -- | Context where a thunk was found 188 | -- 189 | -- This is intended to give a hint about which thunk was found. For example, 190 | -- a thunk might be reported with context 191 | -- 192 | -- > ["Int", "(,)", "Map", "AppState"] 193 | -- 194 | -- telling you that you have an @AppState@ containing a @Map@ containing a pair, 195 | -- all of which weren't thunks (were in WHNF), but that pair contained an 196 | -- @Int@ which was a thunk. 197 | type Context = [String] 198 | 199 | -- | Binding name, type and location information about the thunk, e.g. 200 | -- 201 | -- > fromModel :: Int @ test/Test/NoThunks/Class.hs:198:53-84 202 | -- 203 | type Info = String 204 | 205 | {------------------------------------------------------------------------------- 206 | Results of the check 207 | -------------------------------------------------------------------------------} 208 | 209 | -- | Information about unexpected thunks 210 | -- 211 | -- ThunkInfo contains either precise `Info` about the thunk location 212 | -- or `Context` to make it easier to debug space leaks. `Info` is available if 213 | -- 214 | -- * @GHC-9.4@ or newer is used, 215 | -- * the code is compiled with @-finfo-table-map@ and is improved if 216 | -- @-fdistinct-constructor-tables@ is used as well. 217 | -- 218 | -- The @Context@ argument is intended to give a clue to add debugging. 219 | -- For example, suppose we have something of type @(Int, [Int])@. The 220 | -- various contexts we might get are 221 | -- 222 | -- > Context The thunk is.. 223 | -- > --------------------------------------------------------------------- 224 | -- > ["(,)"] the pair itself 225 | -- > ["Int","(,)"] the Int in the pair 226 | -- > ["List","(,)"] the [Int] in the pair 227 | -- > ["Int","List","(,)"] an Int in the [Int] in the pair 228 | -- 229 | -- Note: prior to `ghc-9.6` a list was indicated by `[]`. 230 | data ThunkInfo = ThunkInfo { 231 | thunkContext :: Context 232 | , thunkInfo :: Maybe Info 233 | } 234 | deriving Show 235 | 236 | -- | Construct `ThunkInfo` either from `Context` or information provided by 237 | -- `GHC` about `a` (see `whereFrom`). 238 | -- 239 | mkThunkInfo :: Context -> a -> IO ThunkInfo 240 | #if MIN_VERSION_base(4,16,0) 241 | mkThunkInfo ctxt a = ThunkInfo ctxt . fmap fmt <$> whereFrom a 242 | where 243 | fmt :: InfoProv -> Info 244 | fmt InfoProv { ipSrcFile, ipSrcSpan, 245 | ipLabel, ipTyDesc } = 246 | ipLabel ++ " :: " ++ ipTyDesc 247 | ++ " @ " ++ ipSrcFile ++ ":" ++ ipSrcSpan 248 | #else 249 | mkThunkInfo ctxt _ = return (ThunkInfo ctxt Nothing) 250 | #endif 251 | 252 | 253 | {-# NOINLINE unsafeNoThunks #-} 254 | -- | Call 'noThunks' in a pure context (relies on 'unsafePerformIO'). 255 | unsafeNoThunks :: NoThunks a => a -> Maybe ThunkInfo 256 | unsafeNoThunks a = unsafePerformIO $ noThunks [] a 257 | 258 | {------------------------------------------------------------------------------- 259 | Helpers for defining NoThunks instances 260 | -------------------------------------------------------------------------------} 261 | 262 | -- | Short-circuit a list of checks 263 | allNoThunks :: [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo) 264 | allNoThunks = go 265 | where 266 | go :: [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo) 267 | go [] = return Nothing 268 | go (a:as) = do 269 | nf <- a 270 | case nf of 271 | Nothing -> go as 272 | Just thunk -> return $ Just thunk 273 | 274 | -- | Check that all elements in the list are thunk-free 275 | -- 276 | -- Does not check the list itself. Useful for checking the elements of a 277 | -- container. 278 | -- 279 | -- See also 'noThunksInKeysAndValues' 280 | noThunksInValues :: NoThunks a => Context -> [a] -> IO (Maybe ThunkInfo) 281 | noThunksInValues ctxt = allNoThunks . map (noThunks ctxt) 282 | 283 | -- | Variant on 'noThunksInValues' for keyed containers. 284 | -- 285 | -- Neither the list nor the tuples are checked for thunks. 286 | noThunksInKeysAndValues :: (NoThunks k, NoThunks v) 287 | => Context -> [(k, v)] -> IO (Maybe ThunkInfo) 288 | noThunksInKeysAndValues ctxt = 289 | allNoThunks 290 | . concatMap (\(k, v) -> [ noThunks ctxt k 291 | , noThunks ctxt v 292 | ]) 293 | 294 | {------------------------------------------------------------------------------- 295 | Newtype wrappers for deriving via 296 | -------------------------------------------------------------------------------} 297 | 298 | -- | Newtype wrapper for use with @deriving via@ to check for WHNF only 299 | -- 300 | -- For some types we don't want to check for nested thunks, and we only want 301 | -- check if the argument is in WHNF, not in NF. A typical example are functions; 302 | -- see the instance of @(a -> b)@ for detailed discussion. This should be used 303 | -- sparingly. 304 | -- 305 | -- Example: 306 | -- 307 | -- > deriving via OnlyCheckWhnf T instance NoThunks T 308 | newtype OnlyCheckWhnf a = OnlyCheckWhnf a 309 | 310 | -- | Variant on 'OnlyCheckWhnf' that does not depend on 'Generic' 311 | -- 312 | -- Example: 313 | -- 314 | -- > deriving via OnlyCheckWhnfNamed "T" T instance NoThunks T 315 | newtype OnlyCheckWhnfNamed (name :: Symbol) a = OnlyCheckWhnfNamed a 316 | 317 | -- | Newtype wrapper for values that should be allowed to be a thunk 318 | -- 319 | -- This should be used /VERY/ sparingly, and should /ONLY/ be used on values 320 | -- (or, even rarer, types) which you are /SURE/ cannot retain any data that they 321 | -- shouldn't. Bear in mind allowing a value of type @T@ to be a thunk might 322 | -- cause a value of type @S@ to be retained if @T@ was computed from @S@. 323 | newtype AllowThunk a = AllowThunk a 324 | 325 | -- | Newtype wrapper for records where some of the fields are allowed to be 326 | -- thunks. 327 | -- 328 | -- Example: 329 | -- 330 | -- > deriving via AllowThunksIn '["foo","bar"] T instance NoThunks T 331 | -- 332 | -- This will create an instance that skips the thunk checks for the "foo" and 333 | -- "bar" fields. 334 | newtype AllowThunksIn (fields :: [Symbol]) a = AllowThunksIn a 335 | 336 | -- | Newtype wrapper for use with @deriving via@ to inspect the heap directly 337 | -- 338 | -- This bypasses the class instances altogether, and inspects the GHC heap 339 | -- directly, checking that the value does not contain any thunks /anywhere/. 340 | -- Since we can do this without any type classes instances, this is useful for 341 | -- types that contain fields for which 'NoThunks' instances are not available. 342 | -- 343 | -- Since the primary use case for 'InspectHeap' then is to give instances 344 | -- for 'NoThunks' from third party libraries, we also don't want to 345 | -- rely on a 'Generic' instance, which may likewise not be available. Instead, 346 | -- we will rely on 'Typeable', which is available for /all/ types. However, as 347 | -- 'showTypeOf' explains, requiring 'Typeable' may not always be suitable; if 348 | -- it isn't, 'InspectHeapNamed' can be used. 349 | -- 350 | -- Example: 351 | -- 352 | -- > deriving via InspectHeap T instance NoThunks T 353 | newtype InspectHeap a = InspectHeap a 354 | 355 | -- | Variant on 'InspectHeap' that does not depend on 'Typeable'. 356 | -- 357 | -- > deriving via InspectHeapNamed "T" T instance NoUnexpecedThunks T 358 | newtype InspectHeapNamed (name :: Symbol) a = InspectHeapNamed a 359 | 360 | {------------------------------------------------------------------------------- 361 | Internal: instances for the deriving-via wrappers 362 | -------------------------------------------------------------------------------} 363 | 364 | instance Typeable a => NoThunks (OnlyCheckWhnf a) where 365 | showTypeOf _ = show $ typeRep (Proxy @a) 366 | wNoThunks _ _ = return Nothing 367 | 368 | instance KnownSymbol name => NoThunks (OnlyCheckWhnfNamed name a) where 369 | showTypeOf _ = symbolVal (Proxy @name) 370 | wNoThunks _ _ = return Nothing 371 | 372 | instance NoThunks (AllowThunk a) where 373 | showTypeOf _ = "" 374 | noThunks _ _ = return Nothing 375 | wNoThunks = noThunks 376 | 377 | instance (HasFields s a, Generic a, Typeable a, GWNoThunks s (Rep a)) 378 | => NoThunks (AllowThunksIn s a) where 379 | showTypeOf _ = show $ typeRep (Proxy @a) 380 | wNoThunks ctxt (AllowThunksIn x) = gwNoThunks (Proxy @s) ctxt fp 381 | where 382 | fp :: Rep a x 383 | !fp = from x 384 | 385 | instance Typeable a => NoThunks (InspectHeap a) where 386 | showTypeOf _ = show $ typeRep (Proxy @a) 387 | wNoThunks = inspectHeap 388 | 389 | instance KnownSymbol name => NoThunks (InspectHeapNamed name a) where 390 | showTypeOf _ = symbolVal (Proxy @name) 391 | wNoThunks = inspectHeap 392 | 393 | -- | Internal: implementation of 'wNoThunks' for 'InspectHeap' 394 | -- and 'InspectHeapNamed' 395 | inspectHeap :: Context -> a -> IO (Maybe ThunkInfo) 396 | inspectHeap ctxt x = do 397 | containsThunks <- checkContainsThunks x 398 | thunkInfo <- mkThunkInfo ("..." : ctxt) x 399 | return $ if containsThunks 400 | then Just thunkInfo 401 | else Nothing 402 | 403 | {------------------------------------------------------------------------------- 404 | Internal: generic infrastructure 405 | -------------------------------------------------------------------------------} 406 | 407 | -- | Generic infrastructure for checking for unexpected thunks 408 | -- 409 | -- The @a@ argument records which record fields are allowed to contain thunks; 410 | -- see 'AllowThunksIn' and 'GWRecordField', below. 411 | class GWNoThunks (a :: [Symbol]) f where 412 | -- | Check that the argument does not contain any unexpected thunks 413 | -- 414 | -- Precondition: the argument is in WHNF. 415 | gwNoThunks :: proxy a -> Context -> f x -> IO (Maybe ThunkInfo) 416 | 417 | instance GWNoThunks a f => GWNoThunks a (D1 c f) where 418 | gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp 419 | 420 | instance GWNoThunks a f => GWNoThunks a (C1 c f) where 421 | gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp 422 | 423 | instance GWNoThunks a f => GWNoThunks a (S1 ('MetaSel 'Nothing su ss ds) f) where 424 | gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp 425 | 426 | instance (GWNoThunks a f, GWNoThunks a g) => GWNoThunks a (f :*: g) where 427 | gwNoThunks a ctxt (fp :*: gp) = allNoThunks [ 428 | gwNoThunks a ctxt fp 429 | , gwNoThunks a ctxt gp 430 | ] 431 | 432 | instance (GWNoThunks a f, GWNoThunks a g) => GWNoThunks a (f :+: g) where 433 | gwNoThunks a ctxt (L1 fp) = gwNoThunks a ctxt fp 434 | gwNoThunks a ctxt (R1 gp) = gwNoThunks a ctxt gp 435 | 436 | instance NoThunks c => GWNoThunks a (K1 i c) where 437 | gwNoThunks _a ctxt (K1 c) = noThunks ctxt' c 438 | where 439 | -- If @c@ is a recursive occurrence of the type itself, we want to avoid 440 | -- accumulating context. For example, suppose we are dealing with @[Int]@, 441 | -- and we have an unexpected thunk as the third @Int@ in the list. If 442 | -- we use the generic instance, then without this correction, the final 443 | -- context will look something like 444 | -- 445 | -- > ["Int", "[]", "[]", "[]"] 446 | -- 447 | -- While that is more informative (it's the /third/ element that is a 448 | -- thunk), it's not that helpful (typically we just want /all/ elements 449 | -- to be in NF). We strip the context here so that we just get 450 | -- 451 | -- > ["Int", "[]"] 452 | -- 453 | -- which is a bit easier to interpret. 454 | ctxt' = case ctxt of 455 | hd : tl | hd == showTypeOf (Proxy @c) -> tl 456 | _otherwise -> ctxt 457 | 458 | instance GWNoThunks a U1 where 459 | gwNoThunks _a _ctxt U1 = return Nothing 460 | 461 | instance GWNoThunks a V1 where 462 | -- By assumption, the argument is already in WHNF. Since every inhabitant of 463 | -- this type is bottom, this code is therefore unreachable. 464 | gwNoThunks _a _ctxt _ = error "unreachable gwNoThunks @V1" 465 | 466 | {------------------------------------------------------------------------------- 467 | Skip fields with allowed thunks 468 | -------------------------------------------------------------------------------} 469 | 470 | -- | If @fieldName@ is allowed to contain thunks, skip it. 471 | instance ( GWRecordField f (Elem fieldName a) 472 | , KnownSymbol fieldName 473 | ) 474 | => GWNoThunks a (S1 ('MetaSel ('Just fieldName) su ss ds) f) where 475 | gwNoThunks _ ctxt (M1 fp) = 476 | gwRecordField (Proxy @(Elem fieldName a)) (symbolVal @fieldName Proxy : ctxt) fp 477 | 478 | class GWRecordField f (b :: Bool) where 479 | gwRecordField :: proxy b -> Context -> f x -> IO (Maybe ThunkInfo) 480 | 481 | -- | If the field is allowed to contain thunks, don't check anything. 482 | instance GWRecordField f 'True where 483 | gwRecordField _ _ _ = return Nothing 484 | 485 | instance GWNoThunks '[] f => GWRecordField f 'False where 486 | gwRecordField _ ctxt f = gwNoThunks (Proxy @'[]) ctxt f 487 | 488 | {------------------------------------------------------------------------------- 489 | Internal: generic function to get name of a type 490 | -------------------------------------------------------------------------------} 491 | 492 | class GShowTypeOf f where 493 | gShowTypeOf :: f x -> String 494 | 495 | instance Datatype c => GShowTypeOf (D1 c f) where 496 | gShowTypeOf = datatypeName 497 | 498 | {------------------------------------------------------------------------------- 499 | Instances for primitive types 500 | -------------------------------------------------------------------------------} 501 | 502 | deriving via OnlyCheckWhnf Bool instance NoThunks Bool 503 | deriving via OnlyCheckWhnf Natural instance NoThunks Natural 504 | deriving via OnlyCheckWhnf Integer instance NoThunks Integer 505 | deriving via OnlyCheckWhnf Float instance NoThunks Float 506 | deriving via OnlyCheckWhnf Double instance NoThunks Double 507 | deriving via OnlyCheckWhnf Char instance NoThunks Char 508 | 509 | deriving via OnlyCheckWhnf Int instance NoThunks Int 510 | deriving via OnlyCheckWhnf Int8 instance NoThunks Int8 511 | deriving via OnlyCheckWhnf Int16 instance NoThunks Int16 512 | deriving via OnlyCheckWhnf Int32 instance NoThunks Int32 513 | deriving via OnlyCheckWhnf Int64 instance NoThunks Int64 514 | 515 | deriving via OnlyCheckWhnf Word instance NoThunks Word 516 | deriving via OnlyCheckWhnf Word8 instance NoThunks Word8 517 | deriving via OnlyCheckWhnf Word16 instance NoThunks Word16 518 | deriving via OnlyCheckWhnf Word32 instance NoThunks Word32 519 | deriving via OnlyCheckWhnf Word64 instance NoThunks Word64 520 | 521 | {------------------------------------------------------------------------------- 522 | Semigroups 523 | -------------------------------------------------------------------------------} 524 | 525 | deriving via a instance NoThunks a => NoThunks (Semigroup.Min a) 526 | deriving via a instance NoThunks a => NoThunks (Semigroup.Max a) 527 | deriving via a instance NoThunks a => NoThunks (Semigroup.First a) 528 | deriving via a instance NoThunks a => NoThunks (Semigroup.Last a) 529 | deriving via a instance NoThunks a => NoThunks (Semigroup.Dual a) 530 | deriving via Bool instance NoThunks Semigroup.All 531 | deriving via Bool instance NoThunks Semigroup.Any 532 | deriving via a instance NoThunks a => NoThunks (Semigroup.Sum a) 533 | deriving via a instance NoThunks a => NoThunks (Semigroup.Product a) 534 | deriving via a instance NoThunks a => NoThunks (Semigroup.WrappedMonoid a) 535 | instance (NoThunks a, NoThunks b) => NoThunks (Semigroup.Arg a b) 536 | 537 | {------------------------------------------------------------------------------- 538 | Monoids 539 | -------------------------------------------------------------------------------} 540 | 541 | deriving via (Maybe a) instance NoThunks a => NoThunks (Monoid.First a) 542 | deriving via (Maybe a) instance NoThunks a => NoThunks (Monoid.Last a) 543 | deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Alt f a) 544 | deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Ap f a) 545 | 546 | {------------------------------------------------------------------------------- 547 | Solo 548 | -------------------------------------------------------------------------------} 549 | 550 | #if MIN_VERSION_base(4,18,0) 551 | -- GHC-9.6 and newer 552 | instance NoThunks a => NoThunks (Solo a) where 553 | wNoThunks ctx (MkSolo a) = wNoThunks ("Solo" : ctx) a 554 | #elif MIN_VERSION_base(4,16,0) 555 | -- GHC-9.2 556 | instance NoThunks a => NoThunks (Solo a) where 557 | wNoThunks ctx (Solo a) = wNoThunks ("Solo" : ctx) a 558 | #endif 559 | 560 | {------------------------------------------------------------------------------- 561 | Mutable Vars 562 | -------------------------------------------------------------------------------} 563 | 564 | instance NoThunks a => NoThunks (IORef.IORef a) where 565 | showTypeOf _ = "IORef" 566 | wNoThunks ctx ref = do 567 | val <- IORef.readIORef ref 568 | noThunks ctx val 569 | 570 | instance NoThunks a => NoThunks (MVar.MVar a) where 571 | showTypeOf _ = "MVar" 572 | wNoThunks ctx ref = do 573 | val <- MVar.tryReadMVar ref 574 | maybe (return Nothing) (noThunks ctx) val 575 | 576 | instance NoThunks a => NoThunks (TVar.TVar a) where 577 | showTypeOf _ = "TVar" 578 | wNoThunks ctx ref = do 579 | -- An alternative is to use 580 | -- 581 | -- val <- STM.atomically $ TVar.readTVar ref 582 | -- 583 | -- but that would cause nested atomically failures with 584 | -- unsafeNoThunks. Fortunately, readTVarIO doesn't make a transaction. 585 | -- 586 | -- See related tests. 587 | -- 588 | val <- TVar.readTVarIO ref 589 | noThunks ctx val 590 | 591 | {------------------------------------------------------------------------------- 592 | Time 593 | -------------------------------------------------------------------------------} 594 | 595 | deriving via InspectHeap Day instance NoThunks Day 596 | deriving via InspectHeap DiffTime instance NoThunks DiffTime 597 | deriving via InspectHeap LocalTime instance NoThunks LocalTime 598 | deriving via InspectHeap NominalDiffTime instance NoThunks NominalDiffTime 599 | deriving via InspectHeap TimeLocale instance NoThunks TimeLocale 600 | deriving via InspectHeap TimeOfDay instance NoThunks TimeOfDay 601 | deriving via InspectHeap TimeZone instance NoThunks TimeZone 602 | deriving via InspectHeap UniversalTime instance NoThunks UniversalTime 603 | deriving via InspectHeap UTCTime instance NoThunks UTCTime 604 | deriving via InspectHeap ZonedTime instance NoThunks ZonedTime 605 | 606 | {------------------------------------------------------------------------------- 607 | ByteString 608 | -------------------------------------------------------------------------------} 609 | 610 | #ifdef MIN_VERSION_bytestring 611 | 612 | -- | Instance for string bytestrings 613 | -- 614 | -- Strict bytestrings /shouldn't/ contain any thunks, but could, due to 615 | -- . However, such thunks can't 616 | -- retain any data that they shouldn't, and so it's safe to ignore such thunks. 617 | deriving via OnlyCheckWhnfNamed "Strict.ByteString" BS.Strict.ByteString 618 | instance NoThunks BS.Strict.ByteString 619 | 620 | -- | Instance for short bytestrings 621 | -- 622 | -- We have 623 | -- 624 | -- > data ShortByteString = SBS ByteArray# 625 | -- 626 | -- Values of this type consist of a tag followed by an _unboxed_ byte array, 627 | -- which can't contain thunks. Therefore we only check WHNF. 628 | deriving via OnlyCheckWhnfNamed "ShortByteString" ShortByteString 629 | instance NoThunks ShortByteString 630 | 631 | -- | Instance for lazy bytestrings 632 | -- 633 | -- Defined manually so that it piggy-backs on the one for strict bytestrings. 634 | instance NoThunks BS.Lazy.ByteString where 635 | showTypeOf _ = "Lazy.ByteString" 636 | wNoThunks ctxt bs = 637 | case bs of 638 | BS.Lazy.Internal.Empty -> return Nothing 639 | BS.Lazy.Internal.Chunk chunk bs' -> allNoThunks [ 640 | noThunks ctxt chunk 641 | , noThunks ctxt bs' 642 | ] 643 | 644 | #endif 645 | 646 | {------------------------------------------------------------------------------- 647 | Instances for text types 648 | 649 | For consistency, we follow the same pattern as for @ByteString@. 650 | -------------------------------------------------------------------------------} 651 | 652 | #ifdef MIN_VERSION_text 653 | 654 | deriving via OnlyCheckWhnfNamed "Strict.Text" Text.Strict.Text 655 | instance NoThunks Text.Strict.Text 656 | 657 | instance NoThunks Text.Lazy.Text where 658 | showTypeOf _ = "Lazy.Text" 659 | wNoThunks ctxt bs = 660 | case bs of 661 | Text.Lazy.Internal.Empty -> return Nothing 662 | Text.Lazy.Internal.Chunk chunk bs' -> allNoThunks [ 663 | noThunks ctxt chunk 664 | , noThunks ctxt bs' 665 | ] 666 | 667 | #endif 668 | 669 | {------------------------------------------------------------------------------- 670 | Tuples 671 | -------------------------------------------------------------------------------} 672 | 673 | instance ( NoThunks a 674 | , NoThunks b 675 | ) => NoThunks (a, b) 676 | 677 | instance ( NoThunks a 678 | , NoThunks b 679 | , NoThunks c 680 | ) => NoThunks (a, b, c) 681 | 682 | instance ( NoThunks a 683 | , NoThunks b 684 | , NoThunks c 685 | , NoThunks d 686 | ) => NoThunks (a, b, c, d) 687 | 688 | instance ( NoThunks a 689 | , NoThunks b 690 | , NoThunks c 691 | , NoThunks d 692 | , NoThunks e 693 | ) => NoThunks (a, b, c, d, e) 694 | 695 | instance ( NoThunks a 696 | , NoThunks b 697 | , NoThunks c 698 | , NoThunks d 699 | , NoThunks e 700 | , NoThunks f 701 | ) => NoThunks (a, b, c, d, e, f) 702 | 703 | instance ( NoThunks a 704 | , NoThunks b 705 | , NoThunks c 706 | , NoThunks d 707 | , NoThunks e 708 | , NoThunks f 709 | , NoThunks g 710 | ) => NoThunks (a, b, c, d, e, f, g) 711 | 712 | {------------------------------------------------------------------------------- 713 | Base types (other than tuples) 714 | -------------------------------------------------------------------------------} 715 | 716 | instance NoThunks Void 717 | instance NoThunks () 718 | 719 | instance NoThunks a => NoThunks [a] 720 | instance NoThunks a => NoThunks (Identity a) 721 | instance NoThunks a => NoThunks (Maybe a) 722 | instance NoThunks a => NoThunks (NonEmpty a) 723 | 724 | instance (NoThunks a, NoThunks b) => NoThunks (Either a b) 725 | 726 | deriving via InspectHeap ThreadId instance NoThunks ThreadId 727 | 728 | {------------------------------------------------------------------------------- 729 | Spine-strict container types 730 | 731 | Such types can /only/ contain thunks in the values, so that's all we check. 732 | Note that containers using keys are typically strict in those keys, but that 733 | forces them to WHNF only, not NF; in /most/ cases the @Ord@ instance on those 734 | keys will force them to NF, but not /always/ (for example, when using lists 735 | as keys); this means we must check keys for thunks to be sure. 736 | -------------------------------------------------------------------------------} 737 | 738 | instance (NoThunks k, NoThunks v) => NoThunks (Map k v) where 739 | showTypeOf _ = "Map" 740 | wNoThunks ctxt = noThunksInKeysAndValues ctxt . Map.toList 741 | 742 | instance NoThunks a => NoThunks (Set a) where 743 | showTypeOf _ = "Set" 744 | wNoThunks ctxt = noThunksInValues ctxt . Set.toList 745 | 746 | instance NoThunks a => NoThunks (IntMap a) where 747 | showTypeOf _ = "IntMap" 748 | wNoThunks ctxt = noThunksInValues ctxt . IntMap.toList 749 | 750 | {------------------------------------------------------------------------------- 751 | Vector 752 | -------------------------------------------------------------------------------} 753 | 754 | #ifdef MIN_VERSION_vector 755 | 756 | instance NoThunks a => NoThunks (Vector.Boxed.Vector a) where 757 | showTypeOf _ = "Boxed.Vector" 758 | wNoThunks ctxt = noThunksInValues ctxt . Vector.Boxed.toList 759 | 760 | -- | Unboxed vectors can't contain thunks 761 | -- 762 | -- Implementation note: defined manually rather than using 'OnlyCheckWhnf' 763 | -- due to ghc limitation in deriving via, making it impossible to use with it 764 | -- with data families. 765 | instance NoThunks (Vector.Unboxed.Vector a) where 766 | showTypeOf _ = "Unboxed.Vector" 767 | wNoThunks _ _ = return Nothing 768 | 769 | #endif 770 | 771 | {------------------------------------------------------------------------------- 772 | Function types 773 | -------------------------------------------------------------------------------} 774 | 775 | -- | We do NOT check function closures for captured thunks by default 776 | -- 777 | -- Since we have no type information about the values captured in a thunk, the 778 | -- only check we could possibly do is 'checkContainsThunks': we can't 779 | -- recursively call 'noThunks' on those captured values, which is problematic if 780 | -- any of those captured values /requires/ a custom instance (for example, data 781 | -- types that depend on laziness, such as 'Seq'). 782 | -- 783 | -- By default we therefore /only/ check if the function is in WHNF, and don't 784 | -- check the captured values at all. If you want a stronger check, you can 785 | -- use @'InspectHeap' (a -> b)@ instead. 786 | deriving via OnlyCheckWhnfNamed "->" (a -> b) instance NoThunks (a -> b) 787 | 788 | -- | We do not check IO actions for captured thunks by default 789 | -- 790 | -- See instance for @(a -> b)@ for detailed discussion. 791 | deriving via OnlyCheckWhnfNamed "IO" (IO a) instance NoThunks (IO a) 792 | 793 | {------------------------------------------------------------------------------- 794 | Special cases 795 | -------------------------------------------------------------------------------} 796 | 797 | -- | Since CallStacks can't retain application data, we don't want to check 798 | -- them for thunks /at all/ 799 | deriving via AllowThunk CallStack instance NoThunks CallStack 800 | 801 | -- | Instance for 'Seq' checks elements only 802 | -- 803 | -- The internal fingertree in 'Seq' might have thunks, which is essential for 804 | -- its asymptotic complexity. 805 | instance NoThunks a => NoThunks (Seq a) where 806 | showTypeOf _ = "Seq" 807 | wNoThunks ctxt = noThunksInValues ctxt . toList 808 | 809 | instance NoThunks a => NoThunks (Ratio a) where 810 | showTypeOf _ = "Ratio" 811 | wNoThunks ctxt r = noThunksInValues ctxt [n, d] 812 | where 813 | -- The 'Ratio' constructor is not exported: we only have two accessor 814 | -- functions. However, @numerator r@ is obviously trivially a trunk 815 | -- (due to the unevaluated call to @numerator@). By forcing the values of 816 | -- @n@ and @d@ where we get rid of these function calls, leaving only the 817 | -- values inside the @Ratio@. Note that @Ratio@ is strict in both of these 818 | -- fields, so forcing them to WHNF won't change them. 819 | !n = numerator r 820 | !d = denominator r 821 | 822 | {------------------------------------------------------------------------------- 823 | Type level symbol comparison logic 824 | -------------------------------------------------------------------------------} 825 | 826 | type family Same s t where 827 | Same s t = IsSame (CmpSymbol s t) 828 | 829 | type family IsSame (o :: Ordering) where 830 | IsSame 'EQ = 'True 831 | IsSame _x = 'False 832 | 833 | type family Or (a :: Bool) (b :: Bool) where 834 | Or 'False 'False = 'False 835 | Or _a _b = 'True 836 | 837 | type family Elem (s :: Symbol) (xs :: [Symbol]) where 838 | Elem s (x ': xs) = Or (Same s x) (Elem s xs) 839 | Elem _s '[] = 'False 840 | 841 | {------------------------------------------------------------------------------- 842 | Check that all mentioned record fields are known fields 843 | -------------------------------------------------------------------------------} 844 | 845 | -- | Check that type @a@ has all record fields listed in @s@ 846 | -- 847 | -- This exists to catch mismatches between the arguments to `AllowThunksIn` and 848 | -- the fields of a record. If any of the symbols is not the name of a field then 849 | -- this constraint won't be satisfied. 850 | class HasFields (s :: [Symbol]) (a :: Type) 851 | instance HasFields '[] a 852 | instance (HasField x a t, HasFields xs a) => HasFields (x ': xs) a 853 | 854 | {------------------------------------------------------------------------------- 855 | Internal: low level magic 856 | -------------------------------------------------------------------------------} 857 | 858 | -- | Is the argument a (top-level thunk)? 859 | checkIsThunk :: a -> IO Bool 860 | checkIsThunk x = closureIsThunk <$> getBoxedClosureData (asBox x) 861 | 862 | -- | Is the argument a thunk, or does it (recursively) contain any? 863 | checkContainsThunks :: a -> IO Bool 864 | checkContainsThunks x = go (asBox x) 865 | where 866 | go :: Box -> IO Bool 867 | go b = do 868 | c <- getBoxedClosureData b 869 | if closureIsThunk c then 870 | return True 871 | else do 872 | c' <- getBoxedClosureData b 873 | anyM go (allClosures c') 874 | 875 | -- | Check if the given 'Closure' is a thunk. 876 | -- 877 | -- Indirections are not considered to be thunks. 878 | closureIsThunk :: Closure -> Bool 879 | closureIsThunk ThunkClosure{} = True 880 | closureIsThunk APClosure{} = True 881 | closureIsThunk SelectorClosure{} = True 882 | closureIsThunk BCOClosure{} = True 883 | closureIsThunk _ = False 884 | 885 | anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool 886 | anyM _ [] = return False 887 | anyM p (x : xs) = do 888 | q <- p x 889 | if q then return True 890 | else anyM p xs 891 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | 5 | import qualified Test.NoThunks.Class 6 | 7 | tests :: TestTree 8 | tests = testGroup "Tests" [ 9 | Test.NoThunks.Class.tests 10 | ] 11 | 12 | main :: IO () 13 | main = defaultMain tests 14 | -------------------------------------------------------------------------------- /test/Test/NoThunks/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE DerivingVia #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE MagicHash #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE UnboxedTuples #-} 17 | 18 | -- | Tests for 'NoThunks.Class' 19 | -- 20 | -- These tests are tricky, since we want to have precisely control over where 21 | -- there are and aren't thunks, without letting ghc ruin things (normally of 22 | -- course ghc should be free to change a lot of that behaviour). 23 | -- 24 | -- We avoid bang patterns as well as the use of '($!)', to make sure that these 25 | -- tests pass with @-O0@. 26 | module Test.NoThunks.Class (tests) where 27 | 28 | import Control.Monad.IO.Class 29 | import Data.Kind 30 | import Data.Maybe (isNothing) 31 | import Data.Proxy 32 | import Data.Sequence (Seq) 33 | import Data.Typeable 34 | import GHC.Generics (Generic) 35 | import GHC.Types 36 | import System.Random 37 | import Test.Tasty 38 | import Test.Tasty.Hedgehog 39 | 40 | import qualified Data.Sequence as Seq 41 | import qualified Data.Sequence.Internal as Seq.Internal 42 | 43 | import qualified Control.Concurrent.MVar as MVar 44 | import qualified Control.Concurrent.STM as STM 45 | import qualified Control.Concurrent.STM.TVar as TVar 46 | import qualified Data.IORef as IORef 47 | 48 | import Hedgehog 49 | import Hedgehog.Internal.Report (Result (..), reportStatus) 50 | import Hedgehog.Internal.Region (displayRegion) 51 | import Hedgehog.Internal.Runner (checkNamed) 52 | import Hedgehog.Internal.Config (UseColor (..)) 53 | 54 | import qualified Hedgehog.Gen as Gen 55 | import qualified Hedgehog.Range as Range 56 | 57 | import NoThunks.Class 58 | 59 | {------------------------------------------------------------------------------- 60 | Top-level 61 | -------------------------------------------------------------------------------} 62 | 63 | tests :: TestTree 64 | tests = testGroup "NoThunks.Class" [ 65 | testGroup "Sanity" [ 66 | testProperty "IntNotNF" sanityCheckIntNotNF 67 | , testProperty "IntIsNF" sanityCheckIntIsNF 68 | , testProperty "Pair" sanityCheckPair 69 | , testProperty "Sum" sanityCheckSum 70 | , testProperty "Fn" sanityCheckFn 71 | , testProperty "IO" sanityCheckIO 72 | ] 73 | , testGroup "InspectHeap" [ 74 | testProperty "Int" $ testWithModel agreeOnNF $ Proxy @(InspectHeap Int) 75 | , testProperty "IntInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Int, Int)) 76 | , testProperty "SumInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Either Int Int)) 77 | , testProperty "ListInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap [Int]) 78 | , testProperty "IntListInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Int, [Int])) 79 | , testProperty "SeqInt" $ expectFailure $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Seq Int)) 80 | ] 81 | , testGroup "Model" [ 82 | testProperty "Int" $ testWithModel agreeOnContext $ Proxy @Int 83 | , testProperty "IntInt" $ testWithModel agreeOnContext $ Proxy @(Int, Int) 84 | , testProperty "SumInt" $ testWithModel agreeOnContext $ Proxy @(Either Int Int) 85 | , testProperty "ListInt" $ testWithModel agreeOnContext $ Proxy @[Int] 86 | , testProperty "IntListInt" $ testWithModel agreeOnContext $ Proxy @(Int, [Int]) 87 | , testProperty "SeqInt" $ testWithModel agreeOnContext $ Proxy @(Seq Int) 88 | , testProperty "AllowThunksIn" $ testWithModel agreeOnContext $ Proxy @(AllowThunksIn '["field1"] Record) 89 | , testProperty "Fn" $ testWithModel agreeOnContext $ Proxy @(Int -> Int) 90 | , testProperty "IO" $ testWithModel agreeOnContext $ Proxy @(IO ()) 91 | , testProperty "ThunkFreeFn" $ testWithModel agreeOnContext $ Proxy @(ThunkFree "->" (Int -> Int)) 92 | , testProperty "ThunkFreeIO" $ testWithModel agreeOnContext $ Proxy @(ThunkFree "IO" (IO ())) 93 | ] 94 | , testGroup "MutableVars" [ 95 | checkRef (Proxy :: Proxy IORef.IORef) 96 | , checkRef (Proxy :: Proxy MVar.MVar) 97 | , checkRef (Proxy :: Proxy TVar.TVar) 98 | ] 99 | ] 100 | 101 | -- | When using @InspectHeap@ we don't get a context, so merely check if 102 | -- both the model and the implementation agree whether or not the value is 103 | -- in NF 104 | agreeOnNF :: Maybe ThunkInfo -> Maybe [String] -> Bool 105 | agreeOnNF mThunk mCtxt = isNothing mThunk == isNothing mCtxt 106 | 107 | -- | Check whether the model and the implementation agree on whether the value 108 | -- is in NF, and if not, what the context of the thunk is. 109 | agreeOnContext :: Maybe ThunkInfo -> Maybe [String] -> Bool 110 | agreeOnContext mThunk mCtxt = (thunkContext <$> mThunk) == mCtxt 111 | 112 | {------------------------------------------------------------------------------- 113 | Infrastructure 114 | -------------------------------------------------------------------------------} 115 | 116 | -- | The model for a value describes that value, being explicit where we 117 | -- can expect thunks in the value. 118 | class (NoThunks a, Show (Model a)) => FromModel a where 119 | data Model a :: Type 120 | 121 | -- | Generate model value (see below for examples) 122 | genModel :: Gen (Model a) 123 | 124 | -- | Does the model describe a value in NF? 125 | modelIsNF :: [String] -> Model a -> IsNormalForm [String] 126 | 127 | -- | Context as it should be returned by 'noThunks' 128 | -- 129 | -- This has a default implementation in terms of 'modelIsNF': there are 130 | -- unexpected thunks iff the model is not fully in NF. 131 | modelUnexpected :: [String] -> Model a -> Maybe [String] 132 | modelUnexpected ctxt m = 133 | case modelIsNF ctxt m of 134 | IsNF -> Nothing 135 | IsWHNF c -> Just c 136 | NotWHNF c -> Just c 137 | 138 | -- | Translate from the model to an actual value 139 | -- 140 | -- The @a@ thunk should contain no unevaluated calls to 'fromModel'. 141 | fromModel :: forall r. Model a -> (a -> r) -> r 142 | 143 | -- | Is a value in normal form? 144 | data IsNormalForm a = 145 | IsNF -- ^ Value completely in normal form 146 | | IsWHNF a -- ^ Value is in WHNF, but not NF. Record information about thunk. 147 | | NotWHNF a -- ^ Value is not in WHNF. Record information about thunk. 148 | deriving (Show, Functor) 149 | 150 | -- | 'IsNormalForm' for a constructor applied to arguments 151 | -- 152 | -- A constructor applied to arguments is always in WHNF; it is in NF iff all 153 | -- arguments are. 154 | constrNF :: forall a. [IsNormalForm a] -> IsNormalForm a 155 | constrNF args = 156 | case firstNotNF args of 157 | Nothing -> IsNF 158 | Just a -> IsWHNF a 159 | where 160 | firstNotNF :: [IsNormalForm a] -> Maybe a 161 | firstNotNF [] = Nothing 162 | firstNotNF (NotWHNF a : _ ) = Just a 163 | firstNotNF (IsWHNF a : _ ) = Just a 164 | firstNotNF (IsNF : args') = firstNotNF args' 165 | 166 | testWithModel :: forall a. FromModel a 167 | => (Maybe ThunkInfo -> Maybe [String] -> Bool) 168 | -> Proxy a 169 | -- ^ Compare @ThunkInfo@. When we use 'noThunks' this 170 | -- can just be @(==)@; however, when we use 'isNormalForm', the 171 | -- context we will get from the model will be too detailed. 172 | -> Property 173 | testWithModel compareInfo _proxy = withTests 1000 $ property $ do 174 | m :: Model a <- forAll genModel 175 | collect $ modelUnexpected [] m 176 | fromModel m $ \a -> do 177 | annotate $ show $ modelIsNF [] m 178 | isNF <- liftIO $ noThunks [] a 179 | Hedgehog.diff isNF compareInfo (modelUnexpected [] m) 180 | 181 | {------------------------------------------------------------------------------- 182 | Int 183 | -------------------------------------------------------------------------------} 184 | 185 | instance FromModel Int where 186 | data Model Int = 187 | IntThunk (Model Int) 188 | | IntValue Int 189 | deriving (Show) 190 | 191 | -- for integers there is no difference between NF/WHNF 192 | modelIsNF ctxt = \case 193 | IntThunk _ -> NotWHNF ctxt' 194 | IntValue _ -> IsNF 195 | where 196 | ctxt' = "Int" : ctxt 197 | 198 | fromModel (IntThunk i) k = fromModel i $ \i' -> k (if ack 3 3 > 0 then i' else i') 199 | fromModel (IntValue n) k = case n of I# result -> k (I# result) 200 | 201 | genModel = Gen.choice [ 202 | IntValue <$> Gen.int Range.linearBounded 203 | , IntThunk <$> genModel 204 | ] 205 | 206 | {------------------------------------------------------------------------------- 207 | Pairs 208 | -------------------------------------------------------------------------------} 209 | 210 | instance (FromModel a, FromModel b) => FromModel (a, b) where 211 | data Model (a, b) = 212 | PairThunk (Model (a, b)) 213 | | PairDefined (Model a) (Model b) 214 | 215 | modelIsNF ctxt = \case 216 | PairThunk _ -> NotWHNF ctxt' 217 | PairDefined a b -> constrNF [modelIsNF ctxt' a, modelIsNF ctxt' b] 218 | where 219 | #if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) 220 | ctxt' = "Tuple2" : ctxt 221 | #else 222 | ctxt' = "(,)" : ctxt 223 | #endif 224 | 225 | fromModel (PairThunk p) k = fromModel p $ \p' -> k (if ack 3 3 > 0 then p' else p') 226 | fromModel (PairDefined a b) k = fromModel a $ \a' -> 227 | fromModel b $ \b' -> 228 | k (a', b') 229 | 230 | genModel = Gen.choice [ 231 | PairDefined <$> genModel <*> genModel 232 | , PairThunk <$> genModel 233 | ] 234 | 235 | deriving instance (Show (Model a), Show (Model b)) => Show (Model (a, b)) 236 | 237 | {------------------------------------------------------------------------------- 238 | Sums 239 | -------------------------------------------------------------------------------} 240 | 241 | instance (FromModel a, FromModel b) => FromModel (Either a b) where 242 | data Model (Either a b) = 243 | SumThunk (Model (Either a b)) 244 | | LeftDefined (Model a) 245 | | RightDefined (Model b) 246 | 247 | modelIsNF ctxt = \case 248 | SumThunk _ -> NotWHNF ctxt' 249 | LeftDefined a -> constrNF [modelIsNF ctxt' a] 250 | RightDefined b -> constrNF [modelIsNF ctxt' b] 251 | where 252 | ctxt' = "Either" : ctxt 253 | 254 | fromModel (SumThunk p) k = fromModel p $ \p' -> k (if ack 3 3 > 0 then p' else p') 255 | fromModel (LeftDefined a) k = fromModel a $ \a' -> k (Left a') 256 | fromModel (RightDefined b) k = fromModel b $ \b' -> k (Right b') 257 | 258 | genModel = Gen.choice [ 259 | LeftDefined <$> genModel 260 | , RightDefined <$> genModel 261 | , SumThunk <$> genModel 262 | ] 263 | 264 | deriving instance (Show (Model a), Show (Model b)) => Show (Model (Either a b)) 265 | 266 | {------------------------------------------------------------------------------- 267 | Lists 268 | -------------------------------------------------------------------------------} 269 | 270 | instance FromModel a => FromModel [a] where 271 | data Model [a] = 272 | ListThunk (Model [a]) 273 | | ListNil 274 | | ListCons (Model a) (Model [a]) 275 | 276 | modelIsNF ctxt = \case 277 | ListThunk _ -> NotWHNF ctxt' 278 | ListNil -> IsNF 279 | ListCons x xs' -> constrNF [modelIsNF ctxt' x, modelIsNF ctxt xs'] 280 | where 281 | #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) 282 | ctxt' = "List" : ctxt 283 | #else 284 | ctxt' = "[]" : ctxt 285 | #endif 286 | 287 | fromModel (ListThunk xs) k = fromModel xs $ \xs' -> k (if ack 3 3 > 0 then xs' else xs') 288 | fromModel ListNil k = k [] 289 | fromModel (ListCons x xs) k = fromModel x $ \x' -> 290 | fromModel xs $ \xs' -> 291 | k (x' : xs') 292 | 293 | genModel = do 294 | sz <- Gen.int $ Range.linear 0 10 295 | go sz 296 | where 297 | go :: Int -> Gen (Model [a]) 298 | go 0 = pure ListNil 299 | go n = Gen.choice [ 300 | ListCons <$> genModel <*> go (n - 1) 301 | , ListThunk <$> go (n - 1) 302 | ] 303 | 304 | deriving instance Show (Model a) => Show (Model [a]) 305 | 306 | {------------------------------------------------------------------------------- 307 | Seq 308 | -------------------------------------------------------------------------------} 309 | 310 | instance FromModel (Seq Int) where 311 | data Model (Seq Int) = SeqEmpty | SeqEnqueue (Model Int) (Model (Seq Int)) 312 | deriving (Show) 313 | 314 | modelIsNF ctxt = \case 315 | SeqEmpty -> IsNF 316 | SeqEnqueue x xs -> constrNF [modelIsNF ctxt' x, modelIsNF ctxt xs] 317 | where 318 | ctxt' = "Seq" : ctxt 319 | 320 | fromModel m = \k -> go m $ \s -> forceSeqToWhnf s k 321 | where 322 | go :: Model (Seq Int) -> (Seq Int -> r) -> r 323 | go SeqEmpty k = k Seq.empty 324 | go (SeqEnqueue x xs) k = 325 | fromModel x $ \x' -> 326 | go xs $ \xs' -> 327 | k (x' Seq.<| xs') 328 | 329 | genModel = do 330 | sz <- Gen.int $ Range.linear 0 100 331 | -- It is important that we have a good probability of generating sequences 332 | -- that the model considers to be in normal form: for such sequences the 333 | -- model and the 'isNormalForm' check (but not the 'noThunks' 334 | -- check) can diverge, because the internal @FingerTree@ may not be 335 | -- fully evaluated. 336 | Gen.choice [ 337 | go (pure $ IntValue 0) sz 338 | , go genModel sz 339 | ] 340 | where 341 | go :: Gen (Model Int) -> Int -> Gen (Model (Seq Int)) 342 | go _ 0 = return SeqEmpty 343 | go genInt n = SeqEnqueue <$> genInt <*> go genInt (n - 1) 344 | 345 | forceSeqToWhnf :: Seq a -> (Seq a -> r) -> r 346 | forceSeqToWhnf xs k = 347 | case xs of 348 | Seq.Internal.Seq Seq.Internal.EmptyT -> 349 | k (Seq.Internal.Seq Seq.Internal.EmptyT) 350 | Seq.Internal.Seq (Seq.Internal.Single a) -> 351 | k (Seq.Internal.Seq (Seq.Internal.Single a)) 352 | Seq.Internal.Seq (Seq.Internal.Deep n l ft r) -> 353 | k (Seq.Internal.Seq (Seq.Internal.Deep n l ft r)) 354 | 355 | {------------------------------------------------------------------------------- 356 | AllowThunksIn 357 | -------------------------------------------------------------------------------} 358 | 359 | data Record = Record { 360 | field1 :: [Int] 361 | , field2 :: Int 362 | } 363 | deriving (Generic, Show) 364 | 365 | instance FromModel (AllowThunksIn '["field1"] Record) where 366 | data Model (AllowThunksIn '["field1"] Record) = 367 | RecordThunk (Model (AllowThunksIn '["field1"] Record)) 368 | | RecordDefined (Model [Int]) (Model Int) 369 | 370 | modelIsNF ctxt = \case 371 | RecordThunk _ -> NotWHNF ctxt' 372 | RecordDefined a b -> constrNF [modelIsNF ("field1" : ctxt') a, modelIsNF ("field2" : ctxt') b] 373 | where 374 | ctxt' = "Record" : ctxt 375 | 376 | modelUnexpected ctxt = \case 377 | RecordThunk _ -> Just ctxt' 378 | RecordDefined _ y -> modelUnexpected ("field2" : ctxt') y 379 | where 380 | ctxt' = "Record" : ctxt 381 | 382 | fromModel (RecordThunk r) k = fromModel r $ \r' -> k (if ack 3 3 > 0 then r' else r') 383 | fromModel (RecordDefined a b) k = 384 | fromModel a $ \a' -> 385 | fromModel b $ \b' -> 386 | k (AllowThunksIn (Record a' b')) 387 | 388 | genModel = Gen.choice [ 389 | RecordDefined <$> genModel <*> genModel 390 | , RecordThunk <$> genModel 391 | ] 392 | 393 | deriving instance Show (Model (AllowThunksIn '["field1"] Record)) 394 | 395 | {------------------------------------------------------------------------------- 396 | Special case: function closures 397 | 398 | Since we don't traverse the function closure, we should only check if 399 | the function itself is in WHNF or not. 400 | 401 | We have to be careful here exactly how we phrase this test to avoid the GHC 402 | optimizer being too smart, turning what we think ought to be thunks into 403 | top-level CAFs. 404 | -------------------------------------------------------------------------------} 405 | 406 | -- | Function which is not strict in either 'Int' argument 407 | {-# NOINLINE notStrict #-} 408 | notStrict :: Bool -> Int -> Int -> Int 409 | notStrict False x _ = x 410 | notStrict True _ y = y 411 | 412 | definitelyInNF :: Int -> Int 413 | definitelyInNF n = n 414 | 415 | instance FromModel (Int -> Int) where 416 | data Model (Int -> Int) = 417 | FnInNF -- Function in NF 418 | | FnNotInNF Bool Int -- Function in WHNF but not in NF 419 | | FnNotInWHNF (Model (Int -> Int)) -- Function not in WHNF 420 | | FnToWHNF (Model (Int -> Int)) -- Force function to WHNF 421 | deriving (Show) 422 | 423 | fromModel FnInNF k = k definitelyInNF 424 | fromModel (FnNotInNF b n) k = k (\x -> notStrict b (ack 5 n) x) -- Lambda is in WHNF 425 | fromModel (FnNotInWHNF f) k = fromModel f $ \f' -> k (if ack 3 3 > 0 then f' else f') 426 | fromModel (FnToWHNF f) k = fromModel f $ \f' -> f' `seq` k f' 427 | 428 | -- By default we don't distinguish between NF and WHNF for functions 429 | modelUnexpected ctxt m = 430 | case modelIsNF ctxt m of 431 | IsNF -> Nothing 432 | IsWHNF _ -> Nothing 433 | NotWHNF c -> Just c 434 | 435 | modelIsNF ctxt = \case 436 | FnInNF -> IsNF 437 | FnNotInNF _ _ -> IsWHNF ctxt' 438 | FnNotInWHNF _ -> NotWHNF ctxt' 439 | FnToWHNF f -> 440 | case f of 441 | -- Forcing a function already in NF leaves it in NF 442 | FnInNF -> IsNF 443 | 444 | -- Forcing a function which is already in WHNF (but not in NF) 445 | -- leaves it in WHNF 446 | FnNotInNF _ _ -> IsWHNF ctxt' 447 | 448 | -- Forcing a computation reveals what's underneath it. 449 | -- We leave the 'FnToWHNF' constructor at the top because 450 | -- It doens't matter quite how many computations are underneath, 451 | -- a single force forces them all. 452 | FnNotInWHNF f' -> modelIsNF ctxt (FnToWHNF f') 453 | 454 | -- Forcing twice is the same as forcing once 455 | FnToWHNF f' -> modelIsNF ctxt (FnToWHNF f') 456 | where 457 | ctxt' = ("->" : ctxt) 458 | 459 | genModel = Gen.choice [ 460 | pure FnInNF 461 | , FnNotInNF <$> Gen.bool <*> Gen.int Range.linearBounded 462 | , FnNotInWHNF <$> genModel 463 | , FnToWHNF <$> genModel 464 | ] 465 | 466 | {------------------------------------------------------------------------------- 467 | Special case: IO 468 | 469 | Similar kind of thing as for function closures. Here we have to be even more 470 | careful in our choice of examples to get something that works both with @-O0@ 471 | and @-O1@. 472 | -------------------------------------------------------------------------------} 473 | 474 | -- IO action which is definitely in NF 475 | doNothing :: IO () 476 | doNothing = IO (\w -> (# w, () #) ) 477 | 478 | instance FromModel (IO ()) where 479 | -- We reuse the model we use for functions, we do the same 4 types 480 | newtype Model (IO ()) = ModelIO (Model (Int -> Int)) 481 | deriving Show 482 | 483 | fromModel (ModelIO m) = go m 484 | where 485 | go :: Model (Int -> Int) -> (IO () -> r) -> r 486 | go FnInNF k = k doNothing 487 | go (FnNotInNF b n) k = k (IO (\w -> let x = notStrict b (ack 5 n) 6 488 | in x `seq` (# w, () #) )) 489 | go (FnNotInWHNF f) k = go f $ \f' -> k (if ack 3 3 > 0 then f' else f') 490 | go (FnToWHNF f) k = go f $ \f' -> f' `seq` k f' 491 | 492 | modelUnexpected ctxt (ModelIO f) = fnToIOContext <$> modelUnexpected ctxt f 493 | modelIsNF ctxt (ModelIO f) = fnToIOContext <$> modelIsNF ctxt f 494 | genModel = ModelIO <$> genModel 495 | 496 | fnToIOContext :: [String] -> [String] 497 | fnToIOContext ("->" : ctxt) = "IO" : ctxt 498 | fnToIOContext ("..." : "->" : ctxt) = "..." : "IO" : ctxt 499 | fnToIOContext ctxt = ctxt 500 | 501 | {------------------------------------------------------------------------------- 502 | Check that we /can/ check functions and IO actions for nested thunks 503 | -------------------------------------------------------------------------------} 504 | 505 | newtype ThunkFree (name :: Symbol) a = ThunkFree a 506 | deriving NoThunks via InspectHeapNamed name a 507 | 508 | instance FromModel (ThunkFree "->" (Int -> Int)) where 509 | newtype Model (ThunkFree "->" (Int -> Int)) = ThunkFreeFn (Model (Int -> Int)) 510 | deriving (Show) 511 | 512 | genModel = ThunkFreeFn <$> genModel 513 | fromModel (ThunkFreeFn f) k = fromModel f $ \f' -> k (ThunkFree f') 514 | modelIsNF ctxt (ThunkFreeFn f) = modelIsNF ctxt f 515 | 516 | modelUnexpected ctxt m = 517 | case modelIsNF ctxt m of 518 | IsNF -> Nothing 519 | IsWHNF _ -> Just ["...", "->"] 520 | NotWHNF _ -> Just ["->"] 521 | 522 | instance FromModel (ThunkFree "IO" (IO ())) where 523 | newtype Model (ThunkFree "IO" (IO ())) = ThunkFreeIO (Model (Int -> Int)) 524 | deriving (Show) 525 | 526 | genModel = 527 | ThunkFreeIO <$> genModel 528 | fromModel (ThunkFreeIO m) k = 529 | fromModel (ModelIO m) $ \f -> k (ThunkFree f) 530 | modelIsNF ctxt (ThunkFreeIO f) = 531 | fnToIOContext <$> modelIsNF ctxt (ThunkFreeFn f) 532 | modelUnexpected ctxt (ThunkFreeIO f) = 533 | fnToIOContext <$> modelUnexpected ctxt (ThunkFreeFn f) 534 | 535 | {------------------------------------------------------------------------------- 536 | Using the standard 'isNormalForm' check 537 | -------------------------------------------------------------------------------} 538 | 539 | instance (FromModel a, Typeable a) => FromModel (InspectHeap a) where 540 | newtype Model (InspectHeap a) = Wrap { unwrap :: Model a } 541 | 542 | genModel = Wrap <$> genModel 543 | modelUnexpected ctxt = modelUnexpected ctxt . unwrap 544 | modelIsNF ctxt = modelIsNF ctxt . unwrap 545 | fromModel m k = fromModel (unwrap m) $ \x -> k (InspectHeap x) 546 | 547 | deriving instance Show (Model a) => Show (Model (InspectHeap a)) 548 | 549 | {------------------------------------------------------------------------------- 550 | Some sanity checks 551 | 552 | These are primarily designed to check that we can distinguish between 553 | functions with nested thunks and functions without. 554 | -------------------------------------------------------------------------------} 555 | 556 | {-# NOINLINE checkNF #-} 557 | checkNF :: Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property 558 | checkNF expectedNF k = withTests 1 $ property $ k $ \a -> do 559 | nf <- liftIO $ noThunks [] (InspectHeapNamed @"a" a) 560 | isNothing nf === expectedNF 561 | 562 | {-# NOINLINE sanityCheckIntNotNF #-} 563 | sanityCheckIntNotNF :: Property 564 | sanityCheckIntNotNF = checkNF False (\k -> k (if ack 3 3 > 0 then x else x)) 565 | where 566 | x :: Int 567 | x = 0 568 | 569 | {-# NOINLINE sanityCheckIntIsNF #-} 570 | sanityCheckIntIsNF :: Property 571 | sanityCheckIntIsNF = x `seq` checkNF True (\k -> k x) 572 | where 573 | x :: Int 574 | x = I# 0# 575 | 576 | {-# NOINLINE sanityCheckPair #-} 577 | sanityCheckPair :: Property 578 | sanityCheckPair = checkNF False (\k -> k (if ack 3 3 > 0 then x else x)) 579 | where 580 | x :: (Int, Bool) 581 | x = (0, True) 582 | 583 | {-# NOINLINE sanityCheckSum #-} 584 | sanityCheckSum :: Property 585 | sanityCheckSum = checkNF False (\k -> k (if ack 3 3 > 0 then x else x)) 586 | where 587 | x :: Either Int Int 588 | x = Right 0 589 | 590 | {-# NOINLINE sanityCheckFn #-} 591 | sanityCheckFn :: Property 592 | sanityCheckFn = checkNF False $ \k -> do 593 | b <- liftIO $ randomRIO (False, True) 594 | n <- liftIO $ ack 5 <$> randomRIO (0, 10) 595 | k (notStrict b n :: Int -> Int) 596 | 597 | {-# NOINLINE sanityCheckIO #-} 598 | sanityCheckIO :: Property 599 | sanityCheckIO = checkNF False $ \k -> do 600 | b <- liftIO $ randomRIO (False, True) 601 | n <- liftIO $ ack 5 <$> randomRIO (0, 10) 602 | k (print (notStrict b n 6) :: IO ()) 603 | 604 | {------------------------------------------------------------------------------- 605 | Mutable Vars 606 | -------------------------------------------------------------------------------} 607 | 608 | checkRef :: forall ref. (IsRef ref, NoThunks (ref Int)) => Proxy ref -> TestTree 609 | checkRef p = testGroup (show (typeRep p)) [ 610 | testProperty "NotNF" checkRefNotNF 611 | , testProperty "NF" checkRefNF 612 | , testProperty "NotNFPure" checkRefNotNFPure 613 | , testProperty "NFPure" checkRefNFPure 614 | , testProperty "NotNFAtomically" checkRefNotNFAtomically 615 | , testProperty "NFAtomically" checkRefNFAtomically 616 | ] 617 | where 618 | checkRefNotNF :: Property 619 | checkRefNotNF = checkNFClass False $ \k -> do 620 | ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int)) 621 | k ref 622 | where 623 | x :: Int 624 | x = 0 625 | 626 | checkRefNF :: Property 627 | checkRefNF = checkNFClass True $ \k -> do 628 | !ref <- liftIO (newRef x :: IO (ref Int)) 629 | k ref 630 | where 631 | x :: Int 632 | !x = 0 633 | 634 | checkRefNotNFPure :: Property 635 | checkRefNotNFPure = unsafeCheckNF False $ \k -> do 636 | ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int)) 637 | k ref 638 | where 639 | x :: Int 640 | x = 0 641 | 642 | checkRefNFPure :: Property 643 | checkRefNFPure = unsafeCheckNF True $ \k -> do 644 | !ref <- liftIO (newRef x :: IO (ref Int)) 645 | k ref 646 | where 647 | x :: Int 648 | !x = 0 649 | 650 | checkRefNotNFAtomically :: Property 651 | checkRefNotNFAtomically = unsafeCheckNFAtomically False $ \k -> do 652 | ref <- liftIO (newRef (if ack 3 3 > 0 then x else x) :: IO (ref Int)) 653 | k ref 654 | where 655 | x :: Int 656 | x = 0 657 | 658 | checkRefNFAtomically :: Property 659 | checkRefNFAtomically = unsafeCheckNFAtomically True $ \k -> do 660 | !ref <- liftIO (newRef x :: IO (ref Int)) 661 | k ref 662 | where 663 | x :: Int 664 | !x = 0 665 | 666 | class Typeable ref => IsRef ref where newRef :: a -> IO (ref a) 667 | 668 | instance IsRef IORef.IORef where newRef = IORef.newIORef 669 | instance IsRef MVar.MVar where newRef = MVar.newMVar 670 | instance IsRef TVar.TVar where newRef = TVar.newTVarIO 671 | 672 | checkNFClass :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property 673 | checkNFClass expectedNF k = withTests 1 $ property $ k $ \x -> do 674 | nf <- liftIO $ noThunks [] x 675 | isNothing nf === expectedNF 676 | 677 | {-# NOINLINE unsafeCheckNF #-} 678 | unsafeCheckNF :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property 679 | unsafeCheckNF expectedNF k = withTests 1 $ property $ k $ \x -> do 680 | let nf = unsafeNoThunks x 681 | isNothing nf === expectedNF 682 | 683 | {-# NOINLINE unsafeCheckNFAtomically #-} 684 | unsafeCheckNFAtomically :: NoThunks a => Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property 685 | unsafeCheckNFAtomically expectedNF k = withTests 1 $ property $ k $ \x -> do 686 | tvar <- liftIO (TVar.newTVarIO True) 687 | true <- liftIO $ STM.atomically $ do 688 | val <- TVar.readTVar tvar 689 | -- the $! is essential to trigger NestedAtomically exception. 690 | return $! val && isNothing (unsafeNoThunks x) 691 | true === expectedNF 692 | 693 | {------------------------------------------------------------------------------- 694 | Hedgehog auxiliary 695 | -------------------------------------------------------------------------------} 696 | 697 | expectFailure :: Property -> Property 698 | expectFailure p = withTests 1 $ property $ do 699 | report <- liftIO $ displayRegion $ \r -> 700 | checkNamed r EnableColor (Just "EXPECTED FAILURE") Nothing p 701 | case reportStatus report of 702 | Failed _ -> 703 | success 704 | _otherwise -> do 705 | footnote "The test passed, but we expected it to fail." 706 | failure 707 | 708 | {------------------------------------------------------------------------------- 709 | Auxiliary 710 | -------------------------------------------------------------------------------} 711 | 712 | -- | Ackermann (anything that ghc won't just optimize away..) 713 | ack :: Int -> Int -> Int 714 | ack 0 n = succ n 715 | ack m 0 = ack (pred m) 1 716 | ack m n = ack (pred m) (ack m (pred n)) 717 | --------------------------------------------------------------------------------