add IP update for PatBinds

.gitignore

@@ -1 +1,2 @@
 dist-newstyle
+tags

graph-trace-dot/src/Graph/Trace/Dot.hs

@@ -34,7 +34,11 @@ data Key = Key { keyId :: !Word
   deriving (Eq, Ord, Show)
 
 data LogEntry
-  = Entry Key (Maybe Key) (Maybe SrcCodeLoc) (Maybe SrcCodeLoc)
+  = Entry
+      Key
+      (Maybe Key)
+      (Maybe SrcCodeLoc) -- definition site
+      (Maybe SrcCodeLoc) -- call site
   | Trace Key BS.ByteString (Maybe SrcCodeLoc)
   deriving Show
 
@@ -109,7 +113,11 @@ data NodeEntry
   deriving Show
 
 -- Remembers the order in which the elements were inserted
-type Graph = M.Map Key (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
+type Graph =
+  M.Map Key ( Min Int -- order
+            , [NodeEntry] -- contents
+            , Alt Maybe SrcCodeLoc -- definition site
+            )
 
 buildGraph :: [LogEntry] -> Graph
 buildGraph = foldl' build mempty where
@@ -205,9 +213,9 @@ graphToDot graph = header <> graphContent <> "}"
                   case mEdge of
                     Nothing -> " HREF=\"\""
                     Just _ -> " HREF=\"#" <> keyStrEsc edgeKey <> "\""
-                edgeToolTip =
+                elToolTip =
                   foldMap (("called at " <>) . pprSrcCodeLoc) mCallSite
-                el = "<TR><TD TOOLTIP=\"" <> edgeToolTip
+                el = "<TR><TD TOOLTIP=\"" <> elToolTip
                   <> "\" ALIGN=\"LEFT\" CELLPADDING=\"1\" BGCOLOR=\""
                   <> color <> "\" PORT=\"" <> BSB.wordDec idx <> "\""
                   <> href

graph-trace/src/Graph/Trace.hs

@@ -138,6 +138,8 @@ modifyBinds nameMap entryName =
     (modifyBinding nameMap entryName)
 
 -- | Instrument value bindings that have a signature with a debug pred.
+-- This gets applied to both top level bindings as well as arbitrarily nested
+-- value bindings.
 modifyValBinds
   :: DebugNames
   -> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
@@ -295,6 +297,8 @@ modifyBinding nameMap entryName
           alts
 
       pure bnd{Ghc.fun_matches = mg{ Ghc.mg_alts = newAlts }}
+-- modifyBinding nameMap entryName
+--   bnd@Ghc.PatBind{} = DT.trace "PAT BIND" pure bnd
 modifyBinding _ _ bnd = pure bnd
 
 mkWhereBindName :: Ghc.TcM Ghc.Name
@@ -435,6 +439,11 @@ updateDebugIpInFunBind whereVarName
 #if !(MIN_VERSION_ghc(9,0,0))
     updateMatch x = x
 #endif
+updateDebugIpInFunBind whereVarName
+    b@Ghc.PatBind{ Ghc.pat_rhs = g@Ghc.GRHSs{ Ghc.grhssGRHSs = grhss } }
+  = b { Ghc.pat_rhs =
+          g{ Ghc.grhssGRHSs = fmap (updateDebugIPInGRHS whereVarName) <$> grhss }
+      }
 updateDebugIpInFunBind _ b = b
 
 -- | Produce the contents of the where binding that contains the new debug IP

graph-trace/src/Graph/Trace/Internal/GhcFacade.hs

@@ -214,7 +214,7 @@ pattern HsQualTy' x lctx body
 
 pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc
 #if MIN_VERSION_ghc(9,0,0)
-pattern RealSrcLoc' loc = RealSrcLoc loc Nothing
+pattern RealSrcLoc' loc <- RealSrcLoc loc _
 #else
 pattern RealSrcLoc' loc = RealSrcLoc loc
 #endif