From 85e0d22f3eadf7a893e61949abaf8d863507d19e Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 8 Aug 2024 10:15:50 +0200
Subject: [PATCH] Report _both_ context _and_ info

In some cases having both makes debugging a bit easier.
---
 CHANGELOG.md                |  4 ++++
 src/NoThunks/Class.hs       | 25 ++++++++++++++-----------
 test/Test/NoThunks/Class.hs |  2 +-
 3 files changed, 19 insertions(+), 12 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index b540d30..fda0ccf 100644
--- a/CHANGELOG.md
+++ b/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`.
diff --git a/src/NoThunks/Class.hs b/src/NoThunks/Class.hs
index 75038a6..7189d63 100644
--- a/src/NoThunks/Class.hs
+++ b/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,7 +227,10 @@ 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
@@ -235,7 +238,7 @@ newtype ThunkInfo = ThunkInfo { thunkInfo  :: Either Context Info }
 --
 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,
@@ -243,7 +246,7 @@ mkThunkInfo ctxt a = ThunkInfo . maybe (Left ctxt) (Right . fmt) <$> whereFrom a
            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
diff --git a/test/Test/NoThunks/Class.hs b/test/Test/NoThunks/Class.hs
index bd98468..7956089 100644
--- a/test/Test/NoThunks/Class.hs
+++ b/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