Merge pull request #54 from edsko/edsko/info-and-context

Report _both_ context _and_ info

CHANGELOG.md

@@ -1,5 +1,9 @@
 # Revision history for nothunks
 
+## 0.3.0 -- not yet released
+
+* Include _both_ `Context` _and_ `Info` in `ThunkInfo` (#54)
+
 ## 0.2.1.0 -- 2024-02-06
 
 * Exported `mkThunkInfo`.

src/NoThunks/Class.hs

@@ -133,7 +133,7 @@ class NoThunks a where
   -- 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)
@@ -227,23 +227,26 @@ type Info = String
 -- > ["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 }
+data ThunkInfo = ThunkInfo {
+      thunkContext :: Context
+    , thunkInfo    :: Maybe Info
+    }
   deriving Show
 
 -- | Construct `ThunkInfo` either from `Context` or information provided by
 -- `GHC` about `a` (see `whereFrom`).
 --
 mkThunkInfo :: Context -> a -> IO ThunkInfo
 #if MIN_VERSION_base(4,16,0)
-mkThunkInfo ctxt a = ThunkInfo . maybe (Left ctxt) (Right . fmt) <$> whereFrom a
+mkThunkInfo ctxt a = ThunkInfo ctxt . fmap fmt <$> whereFrom a
   where
     fmt :: InfoProv -> Info
     fmt InfoProv { ipSrcFile, ipSrcSpan,
                               ipLabel, ipTyDesc } =
            ipLabel ++ " :: " ++ ipTyDesc
         ++ " @ " ++ ipSrcFile ++ ":" ++ ipSrcSpan
 #else
-mkThunkInfo ctxt _ = return (ThunkInfo (Left ctxt))
+mkThunkInfo ctxt _ = return (ThunkInfo ctxt Nothing)
 #endif
 
 
@@ -527,18 +530,18 @@ deriving via a instance NoThunks a => NoThunks (Semigroup.Dual a)
 deriving via Bool instance NoThunks Semigroup.All
 deriving via Bool instance NoThunks Semigroup.Any
 deriving via a instance NoThunks a => NoThunks (Semigroup.Sum a)
-deriving via a instance NoThunks a => NoThunks (Semigroup.Product a) 
-deriving via a instance NoThunks a => NoThunks (Semigroup.WrappedMonoid a) 
-instance (NoThunks a, NoThunks b) => NoThunks (Semigroup.Arg a b) 
+deriving via a instance NoThunks a => NoThunks (Semigroup.Product a)
+deriving via a instance NoThunks a => NoThunks (Semigroup.WrappedMonoid a)
+instance (NoThunks a, NoThunks b) => NoThunks (Semigroup.Arg a b)
 
 {-------------------------------------------------------------------------------
   Monoids
 -------------------------------------------------------------------------------}
 
-deriving via (Maybe a) instance NoThunks a => NoThunks (Monoid.First a) 
-deriving via (Maybe a) instance NoThunks a => NoThunks (Monoid.Last a) 
-deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Alt f a) 
-deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Ap f a) 
+deriving via (Maybe a) instance NoThunks a => NoThunks (Monoid.First a)
+deriving via (Maybe a) instance NoThunks a => NoThunks (Monoid.Last a)
+deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Alt f a)
+deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Ap f a)
 
 {-------------------------------------------------------------------------------
   Solo

test/Test/NoThunks/Class.hs

@@ -107,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 = (thunkInfo <$> mThunk) == (Left <$> mCtxt)
+agreeOnContext mThunk mCtxt = (thunkContext <$> mThunk) == mCtxt
 
 {-------------------------------------------------------------------------------
   Infrastructure