Report _both_ context _and_ info

In some cases having both makes debugging a bit easier.
input-output-hk · Aug 8, 2024 · 0d937c2 · 0d937c2
1 parent 13293ce
commit 0d937c2
Show file tree

Hide file tree

Showing 2 changed files with 12 additions and 11 deletions.
diff --git a/src/NoThunks/Class.hs b/src/NoThunks/Class.hs
@@ -9,6 +9,7 @@
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
@@ -133,7 +134,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,15 +228,15 @@ 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 }
+newtype ThunkInfo = ThunkInfo { thunkInfo  :: (Context, 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,
@@ -527,18 +528,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
@@ -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 = (fst. thunkInfo <$> mThunk) == mCtxt
 
 {-------------------------------------------------------------------------------
   Infrastructure