Publish nothunks-0.2.0 on Hackage

CHANGELOG.md

@@ -1,10 +1,11 @@
 # Revision history for nothunks
 
-## next version
+## 0.2.0 -- 2024-01-27
 
 * Use `whereFrom` to get source information, which is avialable when the source
   is compiled with `GHC-9.2` (or newer) and with `-finfo-table-map` (and even
   more accurate when `-fdistinct-constructor-table` is passed).
+  For that reason the `ThunkInfo` type has changed.
 * `NoThunks` instance for `Data.Tuple.Solo`.
 * `NoThunks` instances for `Data.Semigroup` and `Data.Monoid` newtype wrappers.
 

README.md

@@ -17,6 +17,6 @@ used and how it works internally.
 `nothunks` will try to get source information from info tables. For that one
 needs to use `GHC` newer than `9.4` and compile the code with
 `-finfo-table-map`.  More precise information will be available if
-`-fdistinct-constructor-table` flag is used as well.  We don't support this
+`-fdistinct-constructor-tables` flag is used as well.  We don't support this
 feature in `GHC-9.2` (although an earlier version of `whereFrom`
 is available in `base`).

nothunks.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               nothunks
-version:            0.1.5
+version:            0.2.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

src/NoThunks/Class.hs

@@ -20,6 +20,7 @@ module NoThunks.Class (
     NoThunks(..)
   , ThunkInfo(..)
   , Context
+  , Info
   , unsafeNoThunks
     -- * Helpers for defining instances
   , allNoThunks
@@ -129,18 +130,19 @@ class NoThunks a where
   -- reports the /unexpected/ thunks.
   --
   -- The default implementation of 'noThunks' checks that the argument is in
-  -- WHNF, and if so, adds the type into the context (using 'showTypeOf'), and
-  -- calls 'wNoThunks'. See 'ThunkInfo' for a detailed discussion of the type
-  -- context.
+  -- WHNF, and if so, adds the type into the context (using 'showTypeOf' or
+  -- 'whereFrom' if available), and calls 'wNoThunks'. See 'ThunkInfo' for
+  -- a detailed discussion of the type context.
+  -- 
   --
   -- See also discussion of caveats listed for 'checkContainsThunks'.
   noThunks :: Context -> a -> IO (Maybe ThunkInfo)
   noThunks ctxt x = do
       isThunk <- checkIsThunk x
-      c <- getThunkContext (showTypeOf (Proxy @a)) x
-      let ctxt' = c : ctxt
+      let ctxt' = showTypeOf (Proxy @a) : ctxt
+      thunkInfo <- getThunkInfo ctxt' x
       if isThunk
-        then return $ Just ThunkInfo { thunkContext = ctxt' }
+        then return $ Just thunkInfo
         else wNoThunks ctxt' x
 
   -- | Check that the argument is in normal form, assuming it is in WHNF.
@@ -194,48 +196,51 @@ class NoThunks a where
 -- @Int@ which was a thunk.
 type Context = [String]
 
+-- | Binding name, type and location information about the thunk, e.g.
+--
+-- > fromModel :: Int @ test/Test/NoThunks/Class.hs:198:53-84
+--
+type Info = String
+
 {-------------------------------------------------------------------------------
   Results of the check
 -------------------------------------------------------------------------------}
 
 -- | Information about unexpected thunks
 --
--- TODO: The ghc-debug work by Matthew Pickering includes some work that allows
--- to get source spans from closures. If we could take advantage of that, we
--- could not only show the type of the unexpected thunk, but also where it got
--- allocated.
-newtype ThunkInfo = ThunkInfo {
-      -- The @Context@ argument is intended to give a clue to add debugging.
-      -- For example, suppose we have something of type @(Int, [Int])@. The
-      -- various contexts we might get are
-      --
-      -- > Context                  The thunk is..
-      -- > ---------------------------------------------------------------------
-      -- > ["(,)"]                  the pair itself
-      -- > ["Int","(,)"]            the Int in the pair
-      -- > ["List","(,)"]           the [Int] in the pair
-      -- > ["Int","List","(,)"]     an Int in the [Int] in the pair
-      --
-      -- Note: prior to `ghc-9.6` a list was indicated by `[]`.
-      --
-      -- Note: if compiled with `-finfo-table-map` (and
-      -- `-fdistinct-constructor-tables`) the context will contains source
-      -- location if available from the RTS.
-      thunkContext  :: Context
-    }
-  deriving (Show)
-
-getThunkContext :: String -> a -> IO String
-#if MIN_VERSION_base(4,18,0)
-getThunkContext c a = maybe c infoProvContext <$> whereFrom a
+-- ThunkInfo contains either precise `Info` about the thunk location
+-- or `Context` to make it easier to debug space leaks.  `Info` is available if
+--
+-- * @GHC-9.4@ or newer is used,
+-- * the code is compiled with @-finfo-table-map@ and is improved if
+--   @-fdistinct-constructor-tables@ is used as well.
+--
+-- The @Context@ argument is intended to give a clue to add debugging.
+-- For example, suppose we have something of type @(Int, [Int])@. The
+-- various contexts we might get are
+--
+-- > Context                  The thunk is..
+-- > ---------------------------------------------------------------------
+-- > ["(,)"]                  the pair itself
+-- > ["Int","(,)"]            the Int in the pair
+-- > ["List","(,)"]           the [Int] in the pair
+-- > ["Int","List","(,)"]     an Int in the [Int] in the pair
+--
+-- Note: prior to `ghc-9.6` a list was indicated by `[]`.
+newtype ThunkInfo = ThunkInfo { thunkInfo  :: Either Context Info }
+  deriving Show
 
-infoProvContext :: InfoProv -> String
-infoProvContext InfoProv { ipSrcFile, ipSrcSpan,
-                           ipLabel, ipTyDesc } =
-       ipLabel ++ " :: " ++ ipTyDesc
-    ++ " @ " ++ ipSrcFile ++ ":" ++ ipSrcSpan
+getThunkInfo :: Context -> a -> IO ThunkInfo
+#if MIN_VERSION_base(4,18,0)
+getThunkInfo ctxt a = ThunkInfo . maybe (Left ctxt) (Right . fmt) <$> whereFrom a
+  where
+    fmt :: InfoProv -> Info
+    fmt InfoProv { ipSrcFile, ipSrcSpan,
+                              ipLabel, ipTyDesc } =
+           ipLabel ++ " :: " ++ ipTyDesc
+        ++ " @ " ++ ipSrcFile ++ ":" ++ ipSrcSpan
 #else
-getThunkContext c _ = return c
+getThunkInfo ctxt _ = return (ThunkInfo (Left ctxt))
 #endif
 
 
@@ -384,9 +389,9 @@ instance KnownSymbol name => NoThunks (InspectHeapNamed name a) where
 inspectHeap :: Context -> a -> IO (Maybe ThunkInfo)
 inspectHeap ctxt x = do
     containsThunks <- checkContainsThunks x
-    c <- getThunkContext "..." x
+    thunkInfo <- getThunkInfo ("..." : ctxt) x
     return $ if containsThunks
-               then Just $ ThunkInfo { thunkContext = c : ctxt }
+               then Just thunkInfo
                else Nothing
 
 {-------------------------------------------------------------------------------

test/Test/NoThunks/Class.hs

@@ -66,19 +66,22 @@ tests = testGroup "NoThunks.Class" [
           testProperty "IntNotNF" sanityCheckIntNotNF
         , testProperty "IntIsNF"  sanityCheckIntIsNF
         , testProperty "Pair"     sanityCheckPair
+        , testProperty "Sum"      sanityCheckSum
         , testProperty "Fn"       sanityCheckFn
         , testProperty "IO"       sanityCheckIO
         ]
     , testGroup "InspectHeap" [
           testProperty "Int"        $                 testWithModel agreeOnNF $ Proxy @(InspectHeap Int)
         , testProperty "IntInt"     $                 testWithModel agreeOnNF $ Proxy @(InspectHeap (Int, Int))
+        , testProperty "SumInt"     $                 testWithModel agreeOnNF $ Proxy @(InspectHeap (Either 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 "SumInt"        $ testWithModel agreeOnContext $ Proxy @(Either Int Int)
         , testProperty "ListInt"       $ testWithModel agreeOnContext $ Proxy @[Int]
         , testProperty "IntListInt"    $ testWithModel agreeOnContext $ Proxy @(Int, [Int])
         , testProperty "SeqInt"        $ testWithModel agreeOnContext $ Proxy @(Seq Int)
@@ -104,7 +107,7 @@ 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
+agreeOnContext mThunk mCtxt = (thunkInfo <$> mThunk) == (Left <$> mCtxt)
 
 {-------------------------------------------------------------------------------
   Infrastructure
@@ -231,6 +234,35 @@ instance (FromModel a, FromModel b) => FromModel (a, b) where
 
 deriving instance (Show (Model a), Show (Model b)) => Show (Model (a, b))
 
+{-------------------------------------------------------------------------------
+  Sums
+-------------------------------------------------------------------------------}
+
+instance (FromModel a, FromModel b) => FromModel (Either a b) where
+  data Model (Either a b) =
+      SumThunk (Model (Either a b))
+    | LeftDefined (Model a)
+    | RightDefined (Model b)
+
+  modelIsNF ctxt = \case
+      SumThunk _     -> NotWHNF ctxt'
+      LeftDefined  a -> constrNF [modelIsNF ctxt' a]
+      RightDefined b -> constrNF [modelIsNF ctxt' b]
+    where
+      ctxt' = "Either" : ctxt
+
+  fromModel (SumThunk p)     k = fromModel p $ \p' -> k (if ack 3 3 > 0 then p' else p')
+  fromModel (LeftDefined a)  k = fromModel a $ \a' -> k (Left a')
+  fromModel (RightDefined b) k = fromModel b $ \b' -> k (Right b')
+
+  genModel = Gen.choice [
+      LeftDefined <$> genModel
+    , RightDefined <$> genModel
+    , SumThunk <$> genModel
+    ]
+
+deriving instance (Show (Model a), Show (Model b)) => Show (Model (Either a b))
+
 {-------------------------------------------------------------------------------
   Lists
 -------------------------------------------------------------------------------}
@@ -523,8 +555,8 @@ deriving instance Show (Model a) => Show (Model (InspectHeap a))
 
 {-# 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)
+checkNF expectedNF k = withTests 1 $ property $ k $ \a -> do
+    nf <- liftIO $ noThunks [] (InspectHeapNamed @"a" a)
     isNothing nf === expectedNF
 
 {-# NOINLINE sanityCheckIntNotNF #-}
@@ -548,6 +580,13 @@ sanityCheckPair = checkNF False (\k -> k (if ack 3 3 > 0 then x else x))
     x :: (Int, Bool)
     x = (0, True)
 
+{-# NOINLINE sanityCheckSum #-}
+sanityCheckSum :: Property
+sanityCheckSum = checkNF False (\k -> k (if ack 3 3 > 0 then x else x))
+  where
+    x :: Either Int Int
+    x = Right 0
+
 {-# NOINLINE sanityCheckFn #-}
 sanityCheckFn :: Property
 sanityCheckFn = checkNF False $ \k -> do