From b6094ff6c79882309aa1c0c6c9389f2a6d6492fe Mon Sep 17 00:00:00 2001
From: Aaron Allen <aaron@flipstone.com>
Date: Wed, 8 Dec 2021 21:35:04 -0600
Subject: [PATCH] add IP update for PatBinds

---
 .gitignore                                       |  1 +
 graph-trace-dot/src/Graph/Trace/Dot.hs           | 16 ++++++++++++----
 graph-trace/src/Graph/Trace.hs                   |  9 +++++++++
 .../src/Graph/Trace/Internal/GhcFacade.hs        |  2 +-
 4 files changed, 23 insertions(+), 5 deletions(-)

diff --git a/.gitignore b/.gitignore
index 48a004c..649dd71 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1 +1,2 @@
 dist-newstyle
+tags
diff --git a/graph-trace-dot/src/Graph/Trace/Dot.hs b/graph-trace-dot/src/Graph/Trace/Dot.hs
index 2e0b66f..2ee3f70 100644
--- a/graph-trace-dot/src/Graph/Trace/Dot.hs
+++ b/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
diff --git a/graph-trace/src/Graph/Trace.hs b/graph-trace/src/Graph/Trace.hs
index 1ec3798..32ae817 100644
--- a/graph-trace/src/Graph/Trace.hs
+++ b/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
diff --git a/graph-trace/src/Graph/Trace/Internal/GhcFacade.hs b/graph-trace/src/Graph/Trace/Internal/GhcFacade.hs
index a566e37..67c559a 100644
--- a/graph-trace/src/Graph/Trace/Internal/GhcFacade.hs
+++ b/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