auto-scroll to first node

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

@@ -173,7 +173,8 @@ graphToDot graph = header <> graphContent <> "}"
         nodeColor = case mEdgeColor of
                       Nothing -> ""
                       Just c -> "BGCOLOR=\"" <> c <> "\" "
-        labelCell = "<TR><TD HREF=\"\" TOOLTIP=\"" <> foldMap pprSrcCodeLoc mSrcLoc
+        nodeToolTip = foldMap (("defined at " <>) . pprSrcCodeLoc) mSrcLoc
+        labelCell = "<TR><TD HREF=\"\" TOOLTIP=\"" <> nodeToolTip
                  <> "\" " <> nodeColor <> "><B>"
                  <> BSB.byteString (htmlEscape $ keyName key) <> "</B></TD></TR>\n"
         tableStart = quoted (keyStr key) <> " [label=<\n<TABLE BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\" CELLPADDING=\"4\">"
@@ -182,7 +183,9 @@ graphToDot graph = header <> graphContent <> "}"
 
         doEntry (cs, es, colors'@(color:nextColors), colorMap) ev = case ev of
           (Message str mCallSite, idx) ->
-            let el = "<TR><TD HREF=\"\" TOOLTIP=\"" <> foldMap pprSrcCodeLoc mCallSite
+            let msgToolTip =
+                  foldMap (("printed at " <>) . pprSrcCodeLoc) mCallSite
+                el = "<TR><TD HREF=\"\" TOOLTIP=\"" <> msgToolTip
                   <> "\" ALIGN=\"LEFT\" PORT=\""
                   <> BSB.wordDec idx <> "\">"
                   <> BSB.byteString str <> "</TD></TR>"
@@ -192,7 +195,9 @@ graphToDot graph = header <> graphContent <> "}"
                   case mEdge of
                     Nothing -> " HREF=\"\""
                     Just _ -> " HREF=\"#" <> keyStr edgeKey { keyName = htmlEscape $ keyName edgeKey } <> "\""
-                el = "<TR><TD TOOLTIP=\"" <> foldMap pprSrcCodeLoc mCallSite
+                edgeToolTip =
+                  foldMap (("called at " <>) . pprSrcCodeLoc) mCallSite
+                el = "<TR><TD TOOLTIP=\"" <> edgeToolTip
                   <> "\" ALIGN=\"LEFT\" CELLPADDING=\"1\" BGCOLOR=\""
                   <> color <> "\" PORT=\"" <> BSB.wordDec idx <> "\""
                   <> href

graph-trace-viz/extras/header.html

@@ -6,6 +6,13 @@
 
 const nodeCoords = {};
 
+function scrollToPosition (x, y) {
+  window.scrollTo (
+    x - window.innerWidth / 2,
+    y - window.innerHeight / 2
+  );
+};
+
 window.onload = function () {
   const svgEl = document.getElementsByTagName("svg")[0].children[0];
 
@@ -28,15 +35,20 @@ window.onload = function () {
     const pos = nodeCoords[decodeURI(nodeName)];
     if (pos) {
       event.preventDefault();
-      window.scrollTo
-        ( pos.x - window.innerWidth / 2,
-          pos.y - window.innerHeight / 2 );
+      scrollToPosition(pos.x, pos.y);
     } else {
       console.log('Node not found: ' + nodeName);
     }
   };
 
   window.addEventListener('hashchange', scrollToNode, false);
+
+  // Scroll to first node
+  const firstNodePos = nodeCoords[Object.keys(nodeCoords)[0]];
+  if (firstNodePos) {
+    scrollToPosition(firstNodePos.x, firstNodePos.y);
+  }
+
   console.log("Finished loading");
 };
 

graph-trace/src/Graph/Trace.hs

@@ -228,6 +228,8 @@ addConstraintToSigType debugNames debugAllFlag names sig@(Ghc.HsSig' t) = do
             | foundPred : _ <-
                 mapMaybe (checkForDebugPred debugNames)
                   (Ghc.unLoc <$> foldMap Ghc.unLoc ctx)
+            -- Note that DebugMuted bindings should still be included because
+            -- the muted status needs to be inherited by the functions called from it
             -> do tell (M.fromList $ names `zip` repeat foundPred)
                   pure q
             | otherwise -> do