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 = "
edgeToolTip
+ el = " |
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
|