Expand Terms as they the user expands them

The defaultDepth to which we expand Ids is low because otherwise the
performance cost is too great and perceivably slow.

However, the user has to iteractively expand the branches of the
representation tree of variables as they want to view them.

We can leverage this interactivity to overcome the limited depth to
which we expand. Simply: when the user expands a variable, always expand
its corresponding Term a little bit more.

Fixes #97

Author: alt-romes

haskell-debugger/GHC/Debugger/Runtime.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, LambdaCase, NamedFieldPuns #-}
+{-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns #-}
 module GHC.Debugger.Runtime where
 
 import Data.IORef
@@ -9,6 +9,7 @@ import GHC
 import GHC.Types.FieldLabel
 import GHC.Tc.Utils.TcType
 import GHC.Runtime.Eval
+import GHC.Runtime.Heap.Inspect
 
 import GHC.Debugger.Runtime.Term.Key
 import GHC.Debugger.Runtime.Term.Cache
@@ -21,8 +22,9 @@ import GHC.Debugger.Monad
 -- scratch and stored in the cache.
 obtainTerm :: TermKey -> Debugger Term
 obtainTerm key = do
-  tc_ref <- asks termCache
-  tc     <- liftIO $ readIORef tc_ref
+  hsc_env <- getSession
+  tc_ref  <- asks termCache
+  tc      <- liftIO $ readIORef tc_ref
   case lookupTermCache key tc of
     -- cache miss: reconstruct, then store.
     Nothing ->
@@ -37,17 +39,8 @@ obtainTerm key = do
         getTerm = \case
           FromId i -> GHC.obtainTermFromId (depth i) False{-don't force-} i
           FromPath k pf -> do
-            term <- getTerm k >>= \case
-              -- When the key points to a Suspension, the real thing should
-              -- already be forced. It's just that the shallow depth meant we
-              -- returned a Suspension nonetheless while recursing in `getTerm`.
-              t@Suspension{} -> do
-                t' <- seqTerm t
-                -- update term cache with intermediate values?
-                -- insertTermCache k t'
-                return t'
-              t -> return t
-            return $ case term of
+            term <- getTerm k
+            liftIO $ expandTerm hsc_env $ case term of
               Term{dc=Right dc, subTerms} -> case pf of
                 PositionalIndex ix -> subTerms !! (ix-1)
                 LabeledField fl    ->
@@ -59,12 +52,25 @@ obtainTerm key = do
               _ -> error "Unexpected term for the given TermKey"
        in do
         term <- getTerm key
-        liftIO $ writeIORef tc_ref (insertTermCache key term tc)
+        liftIO $ modifyIORef tc_ref (insertTermCache key term)
         return term
 
     -- cache hit
     Just hit -> return hit
 
+-- | Before returning a 'Term' we want to expand its heap representation up to the 'defaultDepth'
+--
+-- For 'Id's, this is done by 'GHC.obtainTermFromId'. For other 'TermKey's this
+-- function should be used
+expandTerm :: HscEnv -> Term -> IO Term
+expandTerm hsc_env term = case term of
+  Term{val, ty} -> cvObtainTerm hsc_env defaultDepth False ty val
+  (NewtypeWrap{}; RefWrap{}) -> do
+    -- TODO: we don't do anything clever here yet
+    return term
+  -- For other terms there's no point in trying to expand
+  (Suspension{}; Prim{}) -> return term
+
 -- | A boring type is one for which we don't care about the structure and would
 -- rather see "whole" when being inspected. Strings and literals are a good
 -- example, because it's more useful to see the string value than it is to see

haskell-debugger/GHC/Debugger/Stopped/Variables.hs

@@ -43,6 +43,9 @@ tyThingToVarInfo t = case t of
     termToVarInfo key term
 
 -- | Construct the VarInfos of the fields ('VarFields') of the given 'TermKey'/'Term'
+--
+-- This is used to come up with terms for the fields of an already `seq`ed
+-- variable which was expanded.
 termVarFields :: TermKey -> Term -> Debugger VarFields
 termVarFields top_key top_term =
 

test/integration-tests/data/T97/Main.hs

@@ -0,0 +1,13 @@
+module Main where
+
+data T97 a = T97 a
+  deriving Show
+
+
+main = do
+  let y :: T97 (T97 (T97 (T97 (T97 (T97 String)))))
+      y = T97 (T97 (T97 (T97 (T97 (T97 "hello")))))
+
+  print y
+  print y
+

test/integration-tests/flake.lock

@@ -2,7 +2,7 @@
   description = "Integration tests for hdb";
 
   inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable"; # or unstable
+    nixpkgs.url = "github:NixOS/nixpkgs/nixos-25.05"; # or unstable
     flake-utils.url = "github:numtide/flake-utils";
   };
 

test/integration-tests/flake.nix

@@ -435,8 +435,7 @@ describe("Debug Adapter Tests", function () {
             }
 
             // Finally, we should be at the OK constructor
-            const focusF = await forceLazy(focus);
-            assert.strictEqual(focusF.value, 'OK');
+            assert.strictEqual(focus.value, 'OK');
         })
 
         it('strings that are fields of the expanded vars and are not thunks are fully evaluated (issue #11)', async () => {
@@ -453,15 +452,14 @@ describe("Debug Adapter Tests", function () {
             await dc.hitBreakpoint(config, { path: config.entryFile, line: 5 }, expected, expected)
 
             // Force only the 2nd "hello" and check the third is already there.
-            // It relies on repeat seemingly only re-using every other thunk?!!?
             // (Mimics reproducer in #11)
             let locals = await fetchLocalVars();
             const xVar = await forceLazy(locals.get('x'));
             const xChild = await expandVar(xVar);
             const _2Var = await xChild.get('_2'); // NOTE: Doesn't need to be forced because of this seemingly weird `repeat` behavior where it looks like every other binding is shared but the others are not
             const _2Child = await expandVar(_2Var);
             const _2_1Var = await forceLazy(_2Child.get('_1'));
-            const _2_2Var = await forceLazy(_2Child.get('_2'));
+            const _2_2Var = await _2Child.get('_2');
             const _2_2Child = await expandVar(_2_2Var);
             const _2_2_1Var = await _2_2Child.get('_1') // NOTE: doesn't need to be forced as above
             assertIsString(_2_2_1Var, '"hello"');
@@ -533,6 +531,40 @@ describe("Debug Adapter Tests", function () {
             const myintCon = await moduleVars.get("MyIntCon")
             assert.strictEqual(myintCon.value, "Data constructor ‘MyIntCon’")
         })
+
+        it('expand iteratively s.t. forced structure appears as forced (issue #97)', async () => {
+            let config = mkConfig({
+                  projectRoot: "/data/T97",
+                  entryFile: "Main.hs",
+                  entryPoint: "main",
+                  entryArgs: [],
+                  extraGhcArgs: []
+                })
+
+            const expected = { path: config.projectRoot + "/" + config.entryFile, line: 12 }
+
+            await dc.hitBreakpoint(config, { path: config.entryFile, line: 12 }, expected, expected)
+
+            let locals = await fetchLocalVars();
+            const xVar = await locals.get('y');
+            // NOTE: This tests that we don't have to force a single variable
+            // as we expand because the data should be fully forced at this
+            // point.
+            const xChild = await expandVar(xVar);
+            const _1Var = await xChild.get('_1');
+            const _1Child = await expandVar(_1Var);
+            const _1_1Var = await _1Child.get('_1');
+            assert.strictEqual(_1_1Var.value, 'T97'); // just check
+            const _1_1Child = await expandVar(_1_1Var);
+            const _1_1_1Var = await _1_1Child.get('_1');
+            const _1_1_1Child = await expandVar(_1_1_1Var);
+            const _1_1_1_1Var = await _1_1_1Child.get('_1');
+            const _1_1_1_1Child = await expandVar(_1_1_1_1Var);
+            const _1_1_1_1_1Var = await _1_1_1_1Child.get('_1');
+            const _1_1_1_1_1Child = await expandVar(_1_1_1_1_1Var);
+            const _1_1_1_1_1_1Var = await _1_1_1_1_1Child.get('_1');
+            assertIsString(_1_1_1_1_1_1Var, '"hello"');
+        })
     })
     describe("Stepping out (step-out)", function () {