Merge pull request #46 from input-output-hk/coot/info-tables

Use info tables to get context

CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## next version
 
+* 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).
 * `NoThunks` instance for `Data.Tuple.Solo`.
 * `NoThunks` instances for `Data.Semigroup` and `Data.Monoid` newtype wrappers.
 

README.md

@@ -12,3 +12,11 @@ See my presentation
 [MuniHac 2020: Being lazy without being bloated](https://www.youtube.com/watch?v=7t6wt7ByBWg)
 for an overview, motivating the library and explaining how it is intended to be
 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
+feature in `GHC-9.2` (although an earlier version of `whereFrom`
+is available in `base`).

nothunks.cabal

@@ -41,7 +41,7 @@ library
     exposed-modules:  NoThunks.Class
 
     build-depends:    base       >= 4.12 && < 5
-                    , containers >= 0.5  && < 0.7
+                    , containers >= 0.5  && < 0.8
                     , stm        >= 2.5  && < 2.6
                     , time       >= 1.5  && < 1.13
 

src/NoThunks/Class.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE KindSignatures        #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE StandaloneDeriving    #-}
 {-# LANGUAGE TypeApplications      #-}
@@ -69,6 +70,10 @@ import GHC.Stack
 import Numeric.Natural
 #endif
 
+#if MIN_VERSION_base(4,18,0)
+import GHC.InfoProv
+#endif
+
 import qualified Control.Concurrent.MVar       as MVar
 import qualified Control.Concurrent.STM.TVar   as TVar
 import qualified Data.IntMap                   as IntMap
@@ -132,12 +137,11 @@ class NoThunks a where
   noThunks :: Context -> a -> IO (Maybe ThunkInfo)
   noThunks ctxt x = do
       isThunk <- checkIsThunk x
+      c <- getThunkContext (showTypeOf (Proxy @a)) x
+      let ctxt' = c : ctxt
       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.
   --
@@ -213,10 +217,28 @@ newtype ThunkInfo = ThunkInfo {
       -- > ["Int","List","(,)"]     an Int in the [Int] in the pair
       --
       -- Note: prior to `ghc-9.6` a list was indicated by `[]`.
-      thunkContext :: Context
+      --
+      -- 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
+
+infoProvContext :: InfoProv -> String
+infoProvContext InfoProv { ipSrcFile, ipSrcSpan,
+                           ipLabel, ipTyDesc } =
+       ipLabel ++ " :: " ++ ipTyDesc
+    ++ " @ " ++ ipSrcFile ++ ":" ++ ipSrcSpan
+#else
+getThunkContext c _ = return c
+#endif
+
+
 {-# NOINLINE unsafeNoThunks #-}
 -- | Call 'noThunks' in a pure context (relies on 'unsafePerformIO').
 unsafeNoThunks :: NoThunks a => a -> Maybe ThunkInfo
@@ -362,8 +384,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
     return $ if containsThunks
-               then Just $ ThunkInfo { thunkContext = "..." : ctxt }
+               then Just $ ThunkInfo { thunkContext = c : ctxt }
                else Nothing
 
 {-------------------------------------------------------------------------------
@@ -513,14 +536,14 @@ deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Ap f a)
   Solo
 -------------------------------------------------------------------------------}
 
-#if MIN_VERSION_base(4,16,0)
+#if MIN_VERSION_base(4,18,0)
+-- GHC-9.6 and newer
+instance NoThunks a => NoThunks (Solo a) where
+    wNoThunks ctx (MkSolo a) = wNoThunks ("Solo" : ctx) a
+#elif MIN_VERSION_base(4,16,0)
 -- GHC-9.2
 instance NoThunks a => NoThunks (Solo a) where
     wNoThunks ctx (Solo a) = wNoThunks ("Solo" : ctx) a
-#elif MIN_VERSION_base(4,17,0)
--- GHC-9.4 and newer
-instance NoThunks a => NoThunks (Solo a) where
-    wNoThunks ctx (MkSolo a) = wNoThunks ("Solo" : ctx) a
 #endif
 
 {-------------------------------------------------------------------------------