diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs index c068dd4..e215be8 100644 --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -17,7 +17,6 @@ import GHC.Driver.Env import GHC.Driver.Ppr as GHC import GHC.Runtime.Debugger.Breakpoints as GHC import GHC.Utils.Outputable as GHC -import GHC.Utils.Trace import GHC.Debugger.Monad import GHC.Debugger.Session diff --git a/haskell-debugger/GHC/Debugger/Breakpoint/Map.hs b/haskell-debugger/GHC/Debugger/Breakpoint/Map.hs index 4ddbc7f..b9b8848 100644 --- a/haskell-debugger/GHC/Debugger/Breakpoint/Map.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint/Map.hs @@ -66,14 +66,14 @@ lookupModuleIBIs m (BreakpointMap bm) = keys :: BreakpointMap a -> [InternalBreakpointId] keys (BreakpointMap bm) = - [ InternalBreakpointId mod bix - | (mod, im) <- moduleEnvToList bm + [ InternalBreakpointId m bix + | (m, im) <- moduleEnvToList bm , bix <- IM.keys im ] toList :: BreakpointMap a -> [(InternalBreakpointId, a)] toList (BreakpointMap bm) = - [ (InternalBreakpointId mod bix, a) - | (mod, im) <- moduleEnvToList bm + [ (InternalBreakpointId m bix, a) + | (m, im) <- moduleEnvToList bm , (bix, a) <- IM.toList im ] diff --git a/haskell-debugger/GHC/Debugger/Evaluation.hs b/haskell-debugger/GHC/Debugger/Evaluation.hs index 68eb52e..15e17a8 100644 --- a/haskell-debugger/GHC/Debugger/Evaluation.hs +++ b/haskell-debugger/GHC/Debugger/Evaluation.hs @@ -23,7 +23,6 @@ import System.Directory import qualified Prettyprinter as Pretty import GHC -import GHC.Utils.Trace import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS) import GHC.Unit.Types import GHC.Data.FastString @@ -193,9 +192,10 @@ handleExecResult = \case ExecComplete {execResult} -> do case execResult of Left e -> return (EvalException (show e) "SomeException") - Right [] -> return (EvalCompleted "" "") -- Evaluation completed without binding any result. + Right [] -> return (EvalCompleted "" "" NoVariables) -- Evaluation completed without binding any result. Right (n:_ns) -> inspectName n >>= \case - Just VarInfo{varValue, varType} -> return (EvalCompleted varValue varType) + Just VarInfo{varValue, varType, varRef} -> do + return (EvalCompleted varValue varType varRef) Nothing -> liftIO $ fail "doEval failed" ExecBreak {breakNames = _, breakPointId = Nothing} -> -- Stopped at an exception diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs index 34c638c..2afdb79 100644 --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveGeneric, +{-# LANGUAGE LambdaCase, + DeriveGeneric, StandaloneDeriving, OverloadedStrings, DuplicateRecordFields, @@ -161,6 +162,14 @@ data VariableReference deriving (Show, Generic, Eq, Ord) +-- | From 'ScopeVariablesReference' to a 'VariableReference' that can be used in @"variable"@ requests +scopeToVarRef :: ScopeVariablesReference -> VariableReference +scopeToVarRef = \case + LocalVariablesScope -> LocalVariables + ModuleVariablesScope -> ModuleVariables + GlobalVariablesScope -> GlobalVariables + + instance Bounded VariableReference where minBound = NoVariables maxBound = SpecificVariable maxBound @@ -234,7 +243,13 @@ data BreakFound deriving (Show, Generic) data EvalResult - = EvalCompleted { resultVal :: String, resultType :: String } + = EvalCompleted { resultVal :: String + , resultType :: String + , resultStructureRef :: VariableReference + -- ^ A structured representation of the result of evaluating + -- the expression given as a "virtual" 'VariableReference' + -- that the user can expand as a normal variable. + } | EvalException { resultVal :: String, resultType :: String } | EvalStopped { breakId :: Maybe GHC.InternalBreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} } -- | Evaluation failed for some reason other than completed/completed-with-exception/stopped. diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 45ac056..bf144df 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -28,7 +28,6 @@ import qualified GHCi.BreakArray as BA import GHC.Driver.DynFlags as GHC import GHC.Unit.Module.ModSummary as GHC import GHC.Utils.Outputable as GHC -import GHC.Utils.Trace as GHC import GHC.Utils.Logger as GHC import GHC.Types.Unique.Supply as GHC import GHC.Runtime.Loader as GHC diff --git a/haskell-debugger/GHC/Debugger/Utils.hs b/haskell-debugger/GHC/Debugger/Utils.hs index d36304a..1cf331d 100644 --- a/haskell-debugger/GHC/Debugger/Utils.hs +++ b/haskell-debugger/GHC/Debugger/Utils.hs @@ -1,13 +1,18 @@ {-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase, DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns, TypeApplications, ScopedTypeVariables, BangPatterns #-} -module GHC.Debugger.Utils where +module GHC.Debugger.Utils + ( module GHC.Debugger.Utils + , module GHC.Utils.Outputable + , module GHC.Utils.Trace + ) where import GHC import GHC.Data.FastString -import GHC.Driver.DynFlags as GHC -import GHC.Driver.Ppr as GHC -import GHC.Utils.Outputable as GHC +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Utils.Outputable +import GHC.Utils.Trace import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages diff --git a/hdb/Development/Debug/Adapter/Evaluation.hs b/hdb/Development/Debug/Adapter/Evaluation.hs index f9b52d2..dc350ff 100644 --- a/hdb/Development/Debug/Adapter/Evaluation.hs +++ b/hdb/Development/Debug/Adapter/Evaluation.hs @@ -36,30 +36,35 @@ startExecution = do -- | Command for evaluation (includes evaluation-on-hover) commandEvaluate :: DebugAdaptor () commandEvaluate = do - EvaluateArguments {..} <- getArguments + EvaluateArguments {evaluateArgumentsFrameId=_todo, ..} <- getArguments + + let simpleEvalResp res ty = EvaluateResponse + { evaluateResponseResult = res + , evaluateResponseType = ty + , evaluateResponsePresentationHint = Nothing + , evaluateResponseVariablesReference = 0 + , evaluateResponseNamedVariables = Nothing + , evaluateResponseIndexedVariables = Nothing + , evaluateResponseMemoryReference = Nothing + } + DidEval er <- sendSync (DoEval (T.unpack evaluateArgumentsExpression)) case er of EvalStopped{} -> error "impossible, execution is resumed automatically for 'DoEval'" - EvalAbortedWith e -> do + EvalAbortedWith e -> -- Evaluation failed, we report it but don't terminate. + sendEvaluateResponse (simpleEvalResp (T.pack e) (T.pack "")) + EvalException {resultVal, resultType} -> + sendEvaluateResponse (simpleEvalResp (T.pack resultVal) (T.pack resultType)) + EvalCompleted{resultVal, resultType, resultStructureRef} -> do sendEvaluateResponse EvaluateResponse - { evaluateResponseResult = T.pack e - , evaluateResponseType = T.pack "" - , evaluateResponsePresentationHint = Nothing - , evaluateResponseVariablesReference = 0 - , evaluateResponseNamedVariables = Nothing - , evaluateResponseIndexedVariables = Nothing - , evaluateResponseMemoryReference = Nothing - } - _ -> do - sendEvaluateResponse EvaluateResponse - { evaluateResponseResult = T.pack $ resultVal er - , evaluateResponseType = T.pack $ resultType er - , evaluateResponsePresentationHint = Nothing - , evaluateResponseVariablesReference = 0 - , evaluateResponseNamedVariables = Nothing - , evaluateResponseIndexedVariables = Nothing - , evaluateResponseMemoryReference = Nothing + { evaluateResponseResult = T.pack resultVal + , evaluateResponseType = T.pack resultType + , evaluateResponsePresentationHint = Nothing + , evaluateResponseVariablesReference = fromEnum resultStructureRef + , evaluateResponseNamedVariables = Nothing + , evaluateResponseIndexedVariables = Nothing + , evaluateResponseMemoryReference = Nothing } -------------------------------------------------------------------------------- diff --git a/hdb/Development/Debug/Adapter/Stopped.hs b/hdb/Development/Debug/Adapter/Stopped.hs index 55fdd49..02607b3 100644 --- a/hdb/Development/Debug/Adapter/Stopped.hs +++ b/hdb/Development/Debug/Adapter/Stopped.hs @@ -153,14 +153,3 @@ varInfoToVariables VarInfo{..} = } } --------------------------------------------------------------------------------- --- * Utilities --------------------------------------------------------------------------------- - --- | From 'ScopeVariablesReference' to a 'VariableReference' that can be used in @"variable"@ requests -scopeToVarRef :: ScopeVariablesReference -> VariableReference -scopeToVarRef = \case - LocalVariablesScope -> LocalVariables - ModuleVariablesScope -> ModuleVariables - GlobalVariablesScope -> GlobalVariables - diff --git a/test/golden/T61/T61.hdb-stdout b/test/golden/T61/T61.hdb-stdout index 1edc519..06fb912 100644 --- a/test/golden/T61/T61.hdb-stdout +++ b/test/golden/T61/T61.hdb-stdout @@ -1,4 +1,4 @@ [1 of 2] Compiling Main ( /x/Main.hs, interpreted )[main] (hdb) wrks -EvalCompleted {resultVal = "()", resultType = "()"} +EvalCompleted {resultVal = "()", resultType = "()", resultStructureRef = NoVariables} (hdb) Exiting... diff --git a/test/golden/T79/T79.hdb-stdout b/test/golden/T79/T79.hdb-stdout index 3f16f44..75a316b 100644 --- a/test/golden/T79/T79.hdb-stdout +++ b/test/golden/T79/T79.hdb-stdout @@ -9,5 +9,5 @@ [1 of 2] Compiling Main ( -tmp] (hdb) Hello, Haskell! -EvalCompleted {resultVal = "()", resultType = "()"} +EvalCompleted {resultVal = "()", resultType = "()", resultStructureRef = NoVariables} (hdb) \ No newline at end of file diff --git a/test/golden/T83/T83.hdb-stdout b/test/golden/T83/T83.hdb-stdout index 7181372..ca0d958 100644 --- a/test/golden/T83/T83.hdb-stdout +++ b/test/golden/T83/T83.hdb-stdout @@ -1,4 +1,4 @@ [1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) Heli -EvalCompleted {resultVal = "()", resultType = "()"} +EvalCompleted {resultVal = "()", resultType = "()", resultStructureRef = NoVariables} (hdb) Exiting... diff --git a/test/integration-tests/data/T116/T116.hs b/test/integration-tests/data/T116/T116.hs new file mode 100644 index 0000000..769124e --- /dev/null +++ b/test/integration-tests/data/T116/T116.hs @@ -0,0 +1,22 @@ +module Main where + +import Data.IntMap +import qualified Data.IntMap as IM + +main = do + nn (IM.fromList [(0,345),(1,34),(46,345)]) + nn (IM.fromList [(0,1)]) + nn (IM.fromList [(0,2), (2,4)]) + nn (IM.fromList [(0,3)]) + +nn :: IntMap Int -> IO () +nn im = do + if False + then return () + else do + nnn im + return () + +nnn :: IntMap Int -> IO () +nnn im = do + const (return ()) im diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 210e4f0..2887c45 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -204,7 +204,7 @@ describe("Debug Adapter Tests", function () { return forcedVar } - const expandVar = async (v) => { + const expandVar = async (v : {variablesReference: number, name: string}) => { assert.notStrictEqual(v.variablesReference, 0, `Variable ${v.name} should be expandable (because it is a structure)`); // Expand a structure (similarly to forcing a lazy variable, but because it is not lazy it will fetch the fields) @@ -857,5 +857,29 @@ describe("Debug Adapter Tests", function () { })) }) }) + describe("Evaluate", function () { + it("Return structured representation for evaluated expressions (issue #116)", async () => { + let config = mkConfig({ + projectRoot: "/data/T116", + entryFile: "T116.hs", + entryPoint: "main", + entryArgs: [], + extraGhcArgs: [] + }) + + const expected = { path: config.projectRoot + "/" + config.entryFile, line: 13 } + + await dc.hitBreakpoint(config, { path: config.entryFile, line: 13 }, expected, expected); + + let resp = await dc.evaluateRequest({expression: "IM.delete 0 (IM.insert 0 'a' (IM.insert 1 'b' IM.empty))"} ) + + assert.strictEqual(resp.body.result, 'Tip'); + const respChild = await expandVar({...resp.body, name: resp.body.result}) + const _1Var = await respChild.get("_1") + const _2Var = await respChild.get("_2") + assert.strictEqual(_1Var.value, '1'); + assert.strictEqual(_2Var.value, '\'b\''); + }) + }) })