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