haskell-debugger 0.12.2.0 → 0.13.0.0

raw patch · 240 files changed

+6648/−1366 lines, 240 filesdep +ghc-stack-annotationsdep +retrydep +stmdep ~asyncdep ~dapdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-stack-annotations, retry, stm, uuid

Dependency ranges changed: async, dap, directory, exceptions, hie-bios, mtl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +31/−0
• README.md +16/−4
• haskell-debugger-view/CHANGELOG.md +20/−0
• haskell-debugger-view/LICENSE +29/−0
• haskell-debugger-view/haskell-debugger-view.cabal +45/−0
• haskell-debugger.cabal +70/−12
• haskell-debugger/GHC/Debugger.hs +4/−10
• haskell-debugger/GHC/Debugger/Breakpoint.hs +56/−13
• haskell-debugger/GHC/Debugger/Interface/Messages.hs +19/−4
• haskell-debugger/GHC/Debugger/Monad.hs +355/−50
• haskell-debugger/GHC/Debugger/Run.hs +149/−36
• haskell-debugger/GHC/Debugger/Runtime/Instances.hs +27/−18
• haskell-debugger/GHC/Debugger/Runtime/Interpreter.hs +122/−0
• haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs +367/−0
• haskell-debugger/GHC/Debugger/Runtime/Thread.hs +52/−29
• haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs +17/−13
• haskell-debugger/GHC/Debugger/Session.hs +153/−60
• haskell-debugger/GHC/Debugger/Session/Builtin.hs +1/−1
• haskell-debugger/GHC/Debugger/Session/Interactive.hs +111/−0
• haskell-debugger/GHC/Debugger/Stopped.hs +12/−23
• haskell-debugger/GHC/Debugger/Stopped/Exception.hs +71/−113
• haskell-debugger/GHC/Debugger/Stopped/Variables.hs +68/−29
• haskell-debugger/GHC/Debugger/Utils/Orphans.hs +9/−0
• hdb/Development/Debug/Adapter.hs +60/−15
• hdb/Development/Debug/Adapter/Breakpoints.hs +7/−3
• hdb/Development/Debug/Adapter/Evaluation.hs +9/−5
• hdb/Development/Debug/Adapter/Exit.hs +8/−75
• hdb/Development/Debug/Adapter/Exit/Helpers.hs +47/−0
• hdb/Development/Debug/Adapter/Init.hs +180/−129
• hdb/Development/Debug/Adapter/Interface.hs +4/−3
• hdb/Development/Debug/Adapter/Proxy.hs +62/−26
• hdb/Development/Debug/Adapter/Stopped.hs +3/−1
• hdb/Development/Debug/Interactive.hs +28/−23
• hdb/Development/Debug/Options.hs +13/−3
• hdb/Development/Debug/Options/Parser.hs +17/−9
• hdb/Development/Debug/Session/Setup.hs +11/−1
• hdb/Main.hs +107/−62
• test/golden/T130/T130.cabal +24/−0
• test/golden/T130/T130.ghc-914.hdb-stdout +2/−0
• test/golden/T130/T130.ghc-915.hdb-stdout +2/−0
• test/golden/T130/T130.hdb-stdout +0/−1
• test/golden/T130b/T130b.cabal +24/−0
• test/golden/T130b/T130b.ghc-914.hdb-stdout +4/−0
• test/golden/T130b/T130b.ghc-915.hdb-stdout +4/−0
• test/golden/T130b/T130b.hdb-stdout +0/−4
• test/golden/T130c/T130c.cabal +18/−0
• test/golden/T130c/T130c.ghc-914.hdb-stdout +7/−0
• test/golden/T130c/T130c.hdb-stdin +3/−0
• test/golden/T130c/T130c.hdb-test +3/−0
• test/golden/T130c/lib/Lib.hs +19/−0
• test/golden/T135/T135.ghc-914.hdb-stdout +13/−0
• test/golden/T135/T135.ghc-915.hdb-stdout +13/−0
• test/golden/T135/T135.hdb-stdout +0/−13
• test/golden/T135/cabal.project +1/−0
• test/golden/T135/hie.yaml +6/−0
• test/golden/T135/myapp/myapp.cabal +17/−0
• test/golden/T135/mylib/mylib.cabal +17/−0
• test/golden/T154/T154.ghc-914.hdb-stdout +5/−0
• test/golden/T154/T154.ghc-915.hdb-stdout +5/−0
• test/golden/T154/T154.hdb-stdout +0/−5
• test/golden/T159/T159.ghc-914.hdb-stdout +6/−0
• test/golden/T159/T159.ghc-915.hdb-stdout +6/−0
• test/golden/T159/T159.hdb-stdout +0/−6
• test/golden/T159/hie.yaml +8/−0
• test/golden/T164/T164.ghc-914.hdb-stdout +25/−0
• test/golden/T164/T164.ghc-915.hdb-stdout +27/−0
• test/golden/T164/T164.hdb-stdout +0/−27
• test/golden/T166/Main.hs +3/−0
• test/golden/T166/T166.ghc-914.hdb-stdout +17/−0
• test/golden/T166/T166.hdb-stdin +6/−0
• test/golden/T166/T166.hdb-stdout +17/−0
• test/golden/T166/T166.hdb-test +1/−0
• test/golden/T169/T169.ghc-914.hdb-stdout +5/−0
• test/golden/T169/T169.ghc-915.hdb-stdout +5/−0
• test/golden/T169/T169.hdb-stdout +0/−5
• test/golden/T169/T169b.ghc-914.hdb-stdout +10/−0
• test/golden/T169/T169b.ghc-915.hdb-stdout +10/−0
• test/golden/T169/T169b.hdb-stdout +0/−10
• test/golden/T169/T169c.external.ghc-914.hdb-stdout +5/−0
• test/golden/T169/T169c.external.ghc-915.hdb-stdout +5/−0
• test/golden/T169/T169c.external.hdb-stdout +0/−5
• test/golden/T169/T169c.internal.ghc-914.hdb-stdout +5/−0
• test/golden/T169/T169c.internal.ghc-915.hdb-stdout +5/−0
• test/golden/T169/T169c.internal.hdb-stdout +0/−5
• test/golden/T217/Main.hs +20/−0
• test/golden/T217/T217.ghc-914.hdb-stdout +12/−0
• test/golden/T217/T217.hdb-stdin +3/−0
• test/golden/T217/T217.hdb-test +1/−0
• test/golden/T218/Main.hs +3/−0
• test/golden/T218/T218.ghc-914.hdb-stdout +12/−0
• test/golden/T218/T218.hdb-stdin +6/−0
• test/golden/T218/T218.hdb-stdout +12/−0
• test/golden/T218/T218.hdb-test +1/−0
• test/golden/T225/Main.hs +12/−0
• test/golden/T225/T225.ghc-914.hdb-stdout +6/−0
• test/golden/T225/T225.hdb-stdin +3/−0
• test/golden/T225/T225.hdb-stdout +6/−0
• test/golden/T225/T225.hdb-test +1/−0
• test/golden/T225b/B.hs +13/−0
• test/golden/T225b/Main.hs +8/−0
• test/golden/T225b/T225b.ghc-914.hdb-stdout +9/−0
• test/golden/T225b/T225b.hdb-stdin +3/−0
• test/golden/T225b/T225b.hdb-stdout +9/−0
• test/golden/T225b/T225b.hdb-test +1/−0
• test/golden/T234/T234.cabal +17/−0
• test/golden/T234/T234.ghc-914.hdb-stdout +7/−0
• test/golden/T234/T234.hdb-stdin +3/−0
• test/golden/T234/T234.hdb-test +3/−0
• test/golden/T234/lib/Lib.hs +20/−0
• test/golden/T234b/T234b.cabal +17/−0
• test/golden/T234b/T234b.ghc-914.hdb-stdout +7/−0
• test/golden/T234b/T234b.hdb-stdin +3/−0
• test/golden/T234b/T234b.hdb-test +1/−0
• test/golden/T234b/lib/Lib.hs +21/−0
• test/golden/T237/T237.cabal +24/−0
• test/golden/T237/T237.ghc-914.hdb-stdout +16/−0
• test/golden/T237/T237.hdb-stdin +3/−0
• test/golden/T237/T237.hdb-test +1/−0
• test/golden/T237/app/Main.hs +15/−0
• test/golden/T237/lib/MyType.hs +11/−0
• test/golden/T239/Main.hs +28/−0
• test/golden/T239/T239.fails-239.ghc-914.hdb-stdout +11/−0
• test/golden/T239/T239.fails-239.hdb-test +1/−0
• test/golden/T239/T239.hdb-stdin +4/−0
• test/golden/T242/Main.hs +12/−0
• test/golden/T242/T242.ghc-914.hdb-stdout +14/−0
• test/golden/T242/T242.hdb-stdin +8/−0
• test/golden/T242/T242.hdb-test +1/−0
• test/golden/T283/T283.cabal +18/−0
• test/golden/T283/T283.ghc-914.hdb-stdout +10/−0
• test/golden/T283/T283.hdb-stdin +4/−0
• test/golden/T283/T283.hdb-test +4/−0
• test/golden/T283/app/Main.hs +4/−0
• test/golden/T61/T61.ghc-914.hdb-stdout +5/−0
• test/golden/T61/T61.ghc-915.hdb-stdout +5/−0
• test/golden/T61/T61.hdb-stdout +0/−5
• test/golden/T79/T79.ghc-914.hdb-stdout +14/−0
• test/golden/T79/T79.ghc-915.hdb-stdout +14/−0
• test/golden/T79/T79.hdb-stdout +0/−14
• test/golden/T83/T83.ghc-914.hdb-stdout +5/−0
• test/golden/T83/T83.ghc-915.hdb-stdout +5/−0
• test/golden/T83/T83.hdb-stdout +0/−5
• test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout +23/−0
• test/golden/exceptions-multiple/exceptions-multiple.ghc-915.hdb-stdout +23/−0
• test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout +0/−23
• test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout +22/−0
• test/golden/exceptions-uncaught/exceptions-uncaught.ghc-915.hdb-stdout +22/−0
• test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout +0/−22
• test/golden/exceptions/exceptions.ghc-914.hdb-stdout +13/−0
• test/golden/exceptions/exceptions.ghc-915.hdb-stdout +13/−0
• test/golden/exceptions/exceptions.hdb-stdout +0/−13
• test/golden/self-debug-cli/Main.hs +1/−0
• test/golden/self-debug-cli/self-debug-cli.hdb-stdin +5/−0
• test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-914.hdb-stdout +56/−0
• test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test +34/−0
• test/haskell/Main.hs +85/−27
• test/haskell/Test/DAP.hs +569/−107
• test/haskell/Test/DAP/Init.hs +197/−0
• test/haskell/Test/DAP/Messages.hs +110/−0
• test/haskell/Test/DAP/Messages/Parser.hs +77/−0
• test/haskell/Test/DAP/Orphans.hs +237/−0
• test/haskell/Test/DAP/RunInTerminal.hs +0/−298
• test/haskell/Test/Integration/Basic.hs +91/−0
• test/haskell/Test/Integration/Conditional.hs +76/−0
• test/haskell/Test/Integration/Evaluate.hs +40/−0
• test/haskell/Test/Integration/Exceptions.hs +69/−0
• test/haskell/Test/Integration/LogMessage.hs +82/−0
• test/haskell/Test/Integration/MultiHomeUnit.hs +52/−0
• test/haskell/Test/Integration/MultiMain.hs +47/−0
• test/haskell/Test/Integration/Persistent.hs +126/−0
• test/haskell/Test/Integration/RunInTerminal.hs +116/−0
• test/haskell/Test/Integration/Scopes.hs +43/−0
• test/haskell/Test/Integration/StackTrace.hs +59/−0
• test/haskell/Test/Integration/Stdout.hs +38/−0
• test/haskell/Test/Integration/StepOut.hs +72/−0
• test/haskell/Test/Integration/Variables.hs +321/−0
• test/haskell/Test/Utils.hs +19/−1
• test/integration/T107a/app/Main.hs +11/−0
• test/integration/T107a/b/b.cabal +17/−0
• test/integration/T107a/b/src/MyLib.hs +6/−0
• test/integration/T107a/cabal.project +1/−0
• test/integration/T107a/hie.yaml +3/−0
• test/integration/T107a/t3.cabal +17/−0
• test/integration/T110/T110.hs +11/−0
• test/integration/T111/T111.hs +22/−0
• test/integration/T113/Main.hs +22/−0
• test/integration/T116/T116.hs +22/−0
• test/integration/T159/T159.cabal +12/−0
• test/integration/T159/app/Main.hs +15/−0
• test/integration/T159/cabal.project +2/−0
• test/integration/T44/Main.hs +8/−0
• test/integration/T45/Main.hs +6/−0
• test/integration/T47a/Main.hs +26/−0
• test/integration/T47a/T47a.cabal +19/−0
• test/integration/T47a/cabal.project +1/−0
• test/integration/T47b/Main.hs +11/−0
• test/integration/T47c/Main.hs +14/−0
• test/integration/T47c/T47a.cabal +19/−0
• test/integration/T47c/cabal.project +1/−0
• test/integration/T47d/Main.hs +12/−0
• test/integration/T47d/T47d.cabal +18/−0
• test/integration/T47e/Main.hs +12/−0
• test/integration/T47e/T47d.cabal +18/−0
• test/integration/T55/Main.hs +43/−0
• test/integration/T6/MainA.hs +22/−0
• test/integration/T6/MainB.hs +20/−0
• test/integration/T6/MainC.hs +10/−0
• test/integration/T64/Main.hs +5/−0
• test/integration/T71/Main.hs +2/−0
• test/integration/T77/T77.cabal +18/−0
• test/integration/T77/app/Main.hs +4/−0
• test/integration/T92/T92.hs +10/−0
• test/integration/T97/Main.hs +13/−0
• test/integration/cabal-mhu1/bar/app/Main.hs +9/−0
• test/integration/cabal-mhu1/bar/bar.cabal +20/−0
• test/integration/cabal-mhu1/bar/src/Bar.hs +10/−0
• test/integration/cabal-mhu1/cabal.project +3/−0
• test/integration/cabal-mhu1/foo/foo.cabal +10/−0
• test/integration/cabal-mhu1/foo/src/Foo.hs +6/−0
• test/integration/cabal-mhu1/hie.yaml +3/−0
• test/integration/cabal1/app/Main.hs +15/−0
• test/integration/cabal1/cabal.project +1/−0
• test/integration/cabal1/cabal1.cabal +17/−0
• test/integration/exceptions/Main.hs +17/−0
• test/integration/labeled/Main.hs +13/−0
• test/integration/multi-exes/a/a.cabal +12/−0
• test/integration/multi-exes/a/app/Main.hs +14/−0
• test/integration/multi-exes/b/app/Main.hs +10/−0
• test/integration/multi-exes/b/b.cabal +11/−0
• test/integration/multi-exes/cabal.project +1/−0
• test/integration/multi-exes/hie.yaml +3/−0
• test/integration/multi-mains/app/Foo.hs +3/−0
• test/integration/multi-mains/app/Main.hs +6/−0
• test/integration/multi-mains/cabal.project +1/−0
• test/integration/multi-mains/hie.yaml +3/−0
• test/integration/multi-mains/multi-mains.cabal +17/−0
• test/integration/multi-mains/second/Main.hs +3/−0
• test/integration/repeat/Main.hs +5/−0
• test/integration/simple/Main.hs +12/−0
• test/integration/simple2/Main.hs +22/−0

@@ -1,5 +1,36 @@ # Revision history for haskell-debugger +## 0.13.0.0 -- 2026-04-24++Features:++* Launch the external-interpreter directly in User's Terminal. That is, VSCode+  terminal will run the external interpreter, which is evaluating the debuggee+  directly, directly (rather than a proxy program).+    * When using the internal interpreter, falls back to running `hdb proxy`.+* Add support for `import Module` statements at the debug REPL.+* Add [logpoints](https://code.visualstudio.com/docs/debugtest/debugging#_logpoints) support.+* Support for nightly GHC 9.15, leveraging external interpreter commands.++Bug fixes:+* Fix: Import failed where depended-upon package was incorrectly considered hidden+* Fix: Respond cleanly to DAP client with ErrorResponse on exceptions, rather than crashing the session.+* Fix: terminate/disconnect/terminated wasn't following DAP properly, resulting in premature exiting crashes+* Fix: Debugger.View.Class cannot be found in certain multi-repl sessions+* Fix: Make custom DebugViews instances work for `newtypes`+* Fix: Display more unevaluatable closures as `<fn>` rather than as thunks `_`+* Fix: Inherit the language extensions at any given breakpoint source to the REPL+* Fix: Don't print certain evaluation results in duplicate+* Fix: Set scopeExpensive=true for Module and Global++Additionally, the debugger internals and the testsuite were considerably+refactored and improved, paving the way for better, faster changes, with more+confidence.++## 0.12.3.0 -- 2026-03-11++* Updated extension logo to be Haskell's logo+ ## 0.12.2.0 -- 2026-03-09  * Bug fixes and improved progress reporting

@@ -179,10 +179,22 @@ nix-build ``` -## Testing+## Testing and Debugging  ```-cd test/integration-tests-make GHC=/path/to/recent/ghc \-     DEBUGGER=$(cd ../.. && cabal list-bin -w /path/to/ghc-9.14 exe:hdb)+# Main testsuite (includes the golden tests, unit tests, and the integration+# tests that used to be run via the NodeJS @vscode-debugadapter-testsupport@+# library).+cabal run haskell-debugger-test ```++### Debugging the debugger with the debugger++1. Run the debugger (e.g. through VSCode) with `entryFile: hdb/Main.hs` and+   arguments `entryArgs: [server, --port, 12345]`. This will start the debugger+   executable on port 12345 through the debugger.++2. Using VSCode, setup the launch.json for the project you want to test the+   debugger with `debugServer: 12345`. This will tell VSCode to connect to this+   port for the DAP server. This should trigger the breakpoint you set on the+   debugger in step (1).

@@ -0,0 +1,20 @@+# Revision history for haskell-debugger-view++## 0.2.1.0 -- 2026-02-24++* Add `DebugView` instance for `SomeException`+* Documentation fixes++## 0.2.0.0 -- 2026-01-05++* Add support for more complex debug visualizations using the Program abstraction+    * API change: `debugValue` and `debugFields` now return `Program`-wrapped+      values, rather than `VarFields/VarValue` directly.+* Introduce new functions `isThunk` and `ifP` for conditional debugging behavior+* Enhance list visualization to show up to 50 forced elements+* Add improved handling for lazy values in debug views+* Update documentation and examples for custom DebugView instances++## 0.1.0.0 -- 2025-11-18++* First version. Released on an unsuspecting world.

@@ -0,0 +1,29 @@+Copyright (c) 2025, Rodrigo Mesquita+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,45 @@+cabal-version:   3.12+name:            haskell-debugger-view+version:         0.2.1.0+license:         BSD-3-Clause+author:          Matthew Pickering, Rodrigo Mesquita+maintainer:      matthewtpickering@gmail.com, rodrigo@well-typed.com+build-type:      Simple+extra-doc-files: CHANGELOG.md+category:        Development+synopsis:+    Custom debug visualization instances for @haskell-debugger@+description:+    This package provides a class to implement custom debug visualization+    instances for user-defined datatypes, which will be discovered and used by+    @haskell-debugger@ when debugging a program. Additionally, it provides a+    handful of built-in custom visualizations, such as for @String@ and @IntMap@.+    The custom debug visualizations are displayed in the editor when inspecting+    a variable or evaluation result. The @'DebugView'@ class is the class for+    which an instance must be provided, and allows one to customize what is+    displayed inline and what fields are available when expanding it.+    See the haddocks of @'GHC.Debugger.View.Class'@ for further information.++common warnings+    ghc-options: -Wall++source-repository head+    type: git+    location: https://github.com/well-typed/haskell-debugger+    subdir: haskell-debugger-view++library+    import:           warnings+    -- If you add a module here make sure to also add this module to the list+    -- of modules that we attempt to load when haskell-debug-view is not+    -- dependend upon transitively, in GHC.Debugger.Session.Builtin+    exposed-modules:  GHC.Debugger.View.Class+                      GHC.Debugger.View.Containers+                      GHC.Debugger.View.Text+                      GHC.Debugger.View.ByteString+    build-depends:    base >= 4.22 && < 5,+                      containers >= 0.7 && < 0.9,+                      text >= 2.1 && < 2.3,+                      bytestring >= 0.12.1 && < 0.13,+    hs-source-dirs:   src+    default-language: GHC2021

@@ -1,6 +1,6 @@ cabal-version:      3.12 name:               haskell-debugger-version:            0.12.2.0+version:            0.13.0.0 synopsis:     A step-through debugger for GHC Haskell @@ -9,17 +9,17 @@                     programs and can act as a Debug Adapter Protocol (DAP)                     server in the @server@ mode for debugging Haskell                     programs.-                    +                     The Debug Adapter is implemented on top of the                     @haskell-debugger@ library which defines the primitive                     debugging capabilities. These debugger features are                     implemented by managing a GHC session and debugging it                     through the GHC API.-                    +                     The @hdb@ is transparently compatible with most projects                     because it uses @hie-bios@ to figure out the right flags to                     invoke GHC with.-                    +                     Additional information can be found [in the README](https://github.com/well-typed/haskell-debugger).  license:            BSD-3-Clause@@ -37,9 +37,21 @@                     haskell-debugger-view/src/GHC/Debugger/View/Containers.hs                     haskell-debugger-view/src/GHC/Debugger/View/Text.hs                     haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs+                    haskell-debugger-view/haskell-debugger-view.cabal+                    haskell-debugger-view/LICENSE+                    haskell-debugger-view/CHANGELOG.md                      -- Should probably be extra extra-files but that requires cabal 3.14                     test/golden/**/*.hs+                    test/golden/**/*.cabal+                    test/golden/**/*.yaml+                    test/golden/**/*.project++                    test/integration/**/*.hs+                    test/integration/**/*.cabal+                    test/integration/**/*.yaml+                    test/integration/**/*.project+                     test/golden/**/*.hdb-stdin                     test/golden/**/*.hdb-stdout                     test/golden/**/*.hdb-test@@ -89,13 +101,22 @@                       GHC.Debugger.Runtime.Thread.Stack,                       GHC.Debugger.Runtime.Thread.Map, +                      GHC.Debugger.Runtime.Interpreter.Custom,+                       GHC.Debugger.Monad,                       GHC.Debugger.Utils,+                      GHC.Debugger.Utils.Orphans,                        GHC.Debugger.Session,                       GHC.Debugger.Session.Builtin,+                      GHC.Debugger.Session.Interactive,                       GHC.Debugger.Interface.Messages-    -- other-modules:++    if impl(ghc >= 9.15)+      exposed-modules:+                      GHC.Debugger.Runtime.Interpreter++     default-extensions: CPP     build-depends:    base >= 4.22 && < 5,                       ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16,@@ -113,17 +134,20 @@                       exceptions >= 0.10.9 && < 0.11,                       bytestring >= 0.12.1 && < 0.13,                       async >= 2.2.6 && < 2.3,+                      network >= 3.2.8,                       cryptohash-sha1 >= 0.11.101.0 && < 0.12,                       base16-bytestring >= 1.0.2.0 && < 1.1,                       aeson >= 2.2.3 && < 2.3,-                      hie-bios >= 0.15 && < 0.19,+                      hie-bios >= 0.15 && < 0.20,                       file-embed >= 0.0.16 && < 0.1,                       attoparsec >= 0.13 && < 0.15,                       time >= 1.14 && < 2,                       text >= 2.1 && < 2.3,+                      retry >= 0.9 && < 1,                       co-log-core >= 0.3.2.5 && < 0.4, -                      haskell-debugger-view >= 0.2 && < 1.0+                      haskell-debugger-view >= 0.2 && < 1.0,+                      ghc-stack-annotations >=0.1 && <0.2,      if !os(windows)         build-depends: unix >= 2.8.6 && < 2.9,@@ -143,6 +167,7 @@                       Development.Debug.Adapter.Interface,                       Development.Debug.Adapter.Output,                       Development.Debug.Adapter.Exit,+                      Development.Debug.Adapter.Exit.Helpers,                       Development.Debug.Adapter.Handles,                       Development.Debug.Adapter, @@ -177,10 +202,13 @@         network-run >= 0.4.4,         async >= 2.2.5 && < 2.3,         text >= 2.1 && < 2.3,-        dap >= 0.4 && < 0.5,+        dap >= 0.5 && < 0.6,          haskeline >= 0.8 && < 1,-        optparse-applicative >= 0.18 && < 0.20+        optparse-applicative >= 0.18 && < 0.20,+        uuid >= 1.3 && < 1.4,+        ghc-stack-annotations >=0.1 && <0.2,+     hs-source-dirs:   hdb     default-language: GHC2021     default-extensions: CPP@@ -195,18 +223,41 @@     type:             exitcode-stdio-1.0     hs-source-dirs:   test/haskell/     main-is:          Main.hs-    other-modules:    Test.DAP.RunInTerminal, Test.DAP, Test.Utils+    other-modules:    Test.DAP,+                      Test.DAP.Init,+                      Test.DAP.Messages,+                      Test.DAP.Messages.Parser,+                      Test.DAP.Orphans,+                      Test.Utils,++                      Test.Integration.RunInTerminal,+                      Test.Integration.Scopes,+                      Test.Integration.LogMessage,+                      Test.Integration.Persistent,+                      Test.Integration.Basic,+                      Test.Integration.Exceptions,+                      Test.Integration.MultiMain,+                      Test.Integration.MultiHomeUnit,+                      Test.Integration.Variables,+                      Test.Integration.StepOut,+                      Test.Integration.Stdout,+                      Test.Integration.Conditional,+                      Test.Integration.Evaluate,+                      Test.Integration.StackTrace     build-depends:         base >=4.14,+        async,         haskell-debugger,         bytestring, text,         containers,+        directory,         filepath,         process,         temporary >= 1.3,+        mtl,          unordered-containers,-        aeson-pretty >= 0.8.10, async >= 2.2.5,+        aeson-pretty >= 0.8.10,         dap, network, aeson, network-run,         random >= 1.3.1, @@ -214,6 +265,13 @@         tasty-golden >= 2.3.5,         tasty-hunit >= 0.10.2,         tasty-expected-failure >= 0.12.3,-        regex >= 1.1+        regex >= 1.1,+        exceptions,+        retry,+        stm >= 2.5.3.1,+     build-tool-depends: haskell-debugger:hdb     ghc-options: -threaded+    -- TODO: Investigate apparent race condition on windows+    if !os(windows)+        ghc-options: -rtsopts "-with-rtsopts=-N"

@@ -3,9 +3,6 @@    TypeApplications, ScopedTypeVariables, BangPatterns #-} module GHC.Debugger where -import System.Exit-import Control.Monad.IO.Class- import GHC.Debugger.Breakpoint import GHC.Debugger.Run import GHC.Debugger.Stopped@@ -22,21 +19,18 @@ execute = \case   ClearFunctionBreakpoints -> DidClearBreakpoints <$ clearBreakpoints Nothing   ClearModBreakpoints fp -> DidClearBreakpoints <$ clearBreakpoints (Just fp)-  SetBreakpoint{brk, hitCount, condition} ->-    DidSetBreakpoint <$> setBreakpoint brk (condBreakEnableStatus hitCount condition)-  DelBreakpoint bp -> DidRemoveBreakpoint <$> setBreakpoint bp BreakpointDisabled+  SetBreakpoint{brk, hitCount, condition, logMessage} ->+    DidSetBreakpoint <$> setBreakpoint brk (condBreakEnableStatus hitCount condition) (maybe BreakpointStop (BreakpointLogAndResume . logMessageExpression) logMessage)+  DelBreakpoint bp -> DidRemoveBreakpoint <$> setBreakpoint bp BreakpointDisabled BreakpointStop   GetBreakpointsAt bp -> DidGetBreakpoints <$> getBreakpointsAt bp   GetThreads -> GotThreads <$> getThreads   GetStacktrace i -> GotStacktrace <$> getStacktrace i   GetScopes threadId frameIx -> GotScopes <$> getScopes threadId frameIx   GetVariables threadId frameIx varRef -> GotVariables <$> getVariables threadId frameIx varRef   GetExceptionInfo threadId -> GotExceptionInfo <$> getExceptionInfo threadId-  DoEval exp_s -> DidEval <$> doEval exp_s+  DoEval exp_s -> DidEval <$> doEvalCommand exp_s   DoContinue -> DidContinue <$> doContinue   DoSingleStep -> DidStep <$> doSingleStep   DoStepOut -> DidStep <$> doStepOut   DoStepLocal -> DidStep <$> doLocalStep   DebugExecution { entryPoint, entryFile, runArgs } -> DidExec <$> debugExecution entryFile entryPoint runArgs-  TerminateProcess -> liftIO $ do-    -- Terminate!-    exitWith ExitSuccess

@@ -9,6 +9,7 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bits (xor)+import Data.List (intercalate) import Data.IORef import System.Directory import System.FilePath@@ -66,12 +67,12 @@ getBreakpointsAt _ = error "unexpected getbreakpoints without ModuleBreak"  -- | Set a breakpoint in this session-setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound-setBreakpoint bp BreakpointAfterCountCond{} = do+setBreakpoint :: Breakpoint -> BreakpointStatus -> BreakpointAction -> Debugger BreakFound+setBreakpoint bp BreakpointAfterCountCond{} _action = do   logSDoc Logger.Warning $     text $ "Setting a hit count condition on a conditional breakpoint is not yet supported. Ignoring breakpoint " ++ show bp   return BreakNotFound-setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do+setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status action = do   mmodl <- getModuleByPath path   case mmodl of     Left e -> do@@ -83,13 +84,17 @@         Just (bix, spn) -> do           let bid = BreakpointId { bi_tick_mod = ms_mod modl                                  , bi_tick_index = bix }-          (changed, ibis) <- registerBreakpoint bid bp_status ModuleBreakpointKind+              binfo = BreakpointInfo+                        { bpInfoStatus = bp_status+                        , bpInfoKind = ModuleBreakpointKind+                        , bpInfoAction = action}+          (changed, ibis) <- registerBreakpoint bid binfo           return $ BreakFound             { changed = changed             , sourceSpan = realSrcSpanToSourceSpan spn             , breakId = ibis             }-setBreakpoint FunctionBreak{function} bp_status = do+setBreakpoint FunctionBreak{function} bp_status action = do   logger <- getLogger   resolveFunctionBreakpoint function >>= \case     Left e -> do@@ -101,7 +106,11 @@           applyBreak (bix, spn) = do             let bid = BreakpointId { bi_tick_mod = modl                                    , bi_tick_index = bix }-            (changed, ibis) <- registerBreakpoint bid bp_status FunctionBreakpointKind+                binfo = BreakpointInfo+                        { bpInfoStatus = bp_status+                        , bpInfoKind = FunctionBreakpointKind+                        , bpInfoAction = action}+            (changed, ibis) <- registerBreakpoint bid binfo             return $ BreakFound               { changed = changed               , sourceSpan = realSrcSpanToSourceSpan spn@@ -115,7 +124,8 @@         bs  -> do           liftIO $ logOutput logger (text $ "Ambiguous breakpoint found by name " ++ function ++ ": " ++ show bs ++ ". Setting breakpoints in all...")           ManyBreaksFound <$> mapM applyBreak bs-setBreakpoint exception_bp bp_status = do+-- The assert can be removed once we have a way to register actions for exception breakpoints.+setBreakpoint exception_bp bp_status action = assert (action == BreakpointStop) $ do   let ch_opt | BreakpointDisabled <- bp_status              = gopt_unset              | otherwise@@ -142,8 +152,8 @@ -- 'BreakpointStatus' being set. -- -- Returns @True@ when the breakpoint status is changed.-registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger (Bool, [GHC.InternalBreakpointId])-registerBreakpoint bp status kind = do+registerBreakpoint :: GHC.BreakpointId -> BreakpointInfo -> Debugger (Bool, [GHC.InternalBreakpointId])+registerBreakpoint bp info@BreakpointInfo{bpInfoStatus = status} = do    -- Set breakpoint in GHC session   let breakpoint_count = breakpointStatusInt status@@ -162,12 +172,12 @@          -- Enabling the breakpoint:         _ -> case BM.lookup ibi brksMap of-          Just (status', _kind)-            | status' == status+          Just info'+            | info' == info             -> -- Nothing changed, OK                (brksMap, False)           _ -> -- Else, insert-            (BM.insert ibi (status, kind) brksMap, True)+            (BM.insert ibi info brksMap, True)    return (any id changed, internal_break_ids) @@ -196,7 +206,7 @@     Nothing -> do       return         [ ibi-        | (ibi, (status, kind)) <- BM.toList bm+        | (ibi, BreakpointInfo{bpInfoStatus=status, bpInfoKind=kind}) <- BM.toList bm         -- Keep only function breakpoints in this case         , FunctionBreakpointKind == kind         , assert (status > BreakpointDisabled) True@@ -231,6 +241,39 @@     (Just i,  Nothing) -> BreakpointAfterCount i     (Nothing, Just c)  -> BreakpointWhenCond c     (Just i,  Just c)  -> BreakpointAfterCountCond i c+++-- | @logMessageExpression "foo = {show foo}" = "putStrLn (concat [\"foo = \", show foo])"@+--+--   Braces are preserved if escaped with a backslash. Some unescaped braces are+--   fine: opening braces in antiquotations and closing braces outside of them.+logMessageExpression :: String -> String+logMessageExpression tmpl = apply "Prelude.putStrLn" $ apply "Prelude.concat" $ parts+  where+    apply f x = f ++ " ( " ++ x ++ " ) "+    parts = listOf $ map renderPart (parseQC [] tmpl)+    listOf xs = intercalate ": " . (++ ["[]"]) $ xs+    renderPart (Literal s) = show s+    renderPart (AntiQuote e) = apply "" e++-- Taken from interpolatedstring-perl6 package+data StringPart = Literal String | AntiQuote String deriving Show++unQC :: String -> String -> [StringPart]+unQC a []          = [Literal (reverse a)]+unQC a ('\\':x:xs) = unQC (x:a) xs+unQC a ('\\':[])   = unQC ('\\':a) []+unQC a ('}':xs)    = AntiQuote (reverse a) : parseQC [] xs+unQC a (x:xs)      = unQC (x:a) xs++parseQC :: String -> String -> [StringPart]+parseQC a []           = [Literal (reverse a)]+parseQC a ('\\':'\\':xs) = parseQC ('\\':a) xs+parseQC a ('\\':'{':xs) = parseQC ('{':a) xs+parseQC a ('\\':[])    = parseQC ('\\':a) []+parseQC a ('{':xs)     = Literal (reverse a) : unQC [] xs+parseQC a (x:xs)       = parseQC (x:a) xs+  -- | Get a 'ModSummary' of a loaded module given its 'FilePath' getModuleByPath :: FilePath -> Debugger (Either SDoc ModSummary)

@@ -14,6 +14,8 @@ import qualified GHC.Utils.Outputable as GHC  import GHC.Debugger.Runtime.Term.Key+import Data.Binary (Binary)+import qualified GHC.Stack as Stack  -------------------------------------------------------------------------------- -- Commands@@ -28,6 +30,8 @@                   -- ^ Stop after N hits (if @isJust condition@, count down only when @eval condition == True@)                   , condition :: Maybe String                   -- ^ Stop if condition evalutes to True+                  , logMessage :: Maybe String+                  -- ^ Log only if @condition@ (and @hitCondition@ when supported) are @True@.                   }    -- | Delete a breakpoint on a given function, or module by line number@@ -85,9 +89,6 @@   -- Haskell function arguments.   | DebugExecution { entryPoint :: EntryPoint, entryFile :: FilePath, runArgs :: [String] } -  -- | Terminate haskell-debugger and exit-  | TerminateProcess- -- | An entry point for program execution. data EntryPoint = MainEntry { mainName :: Maybe String } | FunctionEntry { fnName :: String }   deriving (Show)@@ -211,6 +212,16 @@   , endCol = 0   } +srcLocToSourceSpan :: Stack.SrcLoc -> SourceSpan+srcLocToSourceSpan srcLoc =+  SourceSpan+    { file = Stack.srcLocFile srcLoc+    , startLine = Stack.srcLocStartLine srcLoc+    , endLine = Stack.srcLocEndLine srcLoc+    , startCol = Stack.srcLocStartCol srcLoc+    , endCol = Stack.srcLocEndCol srcLoc+    }+ -------------------------------------------------------------------------------- -- Responses --------------------------------------------------------------------------------@@ -261,11 +272,14 @@     -- find the proper remote 'ThreadId' corresponding to this numeric     -- identifier, lookup the 'remoteThreadIntRef' in the 'ThreadMap'     }-    deriving (Show, Eq, Ord)+    deriving (Show, Eq, Ord, Binary) +data SourceKind = IsExpr | IsStmt+ data EvalResult   = EvalCompleted { resultVal :: String                   , resultType :: String+                  , resultSourceKind :: Maybe SourceKind                   , resultStructureRef :: VariableReference                   -- ^ A structured representation of the result of evaluating                   -- the expression given as a "virtual" 'VariableReference'@@ -307,6 +321,7 @@   , exceptionInfoFullTypeName :: String   , exceptionInfoMessage      :: String   , exceptionInfoContext      :: Maybe String+  , exceptionInfoSourceSpan   :: Maybe SourceSpan   , exceptionInfoInner        :: [ExceptionInfo]   }   deriving (Show)

@@ -19,13 +19,14 @@ import Control.Concurrent.Async import Control.Exception import Control.Monad-import Control.Monad.Catch+import Control.Monad.Catch as MC import Control.Monad.IO.Class import Control.Monad.Reader import Data.Function import Data.Functor.Contravariant import Data.IORef import Data.Maybe+import qualified Data.Set as Set import Data.Version (makeVersion, showVersion) import Prelude hiding (mod) #ifdef MIN_VERSION_unix@@ -34,11 +35,15 @@ import Data.Text (Text) import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty+import Network.Socket hiding (Debug)+import System.Process.Internals (mkProcessHandle)+import Text.Read (readMaybe)  import GHC import GHC.Data.FastString import GHC.Data.StringBuffer import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Logger import GHC.Driver.DynFlags as GHC import GHC.Driver.Env import GHC.Driver.Monad@@ -48,10 +53,12 @@ import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Ppr+import GHC.Driver.Session (parseDynamicFlagsCmdLine) import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Loader as GHC+import GHC.Runtime.Context as GHCi import GHC.Types.Error import GHC.Types.PkgQual import GHC.Types.SourceError@@ -68,6 +75,7 @@ import GHC.Debugger.Interface.Messages import GHC.Debugger.Session import GHC.Debugger.Session.Builtin+import GHC.Debugger.Session.Interactive import GHC.Debugger.Runtime.Compile.Cache import GHC.Debugger.Utils import qualified GHC.Debugger.Breakpoint.Map as BM@@ -76,6 +84,16 @@ import Colog.Core as Logger  import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache)+import GHCi.Message (mkPipeFromHandles)+import System.IO (hGetLine, IOMode(..))+import qualified GHC.Linker.Loader as Loader+import GHC.Stack.Annotation+import GHC.Platform.Ways+#if MIN_VERSION_ghc(9,15,0)+import GHC.Data.FastString.Env (emptyFsEnv)+#endif+import GHC.Unit.Home.Graph+import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger`  -- | A debugger action. newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a }@@ -83,11 +101,18 @@            , MonadThrow, MonadCatch, MonadMask            , GHC.HasDynFlags, MonadReader DebuggerState ) +data BreakpointInfo = BreakpointInfo+  { bpInfoStatus :: !BreakpointStatus+  , bpInfoKind   :: !BreakpointKind+  , bpInfoAction :: !BreakpointAction+  }+  deriving (Eq,Show)+ -- | State required to run the debugger. -- -- - Keep track of active breakpoints to easily unset them all. data DebuggerState = DebuggerState-      { activeBreakpoints :: IORef (BM.BreakpointMap (BreakpointStatus, BreakpointKind))+      { activeBreakpoints :: IORef (BM.BreakpointMap BreakpointInfo)         -- ^ Maps a 'InternalBreakpointId' in Trie representation (map of Module to map of Int) to the         -- 'BreakpointStatus' it was activated with. @@ -150,6 +175,18 @@  instance Outputable BreakpointStatus where ppr = text . show +-- | What to do when a breakpoint is enabled+data BreakpointAction+      -- | Evaluation is stopped, typical behaviour+      = BreakpointStop+      {- | A log message is printed and then evaluation resumes.+        The @String@ is an expression that takes care of interpolation and printing the log message.+      -}+      | BreakpointLogAndResume String+      deriving (Eq, Ord, Show)++instance Outputable BreakpointAction where ppr = text . show+ -------------------------------------------------------------------------------- -- Operations --------------------------------------------------------------------------------@@ -159,9 +196,13 @@       { supportsANSIStyling :: Bool       , supportsANSIHyperlinks :: Bool       , preferInternalInterpreter :: Bool-      , externalInterpreterStdinStream :: StdStream-      -- ^ How to determine the stdin of the external interpreter running the-      -- debuggee. If not using the external interpreter this field is unused.+      , externalInterpreterCustomProc :: Either StdStream PortNumber+        -- ^ Right: use a custom given existing process for the external+        -- interpreter listening at given port. (This is used when we want to+        -- launch the external interpreter attached to a user's terminal).+        --+        -- Left: we launch our own external interpreter process through+        -- GHC's spawnIServ using the given StdStream as the stdin.       }  -- | Run a 'Debugger' action on a session constructed from a given GHC invocation.@@ -177,15 +218,21 @@             -> RunDebuggerSettings -- ^ Other debugger run settings             -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation             -> IO a-runDebugger l rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = do+runDebugger l rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = annotateCallStackIO $ do   let ghcLog = liftLogIO l :: LogAction Ghc DebuggerLog   let dbgLog = liftLogIO l :: LogAction Debugger DebuggerLog   thisProg <- getExecutablePath   let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation'-  GHC.runGhc (Just libdir) $ do+  GHC.runGhc (Just libdir) $+    flip MC.finally cleanupInterp $ -- See Note [Shutting down the external interpreter]+      do #ifdef MIN_VERSION_unix     -- Workaround #4162+    -- FIXME: setup reasonable handlers to run cleanupSession for every debugger thread, because runGhc's `withSignalHandlers` is not it.     _ <- liftIO $ installHandler sigINT Default Nothing+    _ <- liftIO $ installHandler sigQUIT Default Nothing+    _ <- liftIO $ installHandler sigTERM Default Nothing+    _ <- liftIO $ installHandler sigHUP Default Nothing #endif     dflags0 <- GHC.getSessionDynFlags     let dflags1 = dflags0@@ -236,7 +283,7 @@       -- 3093efa27468fb2d31a617f6a0e4ff67a90f6623 tried to fix (but had to be       -- reverted)       (dflags2, fileish_args, warns)-        <- parseDynamicFlags logger dflags1 (map noLoc extraGhcArgs)+        <- parseDynamicFlagsWithRootDir rootDir logger dflags1 (map noLoc extraGhcArgs)       liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)       forM_ fileish_args $ \fish_arg -> liftIO $ do         GHC.logMsg logger MCOutput noSrcSpan $ text "Ignoring extraGhcArg which isn't a recognized flag:" <+> text (unLoc fish_arg)@@ -246,29 +293,43 @@     -- Make sure to override the function which creates the external     -- interpreter, because we need to keep track of the standard handles     iserv_handles <- liftIO newEmptyMVar-    modifySession $ \h -> h-      { hsc_hooks = (hsc_hooks h)-          { createIservProcessHook = Just $ \cp -> do-              -- See Note [External interpreter buffering]-              (_, Just o, Just e, ph) <--                createProcess cp-                  { std_in  = conf.externalInterpreterStdinStream-                  , std_out = CreatePipe-                  , std_err = CreatePipe-                  -- Override executable path-                  -- See Note [Custom external interpreter]+    case conf.externalInterpreterCustomProc of+      -- Left: GHC will launch the external interpreter itself on demand if+      -- using external interpreter, and we just provide the stdin stream+      Left givenStdStream ->+        modifySession $ \h -> h+          { hsc_hooks = (hsc_hooks h)+              { createIservProcessHook = Just $ \cp -> do+                  -- See Note [External interpreter buffering]+                  (_, Just o, Just e, ph) <-+                    createProcess cp+                      { std_in  = givenStdStream+                      , std_out = CreatePipe+                      , std_err = CreatePipe+                      -- Override executable path+                      -- See Note [Custom external interpreter] #if MIN_VERSION_ghc(9,15,0) #else-                  , cmdspec = case cmdspec cp of-                      ShellCommand (words -> ws) -> ShellCommand $ unwords $ thisProg : drop 1 ws-                      RawCommand _fp args -> RawCommand thisProg args+                      , cmdspec = case cmdspec cp of+                          ShellCommand (words -> ws) -> ShellCommand $ unwords $ thisProg : drop 1 ws+                          RawCommand _fp args -> RawCommand thisProg args #endif-                  }-              putMVar iserv_handles (o, e)-              return ph+                      }+                  putMVar iserv_handles (o, e)+                  return ph+              }           }-      } +      -- Right: we supply our custom external interpreter process, which is+      -- already running and connected to the user's terminal.+      Right port -> do+        extInterp <- liftIO+          $ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process"+          $ extInterpFromTerminalProcess port+        modifySession $ \h -> h+          { hsc_interp = Just extInterp -- set it directly!+          }+     let       externalInterpFwdThread :: IO ()       externalInterpFwdThread = when (GHC.gopt GHC.Opt_ExternalInterpreter dflags2) $ do@@ -361,15 +422,20 @@         when (GHC.failed success) $ liftIO $           throwM DebuggerFailedToLoad +        -- See Note [Must explicitly expose module graph units]+        setExposedInUnit interactiveGhcDebuggerUnitId (graphUnits final_mod_graph)+         -- Set interactive context to import all loaded modules         let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude"         -- dbgView should always be available, either because we manually loaded it         -- or because it's in the transitive closure.+        hug <- hsc_HUG <$> getSession         let dbgViewImps-              -- Using in-memory hs-dbg-view. It's a home-unit, so refer to it directly-              | hdv_uid == hsDebuggerViewInMemoryUnitId+              -- If hs-dbg-view is a home-unit, refer to it directly+              -- See Note [Do not package-qualify imports for home units]+              | memberHugUnitId hdv_uid hug               = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames-              -- It's available in a unit in the transitive closure. Resolve it.+              -- It's available in an exposed unit in the transitive closure. Resolve it               | otherwise               = map (\mn ->                   GHC.IIDecl (GHC.simpleImportDecl mn)@@ -396,17 +462,232 @@         hscInterp <$> GHC.getSession >>= \interp ->           liftIO $ evalIO interp setBufferings +        noPrint <- defineNoPrint+        modifySession (\hsc_env -> hsc_env {hsc_IC = GHCi.setInteractivePrintName (hsc_IC hsc_env) noPrint})+         runReaderT action           =<< initialDebuggerState dbgLog               (if loadedBuiltinModNames == []                 then Nothing                 else Just hdv_uid) -    fwd_thr <- liftIO $ async (void externalInterpFwdThread)-    liftIO $ link fwd_thr-    mainGhcThread+    case conf.externalInterpreterCustomProc of+      Left _ -> do+        -- We launched the external interpreter ourselves, so forward its output to the logger.+        withUnliftGhc $ \ unlift -> do+          withAsync (void externalInterpFwdThread) $ \ fwd_thr -> do+            liftIO $ link fwd_thr+            unlift mainGhcThread+      Right _ ->+        -- Ext interp is running in user terminal, no need to forward output to logger+        mainGhcThread  {-+Note [Shutting down the external interpreter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Ghc monad execution (under `runGhc`) sometimes terminates abruptly:+- When the DebugAdapter exits (e.g. disconnect, terminate, error, ...), it+  calls `destroyDebugSession`, which will *kill* the thread running the+  debugger/Ghc session.+- When there is some exception thrown in the Ghc monad itself++GHC wraps the `Ghc` action run with `withCleanupSession`, which is responsible+for e.g. removing temporary files and cleanly terminating the external+interpreter process, if one is being used.++GHC first checks with `getProcessExitCode` the status of the external+interpreter, does nothing if there is some exit status, and kills the external+process otherwise.++However, this check is incorrect(!) when the external interpreter process is+not a child of this process (which will happen in the runInTerminal external+interpreter case). `getProcessExitCode` should error with `ECHILD` in this case+(see `man 2 wait`), even if it doesn't yet (see process#359).++Therefore, the debugger must step in and make sure the external interpreter is+exited cleanly, WITHOUT resorting to `getProcessExitCode`. To this effect, we+add our own `MC.finally cleanupInterp` call which sends the `Shutdown` message+to the external interpreter before propagating the exception further (to GHC's+`withCleanupSession`, which will now do Nothing because we set `InterpPending`,+and beyond).++Note [Must explicitly expose module graph units]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`interactiveGhcDebugger` is our "current home unit", so its+`UnitState{moduleNameProvidersMap}` will determine which modules we can import+interactively (i.e. with GHC.setContext).++The `moduleNameProvidersMap` has so far only been required to expose, with+`ExposePackage` flags, the other home units. However, exposing a package **does+not** imply exposing its dependencies, so `mkUnitState` was free to choose+versions/abis for us, e.g., expose haskell-debugger-view-0.2.1.0-... and hide+haskell-debugger-view-0.2.0.0-..., while the latter is the one in the graph. We+noticed with `hdv` but the above can happen with any dep of the debuggee,+causing problems at the prompt.++Here we explicitly grab the units from the graph and make them exposed, so if we+find a unit in the graph we should be able to import exposed modules from it,+and importing modules at the prompt should use the versions the debuggee depends+on.++An alternative, closer to what ghci does, would be to copy the `packageFlags`+from the debuggee units, however doing so doesn't take care of fixing a unitId+for dependencies of dependencies.++Note [Do not package-qualify imports for home units]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A package-qualified module import will be looked up directly in the exposed+packages, IGNORING the home units modules.++This can lead to two scenarios:++  1) a package-import of a loaded unit fails, because that unit, despite being+  loaded, is not installed++  2) a package-import of a loaded unit succeeds, because a unit with the same+  name (but not necessarily the same unit-id!), is installed.++The second case can result in subtly wrong interactive sessions, where the+package-qualified imported module shadows the loaded module. Perhaps GHC could+warn about this. Cabal-repl and ghci also suffer from this subtle interaction.++In light of this, when the debugger imports the `haskell-debugger-view` modules,+it is imperative that if the `haskell-debugger-view` unit is in the home units+(e.g. if `haskell-debugger-view` is listed in the cabal.project, like it is in+the debugger tree), we do not use a package-qualified import.++On the other hand, if the `haskell-debugger-view` package is not in the+home-units, we *should* package-qualify it to make sure we reference the right+one.++See also #283+-}++-- | See Note [Shutting down the external interpreter]+cleanupInterp :: Ghc ()+cleanupInterp = do+  interp <- hscInterp <$> getSession+  case interpInstance interp of+    InternalInterp -> pure ()+    ExternalInterp ext -> liftIO $ withExtInterpStatus ext $ \mstate -> do+      MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do+        case state of+          InterpPending    -> pure state -- already stopped+          InterpRunning i  -> do+            -- Can't use  `getProcessExitCode` because the interp process is+            -- not necessarily a child of this process (runInTerminal case).+            -- Just unconditionally try to send the message.+            sendMessage i Shutdown+            pure InterpPending++-- | WARNING: callback is not to be used from other threads.+withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a+withUnliftGhc k = reifyGhc $ \ s -> k (flip reflectGhc s)++annotateDebuggerStackString :: String -> Debugger a -> Debugger a+annotateDebuggerStackString s (Debugger m) = Debugger $ do+  r <- ReaderT $ \val -> do+    withUnliftGhc $ \ unlift ->+      annotateStackStringIO s (unlift $ runReaderT m val)+  pure r++-- | Variant of GHC's parseDynamicFlags which interprets paths relative to first arg.+parseDynamicFlagsWithRootDir+    :: MonadIO m+    => FilePath+    -> Logger+    -> DynFlags+    -> [Located String]+    -> m (DynFlags, [Located String], Messages DriverMessage)+parseDynamicFlagsWithRootDir rootDir logger dflags cmdline = do+  (dflags1', leftovers, warns) <- parseDynamicFlagsCmdLine logger dflags cmdline+  -- flags that have just been read are used by the logger when loading package+  -- env+  let dflags1 = makeDynFlagsAbsoluteOverall rootDir dflags1'+  let logger1 = GHC.setLogFlags logger (initLogFlags dflags1)+  dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1+  return (dflags2, leftovers, warns)++-- | Make an 'ExtInterpInstance' based on an external interpreter process that+-- was launched by the DAP client via 'runInTerminal'. The process sends its+-- own PID as the first line on the socket before the GHCi wire protocol+-- begins.+extInterpFromTerminalProcess :: PortNumber -> IO Interp+extInterpFromTerminalProcess port = do+  putStrLn $ "Trying to connect to " ++ show port+  Control.Exception.bracketOnError+    (openListener port >>= accept)+    (\ (sock,_) -> close sock)+    (\ (sock,_) -> do+      bi_h <- socketToHandle sock ReadWriteMode++      pidLine <- annotateCallStackIO $ hGetLine bi_h++      pid <- case readMaybe pidLine :: Maybe Int of+        Just pid -> pure pid+        Nothing  -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine+      ph <- mkProcessHandle (fromIntegral pid) False+      interpPipe <- mkPipeFromHandles bi_h bi_h+      lock <- newMVar ()+      let process = InterpProcess+                      { interpHandle = ph+                      , interpPipe+                      , interpLock   = lock+                      }++      pending_frees <- newMVar []+      let inst = ExtInterpInstance+            { instProcess           = process+            , instPendingFrees      = pending_frees+            , instExtra             = ()+            }+          conf = IServConfig+            { iservConfProgram  = "the process is already running, we should never need to run it again"+            , iservConfOpts     = []+              -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger]+            , iservConfDynamic  = hostIsDynamic+            , iservConfProfiled = hostIsProfiled+            , iservConfHook     = Nothing -- it's already running!+            , iservConfTrace    = pure ()+            }++      lookup_cache <- mkInterpSymbolCache+      s            <- newMVar $ InterpRunning inst+      loader       <- Loader.uninitializedLoader+#if MIN_VERSION_ghc(9,15,0)+      fs_cache     <- newMVar emptyFsEnv+      return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache)+#else+      return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)+#endif+      )++openListener :: PortNumber -> IO Socket+openListener port = do+  addr <- socketAddressFromPort port+  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+  -- Must set before bind!+  setSocketOption sock ReuseAddr 1++  bind sock (addrAddress addr)+  listen sock maxListenQueue++  return sock++socketAddressFromPort :: PortNumber -> IO AddrInfo+socketAddressFromPort port = do+  let+    hints = defaultHints+      { addrSocketType = Stream+      , addrFlags = [AI_PASSIVE]  -- For wildcard IP (0.0.0.0 or ::)+      , addrFamily = AF_UNSPEC    -- Allow IPv4 or IPv6+      }+  addrs <- getAddrInfo (Just hints) Nothing (Just (show port))+  case addrs of+    addr : _ -> pure addr+    [] -> fail ("Could not resolve address for external interpreter port " ++ show port)++{- Note [Custom external interpreter] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We compile a custom external interpreter server with custom commands which make@@ -484,7 +765,28 @@   hSetBuffering stdout LineBuffering   hSetBuffering stderr LineBuffering +When launching the external interpreter directly attached to the user's+terminal (via runInTerminal), the handles will indeed be connected to a TTY.+ [1] https://ftp.gnu.org/old-gnu/Manuals/glibc-2.2.5/html_node/Buffering-Concepts.html++Note [Dynamic dependencies for dynamic debugger]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the external interpreter running the debuggee is a dynamically-linked+program compiled with -fPIC, it is of utmost importance that the libraries we+load (e.g. base, ghc-internal, etc) are ALSO compiled with -fPIC. Otherwise, we+end up with the same SIGILL scenario of Note [Dynamic Debuggee for dynamic debugger].++In #260, we battled with another SIGILL for over a week because of this.+Namely, we forgot to configure the external interpreter's+IServConfig.iservConfDynamic (and had hardcoded it to False!!).++When loading a package to the external interpreter, GHC will consult+`iservConfDynamic` on whether to LoadDLL (dynamic lib) or LoadArchive (static+archive). This setting must definitely match the way in which the external+interpreter was compiled (checked with `hostIsDynamic`, since the external+interpreter and the debugger, while not necessarily the same process, are the+same executable). Ditto for `iservConfProfiled` (with `hostIsProfiled`). -} -------------------------------------------------------------------------------- @@ -494,11 +796,7 @@             -> m ModuleGraph -- ^ Module graph constructed from current set targets doDownsweep reuse_mg = do   hsc_env <- getSession-#if MIN_VERSION_ghc(9,15,0)-  let msg = batchMultiMsg hsc_env-#else   let msg = batchMultiMsg-#endif   (errs_base, mod_graph) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic (Just msg) (maybe [] mgModSummaries reuse_mg) [] False   when (not $ null errs_base) $ do #if MIN_VERSION_ghc(9,15,0)@@ -511,11 +809,7 @@  doLoad :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> ModuleGraph -> m SuccessFlag doLoad if_cache how_much mg = do-#if MIN_VERSION_ghc(9,15,0)-  msg <- batchMultiMsg <$> getSession-#else   let msg = batchMultiMsg-#endif   load' if_cache how_much mkUnknownDiagnostic (Just msg) mg  -- | Returns @Just modName@ if the given module was successfully loaded@@ -583,14 +877,16 @@   hsc_env <- getSession   let unitState = hsc_units hsc_env -  -- Only looks at unit-nodes, this is not robust!-  -- TODO: Better lookup of unit-id-  let hskl_dbgr_vws =+  -- Note: linear in the module graph but only happens once.+  let potential_units = graphUnits mod_graph+  -- Note: the intermediate set is expected to be small (<= 2).+  let hskl_dbgr_vws = Set.toList . Set.fromList $         [ uid-        | UnitNode _deps uid <- mg_mss mod_graph-        , "haskell-debugger-view" `L.isPrefixOf` unitIdString uid-            || "hskll-dbggr-vw" `L.isPrefixOf` unitIdString uid-            || "haskell-debug_" `L.isPrefixOf` unitIdString uid+        | uid <- potential_units+        , let uid_s = unitIdString uid+        , "haskell-debugger-view" `L.isPrefixOf` uid_s+            || "hskll-dbggr-vw" `L.isPrefixOf` uid_s+            || "haskell-debug_" `L.isPrefixOf` uid_s         ]        -- If the haskell-debugger-view is in the dependency graph, it must have@@ -601,19 +897,23 @@   case hskl_dbgr_vws of     [hdv_uid] -> do       -- In transitive closure, use that one.-      -- Check that the version is exactly 0.2.0.0+      -- Check that the version is in supported range.       case lookupUnit unitState (RealUnit (Definite hdv_uid)) of         Just unitInfo -> do           let version = unitPackageVersion unitInfo           if any (\(l,h) -> l <= version && version < h) supported_ranges             then return (Just hdv_uid)             else throwM UnsupportedHsDbgViewVersion{supportedVersions=supported_ranges, actualVersion=version}+        Nothing+          | "inplace" `L.isSuffixOf` unitIdString hdv_uid+          -- will be built as a target later+          -> return (Just hdv_uid)         Nothing ->           error "Could not find unit info for haskell-debugger-view"     [] -> do       return Nothing-    _  ->-      error "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!"+    _  -> do+      error $ "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!" ++ showSDocUnsafe (withPprStyle (PprDump alwaysQualify) (ppr hskl_dbgr_vws))  -------------------------------------------------------------------------------- -- Utilities@@ -686,7 +986,11 @@     unit_env = hsc_unit_env hsc_env   case term of     Suspension{val, ty} -> do+#if MIN_VERSION_ghc(9,15,0)+      r <- GHCi.seqHValue interp unit_env (hsc_logger hsc_env) val+#else       r <- GHCi.seqHValue interp unit_env val+#endif       () <- fromEvalResult r       let         forceThunks = False {- whether to force the thunk subterms -}@@ -708,6 +1012,7 @@                  -> do wrapped_term' <- deepseqTerm hsc_env wrapped_term                        return t{wrapped_term = wrapped_term'}   _              -> do seqTerm hsc_env t+  -------------------------------------------------------------------------------- -- * Logging

@@ -21,13 +21,35 @@ import System.FilePath import System.Directory -import GHC+import GHC qualified+import GHC (+  ExecOptions (..),+  ExecResult (..),+  execStmt',+  ForeignHValue,+  GhciLStmt,+  GhcPs,+  InteractiveImport (..),+  mkHsString,+  ModSummary (..),+  Name,+  nlHsLit,+  nlList,+  parseImportDecl,+  SingleStep (..),+  SrcSpan (..),+  StmtLR (..),+  unLoc,+  )+import GHC.Plugins (SourceError) import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS) import GHC.Unit.Types import GHC.Data.FastString import GHC.Driver.DynFlags as GHC+import GHC.Driver.Main (hscParseStmtWithLocation) import GHC.Driver.Monad as GHC import GHC.Driver.Env as GHC+import qualified GHC.Driver.Config.Parser as GHC import GHC.Runtime.Debugger.Breakpoints as GHC import qualified GHC.Unit.Module.ModSummary as GHC import GHC.Types.Name.Occurrence (mkVarOccFS)@@ -42,6 +64,7 @@ import Colog.Core as Logger import qualified GHC.Debugger.Breakpoint.Map as BM import GHC.Debugger.Runtime.Thread+import GHC.Debugger.Session (setInteractiveDebuggerDynFlags, getInteractiveDebuggerDynFlags, resumeExec)  -------------------------------------------------------------------------------- -- * Evaluation@@ -61,6 +84,7 @@                                          (moduleName modOfEntryFile)    logSDoc Logger.Debug $ "Eval Module Context:" <+> ppr evalModule+   old_context <- GHC.getContext   GHC.setContext [GHC.IIModule evalModule] @@ -121,13 +145,13 @@ -- | Resume execution of the stopped debuggee program doContinue :: Debugger EvalResult doContinue = do-  GHC.resumeExec RunToCompletion Nothing+  resumeExec RunToCompletion Nothing     >>= handleExecResult  -- | Resume execution but only take a single step. doSingleStep :: Debugger EvalResult doSingleStep = do-  GHC.resumeExec SingleStep Nothing+  resumeExec SingleStep Nothing     >>= handleExecResult  doStepOut :: Debugger EvalResult@@ -135,13 +159,13 @@   mb_span <- getCurrentBreakSpan   case mb_span of     Nothing ->-      GHC.resumeExec (GHC.StepOut Nothing) Nothing+      resumeExec (GHC.StepOut Nothing) Nothing         >>= handleExecResult     Just loc -> do       md <- fromMaybe (error "doStepOut") <$> getCurrentBreakModule       ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md       let current_toplevel_decl = enclosingTickSpan ticks loc-      GHC.resumeExec (GHC.StepOut (Just (RealSrcSpan current_toplevel_decl Strict.Nothing))) Nothing+      resumeExec (GHC.StepOut (Just (RealSrcSpan current_toplevel_decl Strict.Nothing))) Nothing         >>= handleExecResult  -- | Resume execution but stop at the next tick within the same function.@@ -157,43 +181,113 @@     Nothing -> error "not stopped at a breakpoint?!"     Just (UnhelpfulSpan _) -> do       liftIO $ putStrLn "Stopped at an exception. Forcing step into..."-      GHC.resumeExec SingleStep Nothing >>= handleExecResult+      resumeExec SingleStep Nothing >>= handleExecResult     Just loc -> do       md <- fromMaybe (error "doLocalStep") <$> getCurrentBreakModule       -- TODO: Cache moduleLineMap?       ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md       let current_toplevel_decl = enclosingTickSpan ticks loc-      GHC.resumeExec (LocalStep (RealSrcSpan current_toplevel_decl mempty)) Nothing >>= handleExecResult+      resumeExec (LocalStep (RealSrcSpan current_toplevel_decl mempty)) Nothing >>= handleExecResult +-- | Generalized `doEval` that also handles `imports`+doEvalCommand :: String -> Debugger EvalResult+doEvalCommand expr = do+  dflags <- getInteractiveDebuggerDynFlags+  let pflags = GHC.initParserOpts dflags+  if GHC.isStmt pflags expr+    then doEval expr+    else addImport expr++-- | Parses input as an import declaration and applies it to the interactive context.+addImport :: String -> Debugger EvalResult+addImport s = handleError $ do+  cxt <- GHC.getContext+  idecl <- parseImportDecl s+  GHC.setContext $ IIDecl idecl : cxt+  pure $ EvalCompleted "" "" Nothing NoVariables+  where+    handleError m = m `catch` \ (e::SourceError) -> do+      pure $ EvalAbortedWith $ displayException e+ -- | Evaluate expression. Includes context of breakpoint if stopped at one (the current interactive context). doEval :: String -> Debugger EvalResult-doEval expr = do-  excr <- (Right <$> GHC.execStmt expr GHC.execOptions) `catch` \(e::SomeException) -> pure (Left (displayException e))+doEval expr = withCurrentBreakExtensions $ do+  excr <- (Right <$> exec expr GHC.execOptions) `catch` \(e::SomeException) -> pure (Left (displayException e))   case excr of     Left err -> pure $ EvalAbortedWith err-    Right ExecBreak{} -> continueToCompletion >>= handleExecResult-    Right r@ExecComplete{} -> handleExecResult r+    Right (k, ExecBreak{}) -> fmap (addSourceKind k) $ continueToCompletion >>= handleExecResult+    Right (k, r@ExecComplete{}) -> fmap (addSourceKind k) $ handleExecResult r+  where+    exec input exec_opts@ExecOptions{..} = do+      hsc_env <- getSession +      mb_stmt <-+        liftIO $+        runInteractiveHsc hsc_env $+        hscParseStmtWithLocation execSourceFile execLineNumber input++      case mb_stmt of+        -- empty statement / comment+        Nothing -> return (IsStmt, ExecComplete (Right []) 0)+        Just stmt -> (,) <$> stmtKind stmt <*> execStmt' stmt input exec_opts++    stmtKind (stmt :: GhciLStmt GhcPs) = do+      pure $ case unLoc stmt of+        BodyStmt{} -> IsExpr+        _ -> IsStmt++    addSourceKind :: SourceKind -> EvalResult -> EvalResult+    addSourceKind k EvalCompleted{..} = EvalCompleted{resultSourceKind = Just k, ..}+    addSourceKind _ r = r+ -- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'. -- -- We use this in 'doEval' because we want to ignore breakpoints in expressions given at the prompt. continueToCompletion :: Debugger GHC.ExecResult continueToCompletion = do-  execr <- GHC.resumeExec GHC.RunToCompletion Nothing+  execr <- resumeExec GHC.RunToCompletion Nothing   case execr of     GHC.ExecBreak{} -> continueToCompletion     GHC.ExecComplete{} -> return execr +-- | @withCurrentBreakExtensions m@ executes @m@ with the language and language+--  extensions of the current breakpoint source module.+--+--  If we are not stopped at a breakpoint @m@ is executed with no change.+withCurrentBreakExtensions :: Debugger a -> Debugger a+withCurrentBreakExtensions m = do+  mmodl <- getCurrentBreakModule+  case mmodl of+    Nothing          -> m+    Just breakModule -> do+      ic_dyn_flags <- getInteractiveDebuggerDynFlags+      break_dyn_flags <- ms_hspp_opts <$> GHC.getModSummary breakModule+      setInteractiveDebuggerDynFlags $ adjustFlags ic_dyn_flags break_dyn_flags+      x <- m+      setInteractiveDebuggerDynFlags ic_dyn_flags+      return x+  where+    -- Possibly we might want to include more from the module's DynFlags.+    -- However some are likely to mess with the REPL, e.g. Opt_WarnTypeDefaults,+    -- Opt_HideAllPackages, Opt_NoIt. See discussion at+    -- https://github.com/well-typed/haskell-debugger/pull/230#discussion_r2986758826+    adjustFlags :: DynFlags -> DynFlags -> DynFlags+    adjustFlags ic modl = ic+      { extensions = extensions modl+      , extensionFlags = extensionFlags modl+      , language = language modl+      }+ -- | Turn a GHC's 'ExecResult' into an 'EvalResult' response handleExecResult :: GHC.ExecResult -> Debugger EvalResult handleExecResult = \case     ExecComplete {execResult} -> do       case execResult of         Left e -> return (EvalException (show e) "SomeException")-        Right [] -> return (EvalCompleted "" "" NoVariables) -- Evaluation completed without binding any result.+        Right [] -> return (EvalCompleted "" "" Nothing NoVariables) -- Evaluation completed without binding any result.         Right (n:_ns) -> inspectName n >>= \case           Just VarInfo{varValue, varType, varRef} -> do-            return (EvalCompleted varValue varType varRef)+            return (EvalCompleted varValue varType Nothing varRef)           Nothing     -> liftIO $ fail "doEval failed"     ExecBreak {breakNames = _, breakPointId = Nothing} -> do       -- Stopped at an exception@@ -202,37 +296,54 @@       return EvalStopped{ breakId = Nothing                         , breakThread = rt_id }     ExecBreak {breakNames = _, breakPointId = Just bid} -> do++      let performAction BreakpointStop = do++                rt_id <- getRemoteThreadIdFromContext+                return EvalStopped{ breakId = Just bid+                                  , breakThread = rt_id }+          performAction (BreakpointLogAndResume logExpr) = do+            let evalFailedMsg e = text $ unlines ["Evaluation of log message expression failed with " ++ e+                  , "Expr: " ++ logExpr+                  , "Ignoring..."]+            doEval' logExpr evalFailedMsg $ \ _ _ -> resume+       bm <- liftIO . readIORef =<< asks activeBreakpoints       case BM.lookup bid bm of-        -- todo: BreakpointAfterCountCond is not handled yet.-        Just (BreakpointWhenCond cond, _) -> do-          let evalFailedMsg e = text $ "Evaluation of conditional breakpoint expression failed with " ++ e ++ "\nIgnoring..."-          let resume = GHC.resumeExec GHC.RunToCompletion Nothing >>= handleExecResult-          doEval cond >>= \case+        -- When stepping (`GHC.resumeExec SingleStep` or similar), we will typically stop at locations not explicitly enabled by the user (i.e. not registered in `activeBreakpoints`).+        Nothing -> performAction BreakpointStop+        Just BreakpointInfo{bpInfoStatus = status, bpInfoAction = action} -> do+          case status of+           -- todo: BreakpointAfterCountCond is not handled yet.+            BreakpointAfterCountCond{} -> performAction action+            BreakpointWhenCond cond -> do+              let evalFailedMsg e = text $ "Evaluation of conditional breakpoint expression failed with " ++ e ++ "\nIgnoring..."++              doEval' cond evalFailedMsg $ \ resultVal resultType -> do+                if resultType == "Bool" then do+                  if resultVal == "True" then do+                    performAction action+                  else+                    resume+                else do+                  logSDoc Logger.Warning (evalFailedMsg "\"expression resultType is != Bool\"")+                  resume+            BreakpointDisabled -> resume+            -- The counting is handled by @GHC.setupBreakpoint@+            BreakpointAfterCount _ -> performAction action+            BreakpointEnabled -> performAction action+  where+    doEval' expr evalFailedMsg k = doEval expr >>= \case             EvalStopped{} -> error "impossible for doEval"             EvalCompleted { resultVal, resultType } ->-              if resultType == "Bool" then do-                if resultVal == "True" then do-                  rt_id <- getRemoteThreadIdFromContext-                  return EvalStopped{ breakId = Just bid-                                    , breakThread = rt_id }-                else-                  resume-              else do-                logSDoc Logger.Warning (evalFailedMsg "\"expression resultType is != Bool\"")-                resume+              k resultVal resultType             EvalException { resultVal } -> do               logSDoc Logger.Warning (evalFailedMsg resultVal)               resume             EvalAbortedWith e -> do               logSDoc Logger.Warning (evalFailedMsg e)               resume--        -- Unconditionally 'EvalStopped' in all other cases-        _ -> do-          rt_id <- getRemoteThreadIdFromContext-          return EvalStopped{ breakId = Just bid-                            , breakThread = rt_id }+    resume = resumeExec GHC.RunToCompletion Nothing >>= handleExecResult  -- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'. inspectName :: Name -> Debugger (Maybe VarInfo)@@ -241,7 +352,9 @@     Nothing -> do       liftIO . putStrLn =<< display (text "Failed to lookup name: " <+> ppr n)       pure Nothing-    Just tt -> Just <$> tyThingToVarInfo tt+    Just tt -> Just <$> do+      fam_envs <- getFamInstEnvs'+      tyThingToVarInfo fam_envs tt  getRemoteThreadIdFromContext :: Debugger RemoteThreadId getRemoteThreadIdFromContext = do

@@ -1,5 +1,9 @@ {-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments, OrPatterns #-}-module GHC.Debugger.Runtime.Instances where+module GHC.Debugger.Runtime.Instances+  ( debugValueTerm+  , debugFieldsTerm+  , VarValueResult(..)+  ) where  import GHC import GHC.Driver.Env@@ -23,16 +27,16 @@ -- | Get the custom representation of this 'Term' by applying a 'DebugView' -- instance 'debugValue' method if there is one. debugValueTerm :: Term -> Debugger (Maybe VarValueResult)-debugValueTerm term@(Suspension{} ; Term{}) = do+debugValueTerm term = do   hsc_env <- getSession   let interp = hscInterp hsc_env   let ty = termType term   mbInst <- getDebugViewInstance ty-  case mbInst of+  case (,) <$> maybe_hval term <*> mbInst of     Nothing -> return Nothing-    Just DebugViewInstance-      {instDebugValue, varValueIOTy} -> do-        liftIO (instDebugValue (val term)) >>= \case+    Just (hval, DebugViewInstance+      {instDebugValue, varValueIOTy}) -> do+        liftIO (instDebugValue hval) >>= \case           Left _e ->             -- exception! ignore.             return Nothing@@ -54,12 +58,8 @@                   _ -> do                     logSDoc Logger.Warning (text "debugValueTerm(2): Expecting" <+> ppr strTerm <+> text "to be a Term or Suspension.")                     return Nothing-debugValueTerm term = do-  logSDoc Logger.Warning (text "debugValueTerm: Expecting" <+> ppr term <+> text "to be a Term or Suspension.")-  return Nothing  - -- | Get the custom representation of this 'Term' by applying a 'DebugView' -- instance 'debugFields' method if there is one. --@@ -68,14 +68,14 @@ -- -- Returns @Nothing@ if no instance was found for the type of the given term debugFieldsTerm :: Term -> Debugger (Maybe [(String, Term)])-debugFieldsTerm term@(Suspension{} ; Term{}) = do+debugFieldsTerm term = do   let ty = termType term   mbInst <- getDebugViewInstance ty-  case mbInst of+  case (,) <$> maybe_hval term <*> mbInst of     Nothing -> return Nothing-    Just DebugViewInstance-      {instDebugFields, varFieldsIOTy} -> do-        liftIO (instDebugFields (val term)) >>= \case+    Just (hval, DebugViewInstance+      {instDebugFields, varFieldsIOTy}) -> do+        liftIO (instDebugFields hval) >>= \case           Left _e ->             -- exception! ignore.             return Nothing@@ -84,6 +84,15 @@             obtainParsedTerm "VarFields" 2 True varFieldsIOTy transformed_v varFieldsParser >>= \case               Left _ -> pure Nothing               Right res -> pure (Just res)-debugFieldsTerm term = do-  logSDoc Logger.Warning (text "debugValueTerm: Expecting" <+> ppr term <+> text "to be a Term or Suspension.")-  return Nothing++-- | The heap value of the Term the debugView instance methods are applied to+-- (looks through newtypes). For Primitive types and primitive References,+-- assume dbgInst methods can't be applied to them.+maybe_hval :: Term -> Maybe ForeignHValue+maybe_hval t = case t of+  Suspension{val} -> Just val+  Term{val}       -> Just val+  NewtypeWrap{wrapped_term}+                  -> maybe_hval wrapped_term+  Prim{}          -> Nothing+  RefWrap{}       -> Nothing

@@ -0,0 +1,122 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE ViewPatterns #-}++-- | Custom interpreter commands in addition to the existing+-- 'GHC.Runtime.Interpreter' ones.+--+-- Similarly to 'GHC.Runtime.Interpreter', the functions in this module+-- abstract whether the external or internal interpreter is being used.+--+-- When using the external interpreter, we leverage the "Custom external commands"+-- feature introduced in GHC 10.0's ghci API to extend the external interpreter+-- server with custom command messages and handlers. When using+--+-- In GHC 9.14, there isn't support for extending the external interpreter server with new commands.+-- Thus, it is impossible to get the external interpreter to execute custom+-- code. When custom commands aren't available for the external interpreter we+-- fallback to an implementation which uses more primitive functions on the+-- external interpreter, decode the heap values directly into 'Term', and use+-- 'GHC.Debugger.Runtime.Term.Parser' to parse the heap 'Term's into structured+-- data. That implementation doesn't live in this module, which is meant only+-- to be the interface to the custom commands supported by GHC > 9.14.+--+-- When using the internal interpreter, we can execute the custom command+-- handler directly in this process -- regardless of whether using GHC 9.14 or GHC 10.0.+-- In practice, for simplicity, we just use the fallback mechanism of 9.14 for both internal and external.+--+-- The custom commands and their handlers are implemented in+-- 'GHC.Debugger.Runtime.Interpreter.Custom'+--+-- Meant to be imported with+--+-- @+-- import qualified GHC.Debugger.Runtime.Interpreter as Debuggee+-- @+--+-- since the exported+-- functions run on the debuggee (possibly external) process. Even on GHC 9.14,+-- where we use more primitive messages and do some extra parsing on the+-- debugger/host side+module GHC.Debugger.Runtime.Interpreter+  ( listThreads+  , decodeThreadStack+  , collectExceptionInfo++  -- * Re-exports+  , ThreadInfo(..)+  ) where++import Control.Monad+import Control.Monad.IO.Class++import GHCi.RemoteTypes+import GHC.Debugger.Monad++import GHC.Debugger.Interface.Messages (ExceptionInfo)+import GHC.Debugger.Runtime.Interpreter.Custom++import Data.Binary+import GHC.Driver.Env (hscInterp)+import GHC.Driver.Monad (getSession)+import GHC.Runtime.Interpreter+import Control.Concurrent+import Control.Exception++--------------------------------------------------------------------------------+-- * Debugger abstraction+--+-- | The functions in this section need to be in 'Debugger' because the+-- 'TermParser' (needed to implement these top-level functions in GHC 9.14)+-- works in 'Debugger'. This also allows us to call debugger-interpreter+-- functions without 'liftIO' everywhere.+--------------------------------------------------------------------------------++listThreads :: Debugger [ThreadInfo ForeignRef]+listThreads = do+  interp  <- hscInterp <$> getSession+  ts_info <- liftIO $ interpDbgCmd interp ListThreads+  forM ts_info $ \ti@ThreadInfo{threadInfoRef} -> do+    threadInfoForeignRef <- liftIO $ mkFinalizedHValue interp threadInfoRef+    pure ti{threadInfoRef = threadInfoForeignRef}++decodeThreadStack :: ForeignRef ThreadId -> Debugger [StackFrameInfo]+decodeThreadStack ftid = do+  interp  <- hscInterp <$> getSession+  liftIO $ withForeignRef ftid $+    interpDbgCmd interp . DecodeThreadStack++collectExceptionInfo :: ForeignRef SomeException -> Debugger ExceptionInfo+collectExceptionInfo excRef = do+  interp <- hscInterp <$> getSession+  liftIO $ withForeignRef excRef $+    interpDbgCmd interp . CollectExceptionInfo++--------------------------------------------------------------------------------+-- * IO+interpreter abstraction+--+-- | Functions on IO which abstract calling the external interpreter or+-- internal interpreter using custom commands. Note that 'CustomMessage' is not+-- available in GHC 9.14 so we don't make these functions available in GHC 9.14+--------------------------------------------------------------------------------++-- | Run a 'DbgInterpCmd' in the interpreter's context. By default, the command is+-- serialized and sent to an external iserv process, and the response is+-- deserialized (hence the @Binary@ constraint). With @--internal-interpreter@+-- we execute the command directly here.+--+-- To run a builtin 'Message' command, use 'interpCmd' instead.+interpDbgCmd :: Binary a => Interp -> DbgInterpCmd a -> IO a+interpDbgCmd interp command = case interpInstance interp of+  InternalInterp ->+    -- Run it directly on this process!+    runDbgInterpCmd command+  ExternalInterp{}+    -- Use interpCmd to send the command as a custom message to external process.+    -- The custom message will be processed according to the custom command+    -- handlers registered with `iservWithCustom`+    | let payload = encodePayload (Some @Binary command) -> do+      respBytes <- interpCmd interp (CustomMessage dbgInterpCmdTag payload)+      case decodePayload respBytes of+        Left err -> fail err+        Right r  -> pure r

@@ -0,0 +1,367 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeAbstractions #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- necessary Binary instances+module GHC.Debugger.Runtime.Interpreter.Custom where++import GHC.Generics (Generic)++import GHCi.Message+import GHCi.RemoteTypes++import qualified Data.Binary as Bin+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Bits+import Foreign.C.String+import GHC.ByteCode.Types+import GHC.Conc.Sync+import GHC.Exts.Heap.Closures (StackFrame, GenStackFrame (..), Box (..))+import GHC.InfoProv+import GHC.Runtime.Interpreter (evalBreakpointToId)+import GHC.Stack.Annotation.Experimental+import GHC.Utils.Encoding.UTF8 (utf8EncodeShortByteString)+import GHC.Word+import Unsafe.Coerce (unsafeCoerce, unsafeCoerce#)+import qualified GHC.Base+import qualified GHC.Exts+import qualified GHC.Exts.Heap as Heap+import qualified GHC.Stack as Stack+import GHC.Unit.Module+import Control.Exception+import GHC.Debugger.Interface.Messages (SourceSpan (..), ExceptionInfo (..))+import Control.Exception.Context+import Data.Typeable+#if MIN_VERSION_ghc(9,15,0)+import GHC.Debugger.Interface.Messages (srcLocToSourceSpan)+import Data.Maybe+import Control.Exception.Backtrace+import GHC.Exception+import qualified GHC.Stack.CloneStack as Stack+import qualified GHC.Stack.Decode.Experimental as Stack+import qualified GHC.Exception.Backtrace.Experimental as Backtrace+#endif++--------------------------------------------------------------------------------+-- * Custom Commands+--------------------------------------------------------------------------------++data ThreadInfo ref = ThreadInfo+  { threadInfoRef    :: !(ref ThreadId)+  , threadInfoLabel  :: !(Maybe String)+  , threadInfoStatus :: !ThreadStatus+  }+  deriving (Generic)++-- | Information about a stack frame+data StackFrameInfo+  -- | Information derived from an IPE entry+  = StackFrameIPEInfo !InfoProv+  -- | User-defined Stack Frame annotation+  | StackFrameAnnotation !(Maybe Stack.SrcLoc) !String+  -- | Information derived from a continuation BCO breakpoint info.+  | StackFrameBreakpointInfo !InternalBreakpointId+  deriving (Generic)++data DbgInterpCmd a where+  ListThreads :: DbgInterpCmd [ThreadInfo RemoteRef]+  DecodeThreadStack :: RemoteRef ThreadId -> DbgInterpCmd [StackFrameInfo]+  CollectExceptionInfo :: RemoteRef SomeException -> DbgInterpCmd ExceptionInfo++dbgInterpCmdTag :: Word8+dbgInterpCmdTag = 0x25++--------------------------------------------------------------------------------+-- * Running and handlers+--------------------------------------------------------------------------------++-- | Run a custom 'DbgInterpCmd' directly.+runDbgInterpCmd :: DbgInterpCmd a -> IO a+runDbgInterpCmd = \case+  ListThreads -> mapM threadInfo =<< listThreads+#if MIN_VERSION_ghc(9,14,2)+  -- decodeStackWithIpe exposed from 9.14.2 onwards (see #27065)+  DecodeThreadStack threadIdRef -> do+    -- We clone the stack of the thread and decode it in the external interpreter to avoid+    -- any potential issues with decoding the stack in the main interpreter, which can be+    -- more fragile due to optimizations and other factors. This also allows us to leverage+    -- the existing machinery for decoding stacks in the external interpreter, which is more+    -- robust and can handle a wider variety of cases.+    threadId    <- localRef threadIdRef+    clonedStack <- Stack.cloneThreadStack threadId+    frames      <- Stack.decodeStackWithIpe clonedStack+    catMaybes <$> mapM stackFrameInfo frames+#else+  DecodeThreadStack _ -> fail "Decoding thread stacks is not supported on GHC versions prior to 9.14.2, which exposes the necessary decodeStackWithIpe functions. Please upgrade to GHC 9.14.2 or later to use this feature."+#endif+  CollectExceptionInfo excRef -> do+    exc  <- localRef excRef+    let info = exceptionInfo exc+    return info+++-- | Run a serialized custom 'DbgInterpCmd'. This is used in conjunction with+-- 'servWithCustom' to handle custom messages sent to the external interpreter.+dbgInterpCmdHandler :: Word8 -> BS.ByteString -> IO (Maybe BS.ByteString)+dbgInterpCmdHandler tag payload+  | tag == dbgInterpCmdTag =+      case decodePayload payload of+        Left err ->+          fail ("Failed to decode debugger thread command payload: " ++ err)+        Right (Some @Bin.Binary command) ->+          Just . encodePayload <$> runDbgInterpCmd command+  | otherwise =+      pure Nothing++--------------------------------------------------------------------------------+-- * Implementing each command+--------------------------------------------------------------------------------++-- | Read some info about a Thread from its 'ThreadId'+threadInfo :: ThreadId -> IO (ThreadInfo RemoteRef)+threadInfo threadId = do+  status <- threadStatus threadId+  ref    <- mkRemoteRef threadId+  label  <- threadLabel threadId+  pure ThreadInfo+    { threadInfoRef    = ref+    , threadInfoLabel  = label+    , threadInfoStatus = status+    }++-- | Try to make a 'StackFrameInfo' out of the decoded stack frame information:+--+-- 1. Try stack annotations first+-- 2. Try IPE next+-- 3. Try decoding a continuation BCO with a breakpoint next+stackFrameInfo :: (StackFrame, Maybe InfoProv) -> IO (Maybe StackFrameInfo)+stackFrameInfo (AnnFrame{annotation}, _)+  | let Box annVal = annotation+  , let stack_anno = displayStackAnnotation @SomeStackAnnotation (unsafeCoerce annVal)+  = pure $ Just $ StackFrameAnnotation Nothing{-No source locations yet-} stack_anno+stackFrameInfo (_, Just ipe)+  = pure $ Just (StackFrameIPEInfo ipe)+stackFrameInfo (RetBCO{bco}, _)+  | let !(Box !bco_hval) = bco -- needs to be forced for `getClosureData` to look at the right thing.+  = fmap StackFrameBreakpointInfo <$> (lookupBCOBreakpoint =<< Heap.getClosureData bco_hval)+stackFrameInfo _+  = pure Nothing++-- | Try to find a BRK_FUN breakpoint location at the start of a BCO heap closure+lookupBCOBreakpoint :: Heap.GenClosure Box -> IO (Maybe InternalBreakpointId)+lookupBCOBreakpoint Heap.BCOClosure{..}+  {-+  This is highly internals dependent...:+    - find the bytecode instruction (BCI) at index 0+    - BCI is Word16 (the high 8bits are for flags, low for instruction op code)++  NOTE: Assume @Opt_AddBcoName@ is not set. @Opt_AddBcoName@ moves the BRK_FUN+  BCI to index 2#, but it is a debug flag used by compiler developers to debug+  bytecode itself, so we shouldn't go to great lengths to support it. Other+  things will be broken too.+  -}+  | index_at 0# .&. 0xFF == 66{-bci_BRK_FUN-}+  = do+    mod_name <- literalString info_mod_name_ix+    mod_id   <- literalString info_mod_id_ix+    pure $ Just $ evalBreakpointToId EvalBreakpoint+#if MIN_VERSION_ghc(9,15,0)+      { eb_info_mod      = utf8EncodeShortByteString mod_name+#else+      { eb_info_mod      = mod_name+#endif+      , eb_info_mod_unit = utf8EncodeShortByteString mod_id+      , eb_info_index    = fromIntegral $ brk_info_ix_hi .<<. 16 + brk_info_ix_lo+      }++  | otherwise+  = pure Nothing++  where+    Box instrs_val = instrs+    Box literals_val = literals++    index_at n = W16# (GHC.Base.indexWord16Array# (unsafeCoerce# instrs_val) n)++    -- find a string in the literals array by index+    literalString :: Word16 -> IO String+    literalString (fromIntegral -> GHC.Exts.I# ix) = do+      peekCString $+        GHC.Exts.Ptr (GHC.Exts.indexAddrArray# (unsafeCoerce# literals_val) ix)++    _brk_arr_ix      = index_at 1#+    info_mod_name_ix = index_at 2#+    info_mod_id_ix   = index_at 3#+    brk_info_ix_hi   = index_at 4#+    brk_info_ix_lo   = index_at 5#+lookupBCOBreakpoint _ = pure Nothing++exceptionInfo :: SomeException -> ExceptionInfo+exceptionInfo se'@(SomeException exc) =+    ExceptionInfo+       { exceptionInfoTypeName = simpleTypeName+       , exceptionInfoFullTypeName = fullTypeName+       , exceptionInfoMessage = Control.Exception.displayException se'+       , exceptionInfoContext = contextText+       , exceptionInfoSourceSpan = exceptionContextLocation+       , exceptionInfoInner = innerNodes+       }+  where+    ctx = someExceptionContext se'+    rendered = displayExceptionContext ctx+    whileHandling = getExceptionAnnotations ctx+    innerNodes = map (exceptionInfo . unwrap) whileHandling+    simpleTypeName = tyConName tc+    modulePrefix = case tyConModule tc of+      mdl | null mdl -> ""+          | otherwise -> mdl ++ "."+    packagePrefix = case tyConPackage tc of+      pkg | null pkg -> ""+          | otherwise -> pkg ++ ":"+    tc = typeRepTyCon (typeOf exc)+    fullTypeName = packagePrefix ++ modulePrefix ++ simpleTypeName+    unwrap (WhileHandling inner) = inner+    contextText | null rendered = Nothing+                | otherwise     = Just rendered++#if MIN_VERSION_ghc(9,15,0)+    exceptionContextLocation =+      let fromCallStack cs = case listToMaybe (getCallStack cs) of+            Just (_, loc) -> Just (srcLocToSourceSpan loc)+            Nothing       -> Nothing+          bts :: [Backtraces]+          bts = getExceptionAnnotations ctx+      in case bts of+           bt : _ -> case Backtrace.btrHasCallStack bt of+             Just cs -> fromCallStack cs+             Nothing -> Nothing+           [] -> Nothing+#else+    exceptionContextLocation = Nothing {- btrHasCallstack not available -}+#endif++--------------------------------------------------------------------------------+-- * Binary for custom commands+--------------------------------------------------------------------------------++data Some c f where+  Some :: c a => f a -> Some c f++encodePayload :: Bin.Binary a => a -> BS.ByteString+encodePayload = BL.toStrict . Bin.encode++decodePayload :: Bin.Binary a => BS.ByteString -> Either String a+decodePayload bs =+  case Bin.decodeOrFail (BL.fromStrict bs) of+    Left (_, _, err) -> Left err+    Right (_, _, a)  -> Right a++instance Bin.Binary (Some Bin.Binary DbgInterpCmd) where+  put (Some command) = case command of+    ListThreads -> Bin.put (0 :: Word8)+    DecodeThreadStack threadIdRef -> do+      Bin.put (1 :: Word8)+      Bin.put threadIdRef+    CollectExceptionInfo excRef -> do+      Bin.put (2 :: Word8)+      Bin.put excRef++  get = do+    (tag :: Word8) <- Bin.get+    case tag of+      0 -> pure (Some ListThreads)+      1 -> Some . DecodeThreadStack <$> Bin.get+      2 -> Some . CollectExceptionInfo <$> Bin.get+      _ -> fail ("Unknown debugger thread command tag: " ++ show tag)++instance Bin.Binary (ThreadInfo RemoteRef)+instance Bin.Binary StackFrameInfo+instance Bin.Binary Stack.SrcLoc+instance Bin.Binary SourceSpan where+  put SourceSpan{..} = do+    Bin.put file+    Bin.put startLine+    Bin.put endLine+    Bin.put startCol+    Bin.put endCol++  get = do+    file <- Bin.get+    startLine <- Bin.get+    endLine <- Bin.get+    startCol <- Bin.get+    endCol <- Bin.get+    pure SourceSpan{..}++instance Bin.Binary ExceptionInfo where+  put ExceptionInfo{..} = do+    Bin.put exceptionInfoTypeName+    Bin.put exceptionInfoFullTypeName+    Bin.put exceptionInfoMessage+    Bin.put exceptionInfoContext+    Bin.put exceptionInfoSourceSpan+    Bin.put exceptionInfoInner++  get = do+    exceptionInfoTypeName <- Bin.get+    exceptionInfoFullTypeName <- Bin.get+    exceptionInfoMessage <- Bin.get+    exceptionInfoContext <- Bin.get+    exceptionInfoSourceSpan <- Bin.get+    exceptionInfoInner <- Bin.get+    pure ExceptionInfo{..}++instance Bin.Binary InternalBreakpointId where+  put (InternalBreakpointId (Module (RealUnit (Definite unit)) name) ix) = do+    Bin.put (unitString unit)+    Bin.put (moduleNameString name)+    Bin.put ix+  put _ = error "indefinite units are not supported by haskell-debugger yet!"+  get = do+    unit <- stringToUnitId <$> Bin.get+    name <- mkModuleName <$> Bin.get+    ix   <- Bin.get+    pure $ InternalBreakpointId (Module (RealUnit (Definite unit)) name) ix++instance Bin.Binary ThreadStatus where+  put = \case+    ThreadRunning -> Bin.put (0 :: Word8)+    ThreadFinished -> Bin.put (1 :: Word8)+    ThreadBlocked blockReason -> do+      Bin.put (2 :: Word8)+      Bin.put blockReason+    ThreadDied -> Bin.put (3 :: Word8)++  get = do+    (statusTag :: Word8) <- Bin.get+    case statusTag of+      0 -> pure ThreadRunning+      1 -> pure ThreadFinished+      2 -> ThreadBlocked <$> Bin.get+      3 -> pure ThreadDied+      _ -> fail ("Unknown thread status tag: " ++ show statusTag)++instance Bin.Binary BlockReason where+  put = \case+    BlockedOnMVar        -> Bin.put (0 :: Word8)+    BlockedOnBlackHole   -> Bin.put (1 :: Word8)+    BlockedOnException   -> Bin.put (2 :: Word8)+    BlockedOnSTM         -> Bin.put (3 :: Word8)+    BlockedOnForeignCall -> Bin.put (4 :: Word8)+    BlockedOnOther       -> Bin.put (5 :: Word8)++  get = do+    blockTag <- Bin.get+    case (blockTag :: Word8) of+      0 -> pure BlockedOnMVar+      1 -> pure BlockedOnBlackHole+      2 -> pure BlockedOnException+      3 -> pure BlockedOnSTM+      4 -> pure BlockedOnForeignCall+      5 -> pure BlockedOnOther+      _ -> fail ("Unknown thread block reason tag: " ++ show blockTag)++--------------------------------------------------------------------------------

@@ -1,4 +1,5 @@ {-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OrPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-}@@ -9,13 +10,13 @@ module GHC.Debugger.Runtime.Thread   ( getRemoteThreadIdFromRemoteContext   , getRemoteThreadId-  , getRemoteThreadsLabels   , listAllLiveRemoteThreads++  -- * Re-exports+  , ThreadInfo(..)   ) where  import Data.Maybe-import Data.Functor-import Control.Applicative import Control.Concurrent import Control.Monad import Control.Monad.IO.Class@@ -36,9 +37,17 @@ import GHC.Debugger.Runtime.Term.Parser import GHC.Debugger.Runtime.Thread.Map +import GHC.Debugger.Runtime.Interpreter.Custom import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote +#if MIN_VERSION_ghc(9,15,0)+import qualified GHC.Debugger.Runtime.Interpreter as Debuggee+#else+import Data.Functor+import Control.Applicative+#endif+ -- | Get a 'RemoteThreadId' from a remote 'ResumeContext' gotten from an 'ExecBreak' getRemoteThreadIdFromRemoteContext :: ForeignRef (ResumeContext [HValueRef]) -> Debugger RemoteThreadId getRemoteThreadIdFromRemoteContext fctxt = do@@ -53,6 +62,23 @@       getRemoteThreadId (castForeignRef threadIdVal)     _ -> liftIO $ fail "Expected threadIdTerm to be a Term!" +-- | Call 'listThreads' on the (possibly) remote debuggee process to get the+-- list of threads running on the debuggee. Filter by running threads+-- This may include the debugger threads if using the internal interpreter.+listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ThreadInfo ForeignRef)]+listAllLiveRemoteThreads = do+#if MIN_VERSION_ghc(9,15,0)+  threadInfos <- Debuggee.listThreads+#else+  threadInfos <- GHC.Debugger.Runtime.Thread.listThreads+#endif+  fmap catMaybes $+    forM threadInfos $ \ti -> do+      rti <- getRemoteThreadId ti.threadInfoRef+      pure $ case ti.threadInfoStatus of+        (ThreadRunning ; ThreadBlocked{}) -> Just (rti, ti)+        (ThreadDied    ; ThreadFinished)  -> Nothing+ getRemoteThreadId :: ForeignRef ThreadId -> Debugger RemoteThreadId getRemoteThreadId threadIdRef = do   thread_id_fv <- expectRight =<< Remote.eval@@ -75,6 +101,26 @@        return (RemoteThreadId tid_int) +#if MIN_VERSION_ghc(9,15,0)+-- The needed functions are imported from GHC.Debugger.Runtime.Interpreter,+-- which abstracts over the custom interpreter commands.+#else+--------------------------------------------------------------------------------+-- ** GHC 9.14: use @evalX@ and @TermParser@ to do it without custom commands+--------------------------------------------------------------------------------++listThreads :: Debugger [ThreadInfo ForeignRef]+listThreads = do+  threads_fvs <- expectRight =<< Remote.evalIOList Remote.listThreads+  labels      <- getRemoteThreadsLabels threads_fvs+  forM (zip threads_fvs labels) $ \(castForeignRef -> thread_fv, label) -> do+    status <- getRemoteThreadStatus thread_fv+    pure ThreadInfo+      { threadInfoStatus = status+      , threadInfoLabel  = label+      , threadInfoRef    = thread_fv+      }+ -- | Is the remote thread running or blocked (NOT finished NOR dead)? getRemoteThreadStatus :: ForeignRef ThreadId -> Debugger ThreadStatus getRemoteThreadStatus threadIdRef = do@@ -90,33 +136,11 @@     Right thrdStatus ->       return thrdStatus -isRemoteThreadLive :: ForeignRef ThreadId -> Debugger Bool-isRemoteThreadLive r = getRemoteThreadStatus r <&> \case-  (ThreadRunning ; ThreadBlocked{}) -> True-  (ThreadDied    ; ThreadFinished)  -> False---- | Call 'listThreads' on the (possibly) remote debuggee process to get the--- list of threads running on the debuggee. Filter by running threads--- This may include the debugger threads if using the internal interpreter.-listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ForeignRef ThreadId)]-listAllLiveRemoteThreads = do-  threads_fvs <- expectRight =<< Remote.evalIOList Remote.listThreads-  catMaybes <$> do-    forM threads_fvs $ \(castForeignRef -> thread_fv) -> do-      isLive <- isRemoteThreadLive thread_fv-      if isLive then do-        tid <- getRemoteThreadId thread_fv-        pure $ Just (tid, thread_fv)-      else do-        pure Nothing---- | Get the label of a Thread in a remote process. Returns one element per--- given Thread with @Just string@ if a label was found. getRemoteThreadsLabels :: [ForeignRef ThreadId] -> Debugger [Maybe String] getRemoteThreadsLabels threadIdRefs = do    forM threadIdRefs $ \threadIdRef -> do-    +     r <- Remote.evalIOList $ Remote.do       mb_str <- Remote.threadLabel (Remote.ref threadIdRef)       Remote.return (Remote.maybeToList mb_str)@@ -127,11 +151,9 @@       _ -> liftIO $ fail "Unexpected result from evaluating \"threadLabel\""  ----------------------------------------------------------------------------------- * TermParsers+-- *** TermParsers -------------------------------------------------------------------------------- --- ** Threads ------------------------------------------------------------------- threadStatusParser :: TermParser ThreadStatus threadStatusParser = do         (matchConstructorTerm "ThreadRunning"  $> ThreadRunning)@@ -148,3 +170,4 @@     <|> (matchConstructorTerm "BlockedOnForeignCall" $> BlockedOnForeignCall)     <|> (matchConstructorTerm "BlockedOnOther"       $> BlockedOnOther) +#endif

@@ -12,9 +12,16 @@   , getRemoteThreadStackCopy   ) where +import Control.Concurrent+import GHCi.RemoteTypes+import GHC.Debugger.Monad+import GHC.Debugger.Runtime.Interpreter.Custom++#if MIN_VERSION_ghc(9,15,0)+import qualified GHC.Debugger.Runtime.Interpreter as Debuggee+#else import Data.Bits import Data.Maybe-import Control.Concurrent import Control.Applicative import Control.Monad import Control.Monad.IO.Class@@ -32,32 +39,24 @@ import GHC.Utils.Outputable  import GHCi.Message-import GHCi.RemoteTypes  import Colog.Core as Logger-import GHC.Debugger.Monad import GHC.Debugger.Runtime.Term.Parser import GHC.Debugger.Runtime.Eval import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote+#endif  -------------------------------------------------------------------------------- -- * Thread stack frames -------------------------------------------------------------------------------- --- | Information about a stack frame-data StackFrameInfo-  -- | Information derived from an IPE entry-  = StackFrameIPEInfo !InfoProv-  -- | User-defined Stack Frame annotation-  | StackFrameAnnotation !(Maybe Stack.SrcLoc) !String-  -- | Information derived from a continuation BCO breakpoint info.-  | StackFrameBreakpointInfo !InternalBreakpointId- -- | Clone the stack of the given remote thread and get the breakpoint ids of available frames getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [StackFrameInfo] getRemoteThreadStackCopy threadIdRef = do-+#if MIN_VERSION_ghc(9,15,0)+  Debuggee.decodeThreadStack threadIdRef+#else   l <- Remote.evalIOList $ Remote.do     clonedStack <- Remote.cloneThreadStack (Remote.ref threadIdRef)     frames      <- Remote.decodeStackWithIpe clonedStack@@ -79,7 +78,11 @@               return Nothing             Right tm ->               return tm+#endif +#if MIN_VERSION_ghc(9,15,0)+-- Nothing needed in this case :)+#else -------------------------------------------------------------------------------- -- ** Decoding Stack Frames ---------------------------------------------------- --------------------------------------------------------------------------------@@ -225,3 +228,4 @@         logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))         liftIO $ fail "Failed to parse BCOClosure's BRK_FUN"       Right r -> return r+#endif

@@ -1,4 +1,5 @@ {-# LANGUAGE DerivingStrategies, CPP, RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}  -- | Initialise the GHC session for one or more home units. --@@ -25,10 +26,17 @@   enableExternalInterpreter,   enableDynamicDebuggee,   setPgmI, addOptI,-  setDynFlagWays+  setDynFlagWays,+  makeDynFlagsAbsoluteOverall,+  resumeExec,+  setExposedInUnit,+  graphUnits,   )   where +#if MIN_VERSION_ghc(9,14,2)+import Data.Function ((&))+#endif import Control.Monad import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1                    as H@@ -65,6 +73,10 @@ import qualified Data.Set as Set import Data.Maybe import GHC.Types.Target (InputFileBuffer)+import GHC (SingleStep, ExecResult)+import Data.Set (Set)+import qualified GHC.Unit as GHC+import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), ModNodeKeyWithUid (mnkUnitId), mnKey)  -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m@@ -117,6 +129,7 @@         let targets = HIE.makeTargetsAbsolute root_canon targets'         cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts         let dflags'' =+              makeDynFlagsDirsAbsolute compRoot $               setWorkingDirectory root $               setCacheDirs cacheDirs $               enableByteCodeGeneration $@@ -134,31 +147,21 @@  -- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's. -- The first 'DynFlags' are the 'DynFlags' for the interactive session.-createUnitEnvFromFlags :: DynFlags -> [DynFlags] -> IO HomeUnitGraph-createUnitEnvFromFlags initialDynFlags unitDflags = do-  let-    newInternalUnitEnv dflags hpt = mkHomeUnitEnv State.emptyUnitState Nothing dflags hpt Nothing--  unitEnvList <- traverse (\dflags -> do-    emptyHpt <- emptyHomePackageTable-    pure (homeUnitId_ dflags, newInternalUnitEnv dflags emptyHpt)) unitDflags+createHomeUnitGraph :: GHC.Logger -> [DynFlags] -> IO HomeUnitGraph+createHomeUnitGraph logger unitDflags = do+  let home_units = Set.fromList $ map homeUnitId_ unitDflags+  unitEnvList <- flip traverse unitDflags $ \ dflags -> do+    hue <- setupNewHomeUnitEnv logger dflags Nothing home_units+    pure (homeUnitId_ dflags, hue) -  interactiveHomeUnit <- do-    let interactiveDynFlags = initialDynFlags-          { homeUnitId_ = interactiveGhcDebuggerUnitId-          , importPaths = []-          , packageFlags =-              [ ExposePackage-                  ("-package-id " ++ unitIdString unitId)-                  (UnitIdArg $ RealUnit (Definite unitId))-                  (ModRenaming True [])-              | (unitId, _) <- unitEnvList-              ]-          }-    emptyHpt <- emptyHomePackageTable-    pure (homeUnitId_ interactiveDynFlags, newInternalUnitEnv interactiveDynFlags emptyHpt)+  pure $ unitEnv_new (Map.fromList unitEnvList) -  pure $ unitEnv_new (Map.fromList (interactiveHomeUnit : unitEnvList))+setupNewHomeUnitEnv :: GHC.Logger -> DynFlags -> Maybe [GHC.UnitDatabase UnitId] -> Set UnitId -> IO HomeUnitEnv+setupNewHomeUnitEnv logger dflags cached_dbs other_home_units = do+  emptyHpt <- emptyHomePackageTable+  (dbs,unit_state,home_unit,mconstants) <- State.initUnits logger dflags cached_dbs other_home_units+  updated_dflags <- GHC.updatePlatformConstants dflags mconstants+  pure $ mkHomeUnitEnv unit_state (Just dbs) updated_dflags emptyHpt (Just home_unit)  -- | Given a set of 'DynFlags', set up the 'UnitEnv' and 'HomeUnitEnv' for this -- 'HscEnv'.@@ -167,51 +170,94 @@ initHomeUnitEnv :: [DynFlags] -> HscEnv -> IO HscEnv initHomeUnitEnv unitDflags env = do   let dflags0         = hsc_dflags env-  -- additionally, set checked dflags so we don't lose fixes-  initial_home_graph <- createUnitEnvFromFlags dflags0 unitDflags-  let home_units = unitEnv_keys initial_home_graph-  init_home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do-    let dflags = homeUnitEnv_dflags homeUnitEnv-        old_hpt = homeUnitEnv_hpt homeUnitEnv-    (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags Nothing home_units-    updated_dflags <- GHC.updatePlatformConstants dflags mconstants-    pure HomeUnitEnv-      { homeUnitEnv_units = unit_state-      , homeUnitEnv_unit_dbs = Just dbs-      , homeUnitEnv_dflags = updated_dflags-      , homeUnitEnv_hpt = old_hpt-      , homeUnitEnv_home_unit = Just home_unit-      } -  let cached_unit_dbs = concat . catMaybes . fmap homeUnitEnv_unit_dbs $ Foldable.toList init_home_unit_graph+  initial_home_graph <- createHomeUnitGraph (hsc_logger env) unitDflags -  let homeUnitEnv = fromJust $ HUG.unitEnv_lookup_maybe interactiveGhcDebuggerUnitId init_home_unit_graph-      dflags = homeUnitEnv_dflags homeUnitEnv-      old_hpt = homeUnitEnv_hpt homeUnitEnv-  (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags (Just cached_unit_dbs) home_units+  -- We set up the interactive debugger home unit after the other home units+  -- have been initialised.+  -- This allows us to reuse the package databases and their respective visibilities.+  interactiveHomeUnit <- do+    let+      home_units = unitEnv_keys initial_home_graph -  updated_dflags <- GHC.updatePlatformConstants dflags mconstants-  let ie = HomeUnitEnv+      interactiveDynFlags = dflags0+        { homeUnitId_ = interactiveGhcDebuggerUnitId+        , importPaths = []+        , packageFlags =+            [ ExposePackage+                (unitIdString home_unit_id)+                (UnitIdArg $ RealUnit (Definite home_unit_id))+                (ModRenaming True [])+            | home_unit_id <- Set.toList home_units+            ]+        }++    let cached_unit_dbs = concat . catMaybes . fmap homeUnitEnv_unit_dbs $ Foldable.toList initial_home_graph+    setupNewHomeUnitEnv (hsc_logger env) interactiveDynFlags (Just cached_unit_dbs) home_units++  let home_unit_graph =+        HUG.unitEnv_insert interactiveGhcDebuggerUnitId interactiveHomeUnit initial_home_graph++  let interactiveDFlags = homeUnitEnv_dflags interactiveHomeUnit+  unit_env <-+    initUnitEnv interactiveGhcDebuggerUnitId home_unit_graph (GHC.ghcNameVersion interactiveDFlags) (targetPlatform interactiveDFlags)+  pure $ hscSetFlags interactiveDFlags $ hscSetUnitEnv unit_env env++-- | Extracts @UnitId@s from the graph.+graphUnits :: GHC.ModuleGraph -> [UnitId]+graphUnits mod_graph = L.nubOrd .+  (`mapMaybe` mg_mss mod_graph) $ \case+         UnitNode _deps uid -> Just uid+         ModuleNode _ modl -> Just $ mnkUnitId $ mnKey modl+         InstantiationNode uid _ -> Just uid+         LinkNode _ _ -> Nothing++-- | Rebuilds the UnitState of the unit, exposing the given packages.+--+--   Takes care of updating hsc_dflags, ue_platform, and ue_namever if this is the ue_currentUnit.+setExposedInUnit :: UnitId -> [UnitId] -> Ghc ()+setExposedInUnit unitId exposed = do+  env <- GHC.getSession+  let old_ie = case lookupHugUnitId unitId (hsc_HUG env) of+        Just hue -> hue+        Nothing -> error $ "setExposedInUnit: unit not found " ++ unitIdString unitId++  let dflags = (homeUnitEnv_dflags old_ie) { packageFlags = [ExposePackage+                  (unitIdString uid)+                  (UnitIdArg $ RealUnit (Definite uid))+                  (ModRenaming True [])+              | uid <- exposed+              , uid /= rtsUnitId+              , uid /= ghcInternalUnitId+              , unitIdString uid /= "haskell-debugger-view-in-memory"+              -- FIXME: any other to filter out?+              ]}+  let cached_dbs = homeUnitEnv_unit_dbs old_ie+  let home_units = Set.fromList $ State.homeUnitDepends $ homeUnitEnv_units old_ie+  (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger env) dflags cached_dbs home_units++  updated_dflags <- liftIO $ GHC.updatePlatformConstants dflags mconstants+  let ie = old_ie        { homeUnitEnv_units = unit_state        , homeUnitEnv_unit_dbs = Just dbs        , homeUnitEnv_dflags = updated_dflags-       , homeUnitEnv_hpt = old_hpt        , homeUnitEnv_home_unit = Just home_unit        } -  let home_unit_graph = HUG.unitEnv_insert interactiveGhcDebuggerUnitId ie init_home_unit_graph--  let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup interactiveGhcDebuggerUnitId home_unit_graph-  let unit_env = UnitEnv-        { ue_platform        = targetPlatform dflags1-        , ue_namever         = GHC.ghcNameVersion dflags1-        , ue_home_unit_graph = home_unit_graph-        , ue_current_unit    = interactiveGhcDebuggerUnitId-        , ue_module_graph    = ue_module_graph (hsc_unit_env env)-        , ue_eps             = ue_eps (hsc_unit_env env)-        }-  pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env-+  let home_unit_graph = HUG.unitEnv_insert unitId ie (hsc_HUG env)+  let ue0 = hsc_unit_env env+  let ue1 = ue0 {ue_home_unit_graph = home_unit_graph}+  let+    new_env+      | ue_currentUnit ue1 /= unitId = hscSetUnitEnv ue1 env+      | otherwise = hscSetFlags dflags1 $ hscSetUnitEnv ue2 env+      where+        dflags1 = homeUnitEnv_dflags $ unitEnv_lookup unitId (ue_home_unit_graph ue1)+        ue2 = ue1+          { ue_platform        = targetPlatform dflags1+          , ue_namever         = GHC.ghcNameVersion dflags1+          }+  GHC.setSession new_env  -- | Setup the given 'HscEnv' to hold a 'UnitEnv' -- with all the given components.@@ -400,6 +446,18 @@ #endif   } +-- | Prefixes output directories (i.e. @hiDir@, @hieDir@, @stubDir@, @dumpDir@) with @rootDir@ argument.+makeDynFlagsDirsAbsolute :: FilePath -> DynFlags -> DynFlags+makeDynFlagsDirsAbsolute rootDir df0 =+  foldl' (\ df f -> f (fmap $ normalise . (rootDir </>)) df) df0+    [(\ f df -> df {hiDir = f (hiDir df)})+    ,(\ f df -> df {hieDir = f (hieDir df)})+    ,(\ f df -> df {stubDir = f (stubDir df)})+    ,(\ f df -> df {dumpDir = f (dumpDir df)})]++makeDynFlagsAbsoluteOverall :: FilePath -> DynFlags -> DynFlags+makeDynFlagsAbsoluteOverall rootDir df0 = makeDynFlagsDirsAbsolute rootDir $ makeDynFlagsAbsolute rootDir df0+ -- | If the compiler supports `.gbc` files (>= 9.14.2), then persist these -- artefacts to disk. enableByteCodeGeneration :: DynFlags -> DynFlags@@ -464,6 +522,41 @@        dflags3 = foldr GHC.unSetGeneralFlag' dflags2                        (wayUnsetGeneralFlags platform w)    in dflags3++-- ----------------------------------------------------------------------------+-- Wrappers around GHC's odd behavior+-- ----------------------------------------------------------------------------++resumeExec :: GhcMonad m => SingleStep -> Maybe Int -> m ExecResult+resumeExec a b = do+  -- IC's ic_imports field is not kept in sync with ic_gre_cache, so we could do+  -- this call later, but why rely on that.+  imports <- GHC.getContext++  v <- GHC.resumeExec a b++  -- To have interactive imports persist after a `continue` command we have to+  -- work around how GHC.resumeExec handles the InteractiveContext (IC).+  --+  -- GHC.resumeExec resets the scope of the IC (i.e. ic_gre_cache) to what it+  -- was before the last ExecBreak.+  --+  -- It makes sense for GHC.resumeExec to remove from the IC scope the+  -- breakpoint locals and anything that could have been defined with them, in+  -- fact they are also unloaded.+  --+  -- The way it's done though also rollbacks any import statements that were+  -- executed since the last ExecBreak. The only fix is to reimport everything+  -- again.+  --+  -- Note: GHC.setContext recomputes the scope of the interactive imports from+  -- scratch everytime. Considering `runDebugger` adds the whole home unit to+  -- the interactive imports this might become a bottleneck. GHC does not keep+  -- any reference to the scope containing just the imports, so we would have to+  -- cache it ourselves (and then extend it with the cached scope of+  -- ic_tythings, i.e. igre_prompt_env (c.f. replaceImportEnv)).+  GHC.setContext imports+  pure v  -- ---------------------------------------------------------------------------- -- Utils that we need, but don't want to incur an additional dependency for.

@@ -100,7 +100,7 @@         , importPaths = []         , packageFlags =           [ ExposePackage-                  ("-package-id " ++ unitIdString unitId)+                  (unitIdString unitId)                   (UnitIdArg $ RealUnit (Definite unitId))                   (ModRenaming True [])           | unitId <- base_uids

@@ -0,0 +1,111 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultilineStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+module GHC.Debugger.Session.Interactive where++import Control.Monad.IO.Class+import Data.Maybe++#if MIN_VERSION_ghc(9,15,0)+import GHC.Linker.Types (modifyHomePackageBytecodeState)+#endif+import GHC+import GHC.Driver.Config+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Env+import GHC.Driver.Main+import qualified GHC.Linker.Loader as Loader+import GHC.Runtime.Interpreter as GHCi+import GHC.Runtime.Context as GHCi+import GHCi.RemoteTypes (HValueRef)++-- | Defines a strict @noPrintConstant :: a -> IO ()@ while taking care not to introduce its OccName into scope.+defineNoPrint :: Ghc Name+defineNoPrint = do+    let ExecOptions{execSourceFile,execLineNumber} = GHC.execOptions+    hsc_env <- getSession+    let input = "let noPrintConstant x = x `Prelude.seq` Prelude.return () :: Prelude.IO ()"+    stmt <-+      liftIO $ fmap (fromMaybe $ error "impossible: parsing noPrintConstant") $+      runInteractiveHsc hsc_env $+      hscParseStmtWithLocation execSourceFile execLineNumber input++    mr <- execStmtNoOccEnv stmt+    case mr of+      Just ExecComplete{execResult = Right [n]} -> return n+      _ -> error "impossible: defining noPrintConstant"++-- | Executes a statement to completion without bringing any OccName in scope.+execStmtNoOccEnv :: GhcMonad m => GhciLStmt GhcPs -> m (Maybe ExecResult)+execStmtNoOccEnv stmt = do+    hsc_env <- getSession+    let interp = hscInterp hsc_env++    -- Turn off -fwarn-unused-local-binds when running a statement, to hide+    -- warnings about the implicit bindings we introduce.+    let ic       = hsc_IC hsc_env -- use the interactive dflags+        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds+        hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' }})++    r <- liftIO $ hscParsedStmt hsc_env' stmt++    case r of+      Nothing ->+        -- empty statement / comment+        return (Just $ ExecComplete (Right []) 0)+      Just (ids, hval, _fix_env) -> do+        -- updateFixityEnv fix_env++        status <-+          liftIO $ do+            let eval_opts = initEvalOpts idflags' EvalStepNone+            evalStmt interp eval_opts (EvalThis hval)++        handleCompleted extendInteractiveContextWithIdsNoOccEnv ids status++handleCompleted :: GhcMonad m+                => (InteractiveContext -> [Id] -> InteractiveContext)+                -> [Id]+                -> EvalStatus_ [ForeignHValue] [HValueRef]+                -> m (Maybe ExecResult)+handleCompleted extendIC final_ids status = do+  hsc_env <- getSession+  let+    interp = hscInterp hsc_env+  case status of++    -- Completed successfully+    EvalComplete allocs (EvalSuccess hvals) -> do+      let+        final_ic = extendIC (hsc_IC hsc_env) final_ids+        final_names = map getName final_ids+#if MIN_VERSION_ghc(9,15,0)+      liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals)+#else+      liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)+#endif+      -- hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}+      setSession $ hsc_env{hsc_IC=final_ic}+      return (Just $ ExecComplete (Right final_names) allocs)+    _ -> return Nothing++-- | Extend the @InteractiveContext@ with the @Id@s without bringing their @OccName@s in scope.+extendInteractiveContextWithIdsNoOccEnv :: InteractiveContext -> [Id] -> InteractiveContext+extendInteractiveContextWithIdsNoOccEnv ictxt new_ids+  | null new_ids = ictxt+  | otherwise+  = ictxt { ic_mod_index  = ic_mod_index ictxt + 1+          , ic_tythings   = new_tythings ++ ic_tythings ictxt+          }+    -- no change to ic_gre_cache as that deals with OccNames+  where+    new_tythings = map AnId new_ids

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,    DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,-   TypeApplications, ScopedTypeVariables, BangPatterns, MultiWayIf #-}+   TypeApplications, ScopedTypeVariables, BangPatterns, MultiWayIf, OverloadedRecordDot #-} module GHC.Debugger.Stopped where  import Control.Monad@@ -35,7 +35,6 @@ import qualified GHC.Debugger.Interface.Messages as DbgStackFrame (DbgStackFrame(..)) import GHC.Debugger.Utils import qualified Colog.Core as Logger-import qualified GHC.Stack.Types as Stack  {- Note [Don't crash if not stopped]@@ -78,16 +77,15 @@   -- let (t_ids, remote_refs) = unzip (threadMapToList tmap)   --   -- Oh, try the listThreads just for fun.-  (t_ids, remote_refs) <- unzip <$> listAllLiveRemoteThreads-  t_labels             <- getRemoteThreadsLabels remote_refs+  (t_ids, t_infos) <- unzip <$> listAllLiveRemoteThreads   let-    _mkDebuggeeThread tid tlbl+    _mkDebuggeeThread tid tinfo       = DebuggeeThread         { tId = tid-        , tName = tlbl+        , tName = tinfo.threadInfoLabel         }     _all_threads-      = zipWith _mkDebuggeeThread t_ids t_labels+      = zipWith _mkDebuggeeThread t_ids t_infos    -- TODO: We ignore _all_threads and report only the main execution thread for now.   -- See #138 for progress on Multi-threaded debugging.@@ -184,7 +182,7 @@                   , breakId = Just ibi                   }         _ -> do-          mExcSpan <- exceptionSourceSpanFromContext+          mExcSpan <- exceptionInfoSourceSpan <$> getExceptionInfo req_tid           case mExcSpan of             Just sourceSpan ->  return $ Just DbgStackFrame                                   { name = GHC.resumeDecl r@@ -194,16 +192,6 @@             Nothing -> return Nothing   return (maybe id (:) head_frame $ decoded_frames) -srcLocToSourceSpan :: Stack.SrcLoc -> SourceSpan-srcLocToSourceSpan srcLoc =-  SourceSpan-    { file = Stack.srcLocFile srcLoc-    , startLine = Stack.srcLocStartLine srcLoc-    , endLine = Stack.srcLocEndLine srcLoc-    , startCol = Stack.srcLocStartCol srcLoc-    , endCol = Stack.srcLocEndCol srcLoc-    }- -------------------------------------------------------------------------------- -- * Scopes --------------------------------------------------------------------------------@@ -277,6 +265,7 @@   frames <- getStacktrace threadId   let frame = frames !! frameIx   hsc_env <- getSession+  fam_envs <- getFamInstEnvs'   case vk of     -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`)     -- (VARR)(b,c)@@ -294,7 +283,7 @@            term' <- forceTerm term -          vi <- termToVarInfo key term'+          vi <- termToVarInfo fam_envs key term'            return (ForcedVariable vi) @@ -305,14 +294,14 @@           -- Meaning the @SpecificVariable@ request means to inspect the structure.           -- Return ONLY the fields -          termVarFields key term >>= \case+          termVarFields fam_envs key term >>= \case             VarFields vfs -> pure (VariableFields vfs)      -- (VARR)(a) from here onwards      LocalVariables -> fmap VariableFields $ do       -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)-      mapM tyThingToVarInfo =<< GHC.getBindings+      mapM (tyThingToVarInfo fam_envs) =<< GHC.getBindings      ModuleVariables       | frameIx < length frames@@ -323,7 +312,7 @@         things <- typeEnvElts <$> getTopEnv curr_modl         mapM (\tt -> do           nameStr <- display (getName tt)-          vi <- tyThingToVarInfo tt+          vi <- tyThingToVarInfo fam_envs tt           return vi{varName = nameStr}) things      GlobalVariables@@ -345,7 +334,7 @@                 , varRef = NoVariables                 }             Just tt -> do-              vi <- tyThingToVarInfo tt+              vi <- tyThingToVarInfo fam_envs tt               return vi{varName = nameStr}           ) names 

@@ -5,95 +5,32 @@ -- These helpers execute code on the remote process which teach us information -- about the exception we are stopped at. module GHC.Debugger.Stopped.Exception-  ( exceptionSourceSpanFromContext-  , getExceptionInfo-  , fallbackExceptionSourceSpan+  ( getExceptionInfo   , defaultExceptionInfo-  , currentlyStoppedOnException   ) where -import Data.Maybe (fromMaybe, isNothing)+import Data.Maybe  import GHC-import GHC.Types.SrcLoc-import GHC.Data.FastString (unpackFS)-import GHC.Utils.Outputable as Ppr  import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages-  ( SourceSpan(..)-  , ExceptionInfo(..)+  ( ExceptionInfo(..)   , RemoteThreadId(..)   )-import qualified Colog.Core as Logger import GHC.Debugger.Runtime.Thread+import GHCi.RemoteTypes+#if MIN_VERSION_ghc(9,15,0)+import qualified GHC.Debugger.Runtime.Interpreter as Debuggee+#else+import GHC.Builtin.Types (anyTy) import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import GHC.Debugger.Runtime.Term.Parser-import GHCi.RemoteTypes (castForeignRef)-import GHC.Builtin.Types (anyTy)---- | Attempt to obtain a more precise 'SourceSpan' for the exception we stopped--- on by consulting its context, if available.-exceptionSourceSpanFromContext :: Debugger (Maybe SourceSpan)-exceptionSourceSpanFromContext = do-  GHC.getResumeContext >>= \case-    r:_ | Nothing <- GHC.resumeBreakpointId r -> do-      let excRef = resumeApStack r-      evalRes <- Remote.eval-        (Remote.raw exceptionLocationExpr `Remote.app` Remote.untypedRef excRef)-      case evalRes of-        Left err -> do-          logSDoc Logger.Debug $-            Ppr.text "Failed to evaluate exception context:" Ppr.<+> Ppr.text (show err)-          return Nothing-        Right fhv -> do-          parsed <- obtainParsedTerm "Exception context location" 4 True anyTy (castForeignRef fhv)-            (maybeParser exceptionLocationTupleParser)-          case parsed of-            Left errs -> do-              logSDoc Logger.Debug $-                Ppr.text "Failed to parse exception context location:"-                  Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs)-              return Nothing-            Right Nothing -> return Nothing-            Right (Just (file, srcLine, col)) ->-              return $ Just SourceSpan-                { file = file-                , startLine = srcLine-                , startCol = col-                , endLine = srcLine-                , endCol = col-                }-    _ -> return Nothing--exceptionLocationTupleParser :: TermParser (String, Int, Int)-exceptionLocationTupleParser =-  (,,) <$> subtermWith 0 stringParser-       <*> subtermWith 1 intParser-       <*> subtermWith 2 intParser---- | This helper looks at the exception context for an exception, and retrieves--- the last entry of the HasCallStack backtrace.-exceptionLocationExpr :: String-exceptionLocationExpr = """-  let-    fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of-      Data.Maybe.Just (_, loc)-        -> Data.Maybe.Just-          ( GHC.Exception.srcLocFile loc-          , GHC.Exception.srcLocStartLine loc-          , GHC.Exception.srcLocStartCol loc)-    go exc =-      let ctx = Control.Exception.someExceptionContext exc-          bts :: [Control.Exception.Backtrace.Backtraces]-          bts = Control.Exception.Context.getExceptionAnnotations ctx-      in case bts of-           bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of-             Data.Maybe.Just cs -> fromCallStack cs-             Data.Maybe.Nothing -> Data.Maybe.Nothing-           [] -> Data.Maybe.Nothing-  in go-"""+import GHC.Debugger.Interface.Messages (SourceSpan(..))+import GHC.Utils.Outputable as Ppr+import qualified Colog.Core as Logger+#endif+import Control.Exception (SomeException)  -- | Retrieve structured exception information for the requested thread when -- the debugger is currently stopped on an exception.@@ -105,18 +42,21 @@     case (r_tid == req_tid, GHC.resumeBreakpointId r) of       (True, Nothing) -> do         let excRef = resumeApStack r-        fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext excRef+        fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext (castForeignRef excRef)       _ -> return defaultExceptionInfo  -- | Evaluate helper code inside the debuggee that turns the exception context -- into our 'ExceptionInfo' structure.-exceptionInfoFromContext :: ForeignHValue -> Debugger (Maybe ExceptionInfo)+exceptionInfoFromContext :: ForeignRef SomeException -> Debugger (Maybe ExceptionInfo) exceptionInfoFromContext excRef = do+#if MIN_VERSION_ghc(9,15,0)+  Just <$> Debuggee.collectExceptionInfo excRef+#else   -- 1. Add a "data" declaration for the datatype the expression will return   _ <- runDecls exceptionInfoData   -- 2. Gather information about the exception.   evalRes <- Remote.eval-    (Remote.raw exceptionInfoExpr `Remote.app` Remote.untypedRef excRef)+    (Remote.raw exceptionInfoExpr `Remote.app` Remote.ref excRef)   case evalRes of     Left err -> do       logSDoc Logger.Debug $@@ -142,14 +82,37 @@     <*> subtermWith 1 stringParser     <*> subtermWith 2 stringParser     <*> subtermWith 3 (maybeParser stringParser)-    <*> subtermWith 4 (parseList exceptionInfoParser)+    <*> subtermWith 4 (maybeParser exceptionLocationTupleParser)+    <*> subtermWith 5 (parseList exceptionInfoParser)+  where+    -- Parsed from @(String, Int, Int)@.+    exceptionLocationTupleParser :: TermParser SourceSpan+    exceptionLocationTupleParser = do+      locFile <- subtermWith 0 stringParser+      srcLine <- subtermWith 1 intParser+      srcCol <- subtermWith 2 intParser+      pure SourceSpan+        { file = locFile+        , startLine = srcLine+        , startCol = srcCol+        , endLine = srcLine+        , endCol = srcCol+        }  -- | Definition for the helper 'ExceptionInfoNode' data type compiled into the -- debuggee to aid in transporting nested exception information. -- We need a specific datatype because ExceptionInfoNode is recursive. exceptionInfoData :: String-exceptionInfoData =-  "data ExceptionInfoNode = ExceptionInfoNode String String String (Data.Maybe.Maybe String) [ExceptionInfoNode]"+exceptionInfoData = """+  data ExceptionInfoNode = ExceptionInfoNode+    { exceptionNodeTypeName :: String+    , exceptionNodeFullTypeName :: String+    , exceptionNodeMessage :: String+    , exceptionNodeContext :: Data.Maybe.Maybe String+    , exceptionNodeSourceSpan :: Data.Maybe.Maybe (String, Int, Int)+    , exceptionNodeInner :: [ExceptionInfoNode]+    }+  """  -- | Helper expression run in the debuggee that walks the exception context and -- populates the 'ExceptionInfoNode' structure.@@ -163,6 +126,7 @@                 rendered = Control.Exception.Context.displayExceptionContext ctx                 whileHandling = Control.Exception.Context.getExceptionAnnotations ctx                 innerNodes = Prelude.map (collectExceptionInfo Prelude.. unwrap) whileHandling+                sourceSpan = exceptionContextLocation ctx                 simpleTypeName = Data.Typeable.tyConName tc                 modulePrefix = case Data.Typeable.tyConModule tc of                   mdl | Prelude.null mdl -> \"\"@@ -175,30 +139,32 @@                 unwrap (Control.Exception.WhileHandling inner) = inner                 contextText = if Prelude.null rendered then Data.Maybe.Nothing else Data.Maybe.Just rendered             in ExceptionInfoNode-                 simpleTypeName-                 fullTypeName-                 (Control.Exception.displayException se')-                 contextText-                 innerNodes+                 { exceptionNodeTypeName = simpleTypeName+                 , exceptionNodeFullTypeName = fullTypeName+                 , exceptionNodeMessage = Control.Exception.displayException se'+                 , exceptionNodeContext = contextText+                 , exceptionNodeSourceSpan = sourceSpan+                 , exceptionNodeInner = innerNodes+                 }+      exceptionContextLocation ctx =+        let fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of+              Data.Maybe.Just (_, loc) ->+                Data.Maybe.Just+                  ( GHC.Exception.srcLocFile loc+                  , GHC.Exception.srcLocStartLine loc+                  , GHC.Exception.srcLocStartCol loc+                  )+              Data.Maybe.Nothing -> Data.Maybe.Nothing+            bts :: [Control.Exception.Backtrace.Backtraces]+            bts = Control.Exception.Context.getExceptionAnnotations ctx+        in case bts of+             bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of+               Data.Maybe.Just cs -> fromCallStack cs+               Data.Maybe.Nothing -> Data.Maybe.Nothing+             [] -> Data.Maybe.Nothing   in collectExceptionInfo   """----- | When no precise exception location is available, fall back to displaying a--- label derived from the provided 'SrcSpan'.-fallbackExceptionSourceSpan :: Maybe SrcSpan -> SourceSpan-fallbackExceptionSourceSpan mspan =-  let fileLabel = maybe "<exception>" spanLabel mspan-  in SourceSpan-       { file = fileLabel-       , startLine = 0-       , startCol = 0-       , endLine = 0-       , endCol = 0-       }-  where-    spanLabel (RealSrcSpan rss _) = unpackFS (srcSpanFile rss)-    spanLabel (UnhelpfulSpan reason) = unpackFS (unhelpfulSpanFS reason)+#endif  -- | Placeholder exception info returned when the context could not be -- inspected.@@ -208,14 +174,6 @@   , exceptionInfoFullTypeName = "Exception"   , exceptionInfoMessage = "Exception information not available"   , exceptionInfoContext = Nothing+  , exceptionInfoSourceSpan = Nothing   , exceptionInfoInner = []   }---- | Determine whether the debugger is currently stopped because of an--- exception (as opposed to a breakpoint).-currentlyStoppedOnException :: Debugger Bool-currentlyStoppedOnException = do-  resumes <- GHC.getResumeContext-  return $ case resumes of-    [] -> False-    r:_ -> isNothing (GHC.resumeBreakpointId r)

@@ -5,6 +5,7 @@ module GHC.Debugger.Stopped.Variables where  import Control.Monad.Reader+import qualified Colog.Core as Logger  import GHC import GHC.Types.FieldLabel@@ -12,7 +13,10 @@ import GHC.Types.Var import GHC.Runtime.Eval import GHC.Core.DataCon+import GHC.Core.FamInstEnv (topNormaliseType_maybe, emptyFamInstEnvs) import GHC.Core.TyCo.Rep+import GHC.Core.Reduction (Reduction(..))+import GHC.Tc.Instance.Family (tcGetFamInstEnvs, FamInstEnvs) import qualified GHC.Runtime.Debugger     as GHCD import qualified GHC.Runtime.Heap.Inspect as GHCI @@ -25,8 +29,8 @@  -- | 'TyThing' to 'VarInfo'. The 'Bool' argument indicates whether to force the -- value of the thing (as in @True = :force@, @False = :print@)-tyThingToVarInfo :: TyThing -> Debugger VarInfo-tyThingToVarInfo t = case t of+tyThingToVarInfo :: FamInstEnvs -> TyThing -> Debugger VarInfo+tyThingToVarInfo fam_envs t = case t of   AConLike c -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables   ATyCon c   -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables   ACoAxiom c -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables@@ -40,14 +44,14 @@   AnId i -> do     let key = FromId i     term <- obtainTerm key-    termToVarInfo key term+    termToVarInfo fam_envs 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 = do+termVarFields :: FamInstEnvs -> TermKey -> Term -> Debugger VarFields+termVarFields fam_envs top_key top_term = do    vcVarFields <- debugFieldsTerm top_term @@ -56,7 +60,7 @@     Just fls -> do        let keys = map (\(f_name, f_term) -> FromCustomTerm top_key f_name f_term) fls-      VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys+      VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo fam_envs k) keys      -- The general case     _ -> case top_term of@@ -67,61 +71,60 @@           -- Use indexed fields           [] -> do             let keys = zipWith (\ix _ -> FromPath top_key (PositionalIndex ix)) [1..] (dataConRepArgTys dc)-            VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys+            VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo fam_envs k) keys           -- Is a record data con,           -- Use field labels           dataConFields -> do             let mkPath ix Nothing = FromPath top_key (PositionalIndex ix)                 mkPath ix (Just fld) = FromPath top_key (LabeledField ix (flSelector fld))                 keys = zipWith mkPath [1..] ((Nothing <$ dataConOtherTheta dc) ++ (map Just dataConFields))-            VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys+            VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo fam_envs k) keys       NewtypeWrap{dc=Right dc, wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do         case dataConFieldLabels dc of           [] -> do             let key = FromPath top_key (PositionalIndex 1)-            wvi <- obtainTerm key >>= termToVarInfo key+            wvi <- obtainTerm key >>= termToVarInfo fam_envs key             return (VarFields [wvi])           [fld] -> do             let key = FromPath top_key (LabeledField 1 (flSelector fld))-            wvi <- obtainTerm key >>= termToVarInfo key+            wvi <- obtainTerm key >>= termToVarInfo fam_envs key             return (VarFields [wvi])           _ -> error "unexpected number of Newtype fields: larger than 1"       RefWrap{wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do         let key = FromPath top_key (PositionalIndex 1)-        wvi <- obtainTerm key >>= termToVarInfo key+        wvi <- obtainTerm key >>= termToVarInfo fam_envs key         return (VarFields [wvi])       _ -> return (VarFields [])   -- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds-termToVarInfo :: TermKey -> Term -> Debugger VarInfo-termToVarInfo key term0 = do+--   The @FamInstEnvs@ is used to look through newtypes and type families when checking if suspensions are of function type.+termToVarInfo :: FamInstEnvs -> TermKey -> Term -> Debugger VarInfo+termToVarInfo fam_envs key term0 = do   -- Make a VarInfo for a term   let     ty = GHCI.termType term0 -    -- Check for function types explicitly since they seem to always match Suspension-    -- but should not be shown as thunks in the UI.-    checkFn (FunTy _ _ _ _) = True-    checkFn (ForAllTy _ t) = checkFn t-    checkFn _ = False-    isFn = checkFn ty-   varName <- display key   varType <- display ty   case term0 of+    t | Suspension{} <- unwrapNewtype t, isFunctionType ty -> do+      return VarInfo+        { varName+        , varType+        , varValue = "<fn> :: " ++ varType+        , varRef = NoVariables+        , isThunk = False+        }+     -- The simple case: The term is a a thunk...     Suspension{} -> do       return VarInfo         { varName         , varType-        , varValue = if isFn-            then "<fn> :: " ++ varType-            else "_"-        , varRef = if isFn-            then NoVariables-            else SpecificVariable key -- allows forcing the thunk-        , isThunk = not isFn+        , varValue = "_"+        , varRef = SpecificVariable key -- allows forcing the thunk+        , isThunk = True         }      -- Otherwise, try to apply and decode a custom 'DebugView', or default to@@ -182,8 +185,45 @@       Prim{}         -> False       NewtypeWrap{}  -> True       RefWrap{}      -> True-      Term{subTerms} -> not $ null subTerms+      Term{subTerms} -> not $ null $ subTerms+    -- Check for function types explicitly since they seem to always match Suspension+    -- but should not be shown as thunks in the UI.+    isFunctionType = \case+      (FunTy _ _ _ _) -> True+      (ForAllTy _ t)  -> isFunctionType t+      (topNormaliseType_maybe fam_envs -> Just Reduction{..})+        -> isFunctionType reductionReducedType+      _ -> False+    -- FIXME: couldn't find test case where this is needed.+    unwrapNewtype (NewtypeWrap {wrapped_term}) = unwrapNewtype wrapped_term+    unwrapNewtype x = x +-- | Thin wrapper around @tcGetFamInstEnvs@, using @runTcInteractive@+getFamInstEnvs' :: Debugger FamInstEnvs+getFamInstEnvs' = do+  hsc_env <- getSession+  (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ tcGetFamInstEnvs+  case res of+    Just fam_envs -> pure fam_envs+    Nothing -> do+      logSDoc Logger.Debug+        $ text "Couldn't lookup FamInstEnvs to normalise type for VarInfo,"+        <+> text "using empty ones."+        $$  ppr err_msgs+      return emptyFamInstEnvs++pprTerm :: Term -> SDoc+pprTerm t = case t of+  Term{dc,subTerms} -> annotate "T:" $+    either text ppr dc <+> ppr (map pprTerm subTerms)+  Prim{valRaw} -> annotate "P:" $ ppr valRaw+  Suspension{bound_to,ctype} -> annotate "S:" $ ppr bound_to <+> text (show ctype)+  NewtypeWrap{dc,wrapped_term} ->+    annotate "N:" $ either text ppr dc <+> pprTerm wrapped_term+  RefWrap{wrapped_term} -> annotate "R:" $ pprTerm wrapped_term+  where+    annotate tag d = parens $ text tag <+> ppr (ty t) <+> text "∋" <+> d+ -- | Forces a term to WHNF -- -- The term is updated in the cache at the given key.@@ -191,4 +231,3 @@ forceTerm term = do   hsc_env <- getSession   liftIO $ seqTerm hsc_env term-

@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Debugger.Utils.Orphans where++import GHC.Debugger.View.Class+import GHC.Data.FastString++instance DebugView FastString where+  debugValue  t = simpleValue (unpackFS t) False+  debugFields _ = pure (VarFields [])

@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} module Development.Debug.Adapter where  import Control.Concurrent.MVar@@ -12,6 +13,7 @@ import DAP import qualified GHC import qualified GHC.Debugger.Interface.Messages as D (Command, Response, RemoteThreadId, VariableReference)+import Network.Socket (PortNumber)  type DebugAdaptor = Adaptor DebugAdaptorState Request type DebugAdaptorCont = Adaptor DebugAdaptorState ()@@ -24,22 +26,18 @@ --    - The debugger main worker writes to this MVar responses (and, for now, events too) --    - The handler worker reads from this MVar and writes them to the client with the 'Adapter'. data DebugAdaptorState = DAS-      { syncRequests :: MVar D.Command+      { syncRequests  :: MVar D.Command       , syncResponses :: MVar D.Response-      , nextFreshId :: !Int+      , nextFreshId   :: !Int       , breakpointMap :: Map.Map GHC.InternalBreakpointId BreakpointSet       , stackFrameMap :: IM.IntMap StackFrameIx       , variablesMap  :: IM.IntMap VariablesIx-      , entryFile :: FilePath-      , entryPoint :: String-      , entryArgs :: [String]-      , projectRoot :: FilePath-      , syncProxyIn :: Chan BS.ByteString-        -- ^ Read input to the debuggee from the proxy-      , syncProxyOut :: Chan BS.ByteString-        -- ^ Write output from the debuggee to the proxy-      , syncProxyErr :: Chan BS.ByteString-        -- ^ Write stderr from the debuggee to the proxy+      , entryFile     :: FilePath+      , entryPoint    :: String+      , entryArgs     :: [String]+      , projectRoot   :: FilePath+      , runInTerminalProc :: RunInTerminalProc+        -- ^ Potentially a process launched via 'runInTerminal'.       }  type BreakpointId = Int@@ -50,9 +48,56 @@ data VariablesIx = VariablesIx StackFrameIx D.VariableReference  instance MonadFail DebugAdaptor where-  fail a = error a-  -- TODO: PROPER ERROR HANDLING with termination, possibly delete this instance-  -- use: exitWithMsg.+  fail a = sendError (ErrorMessage (T.pack a)) Nothing++--------------------------------------------------------------------------------+-- * Run in terminal+--------------------------------------------------------------------------------++-- | A process launched via 'runInTerminal', which is attached to a user's terminal+data RunInTerminalProc+  -- | We're not using 'runInTerminal', so we didn't request the DAP client to+  -- launch a process on the user's terminal.+  = NoRunInTerminal++  -- | Instead of launching the external interpreter ourselves, we requested+  -- the DAP client to launch the external interpreter process+  | RunExternalInterpreterInTerminal+      { extInterpPort :: PortNumber+        -- ^ The port on which the external interpreter is running.+        --+        -- The external interpreter is only connected to a port when we launch+        -- it ourselves through 'runInTerminal'.+        --+        -- When 'NoRunInTerminal' but using external-interpreter, we'll still+        -- launch the external interpreter but in the default GHC way using the+        -- file descriptors directly.+      }++  -- | We launched @hdb proxy ...@ on the user's terminal.+  --+  -- This process will forward all input the user types into the+  -- debugger/debuggee process and be forwarded the debuggee's output to print.+  --+  -- We should always prefer to launch 'RunExternalInterpreterInTerminal'+  -- directly, but is not possible if using the internal interpreter.+  --+  -- See 'Development.Debug.Adapter.Proxy' for more details on @hdb proxy@.+  | RunProxyInTerminal+      { syncProxyIn :: Chan BS.ByteString+        -- ^ Read input to the debuggee from the proxy+      , syncProxyOut :: Chan BS.ByteString+        -- ^ Write output from the debuggee to the proxy+      , syncProxyErr :: Chan BS.ByteString+        -- ^ Write stderr from the debuggee to the proxy+      , proxyClientReady :: MVar ()+        -- ^ Wait for the runInTerminal proxy client to connect to the proxy+        -- server (#95).+        --+        -- Prevent a race where the debug session finishes before the+        -- 'runInTerminal' proxy has a chance to connect, so when it does+        -- finally try to connect it crashes.+      }  -------------------------------------------------------------------------------- -- * Utilities

@@ -7,6 +7,7 @@ import Text.Read import Control.Monad import Data.Maybe+import System.FilePath ((</>), normalise)  import qualified GHC @@ -63,6 +64,7 @@                     }         (readMaybe @Int =<< (T.unpack <$> DAP.sourceBreakpointHitCondition bp))         (T.unpack <$> DAP.sourceBreakpointCondition bp)+        (T.unpack <$> DAP.sourceBreakpointLogMessage bp)     registerBreakFound bf    sendSetBreakpointsResponse (concat breaks)@@ -84,6 +86,7 @@         FunctionBreak { function  = T.unpack $ DAP.functionBreakpointName bp }         (readMaybe @Int =<< (T.unpack <$> DAP.functionBreakpointHitCondition bp))         (T.unpack <$> DAP.functionBreakpointCondition bp)+        Nothing     registerBreakFound bf    sendSetFunctionBreakpointsResponse (concat breaks)@@ -101,11 +104,11 @@   let breakOnError      = BREAK_ON_ERROR `elem` setExceptionBreakpointsArgumentsFilters    when breakOnExceptions $ do-    DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak Nothing Nothing)+    DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak Nothing Nothing Nothing)     pure ()    when breakOnError $ do-    DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak Nothing Nothing)+    DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak Nothing Nothing Nothing)     pure ()    sendSetExceptionBreakpointsResponse@@ -153,8 +156,9 @@ -- TODO: Handles sourceReferences too fileFromSourcePath :: Source -> DebugAdaptor FilePath fileFromSourcePath source = do+  prjRoot <- projectRoot <$> getDebugSession   let     file = T.unpack $             fromMaybe (error "sourceReference unsupported") $               sourcePath source-  return file+  return $ normalise $ prjRoot </> file

@@ -57,7 +57,7 @@       sendEvaluateResponse (simpleEvalResp (T.pack e) (T.pack ""))     EvalException {resultVal, resultType} ->       sendEvaluateResponse (simpleEvalResp (T.pack resultVal) (T.pack resultType))-    EvalCompleted{resultVal, resultType, resultStructureRef} -> do+    EvalCompleted{resultVal, resultType, resultSourceKind, resultStructureRef} -> do       varIx <- case resultStructureRef of         NoVariables     -> pure 0         LocalVariables  -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"@@ -73,11 +73,16 @@               }           pure varId +      let orIfNoResult !x !y+            | Just IsStmt <- resultSourceKind = y+            | resultType == "()" = y+            | otherwise = x+       sendEvaluateResponse EvaluateResponse-        { evaluateResponseResult             = T.pack resultVal-        , evaluateResponseType               = T.pack resultType+        { evaluateResponseResult             = T.pack resultVal `orIfNoResult` T.empty+        , evaluateResponseType               = T.pack resultType `orIfNoResult` T.empty         , evaluateResponsePresentationHint   = Nothing-        , evaluateResponseVariablesReference = varIx+        , evaluateResponseVariablesReference = varIx `orIfNoResult` 0         , evaluateResponseNamedVariables     = Nothing         , evaluateResponseIndexedVariables   = Nothing         , evaluateResponseMemoryReference    = Nothing@@ -127,4 +132,3 @@           = maybe [] IS.toList (M.lookup bid breakpointMap)       , stoppedEventThreadId = Just $ remoteThreadIntRef breakThread       }-

@@ -22,93 +22,26 @@ -- * @'destroyDebugSession'@ kills all threads started for this session with @'registerNewDebugSession'@. module Development.Debug.Adapter.Exit where -import DAP-import Data.Function-import System.IO-import Control.Monad+import Control.Monad.Except import Control.Monad.IO.Class-import Control.Exception-import Control.Exception.Context-import qualified Data.Text as T-import qualified Data.Text.IO as T-+import DAP import Development.Debug.Adapter-import qualified Development.Debug.Adapter.Output as Output  -- | Command terminate (1a) ----- Terminate the debuggee gracefully.+-- Terminate the *debuggee* gracefully commandTerminate :: DebugAdaptor () commandTerminate = do-  -- Terminate debuggee and sends acknowledgment.-  -- TODO: Terminate event instead of destroy session?-  -- DidTerminate <- sendInterleaved TerminateProcess sendTerminateResponse-  destroyDebugSession+  destroyDebugSession -- kills debugger GHC session (which handles stopping the debuggee ext-interp too)   sendTerminateResponse-  exitCleanly Nothing+  sendTerminatedEvent (TerminatedEvent False) -- we're done debugging now!  -- | Command disconnect (1b) -- -- Terminate the debuggee (and any child processes) forcefully. commandDisconnect :: DebugAdaptor () commandDisconnect = do-  destroyDebugSession+  -- kills debugger GHC session (which handles stopping the debuggee ext-interp too)+  -- ignore error if session has already been destroyed (e.g. client sends disconnect after terminate)+  destroyDebugSession `catchError` \ e -> liftIO $ putStrLn ("terminateSessionCleanly: ignoring missing session: " ++ show e)   sendDisconnectResponse-  exitCleanly Nothing----- Exit Cleanly ------------------------------------------------------------------- | Outputs a message notification ('Output.important'), sends a terminated--- event, destroys the debug session, and dies.------ ::WARNING::------ This function should not be called if the debugsession with the debugger--- threads haven't yet been registered because it WILL block on the call to--- @'destroyDebugSession'@.-exitCleanupWithMsg-  :: Handle-  -- ^ Handle to finalize reading as OutputEvents before exiting (but after-  -- killing the output thread with @destroyDebugSession@)-  -> String-  -- ^ Error message, logged with notification-  -> DebugAdaptor ()-exitCleanupWithMsg final_handle msg = do-  destroyDebugSession -- kill all session threads (including the output thread)-  has_data <- hReady final_handle & liftIO-  when has_data $ do-      -- get all pending output from GHC-      c <- T.hGetContents final_handle & liftIO-      Output.neutral c-  exitWithMsg msg---- | Logs the error to the debug console and sends a terminate event-exitWithMsg :: String -> DebugAdaptor a-exitWithMsg msg = do-  Output.important (T.pack msg)-  exitCleanly (Just msg)--exitCleanly :: Maybe String -> DebugAdaptor a-exitCleanly mm = do--  sendTerminatedEvent (TerminatedEvent False)--  -- We exit here to guarantee the process is killed when-  -- terminated. Important! We want a new server process per-  -- session, which means at the end we must kill the server.-  liftIO $ do-    case mm of-      Nothing -> throwIO TerminateServer-      Just em -> do-        hPutStrLn stderr em-        throwIO TerminateServer----- Utils -------------------------------------------------------------------------- | Display an exception with its context-displayExceptionWithContext :: SomeException -> String-displayExceptionWithContext ex = do-  case displayExceptionContext (someExceptionContext ex) of-    "" -> displayException ex-    cx -> displayException ex ++ "\n\n" ++ cx-

@@ -0,0 +1,47 @@+module Development.Debug.Adapter.Exit.Helpers where++import DAP+import Data.Function+import System.IO+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Development.Debug.Adapter+import qualified Development.Debug.Adapter.Output as Output++--- Exit Cleanly ---------------------------------------------------------------++-- | Outputs a message notification ('Output.important'), sends a terminated+-- event, destroys the debug session, and dies.+--+-- ::WARNING::+--+-- This function should not be called if the debugsession with the debugger+-- threads haven't yet been registered because it WILL block on the call to+-- @'destroyDebugSession'@.+exitCleanupWithMsg+  :: Handle+  -- ^ Handle to finalize reading as OutputEvents before exiting (but after+  -- killing the output thread with @destroyDebugSession@)+  -> String+  -- ^ Error message, logged with notification+  -> DebugAdaptor ()+exitCleanupWithMsg final_handle msg = do+  has_data <- hReady final_handle & liftIO+  when has_data $ do+      -- get all pending output from GHC+      c <- T.hGetContents final_handle & liftIO+      Output.neutral c+  terminateWithError msg++-- | Abruptly terminate a session in the middle of a Request/Response cycle by+-- sending a Terminated event (meaning the debug session is over), destroying+-- the debug session threads, and replying to the response with 'ErrorResponse'+terminateWithError :: String -> DebugAdaptor ()+terminateWithError msg = do+  Output.important (T.pack msg)+  destroyDebugSession+  sendTerminatedEvent (TerminatedEvent False)+  sendError (ErrorMessage (T.pack msg)) Nothing

@@ -9,6 +9,11 @@ -- | TODO: This module should be called Launch. module Development.Debug.Adapter.Init where +#if !MIN_VERSION_ghc(9,15,0)+-- no longer needs to be imported from here in 9.15+import GHC.Conc.Sync (labelThread)+#endif+ import GHC.IO.Handle import System.Process import qualified Data.ByteString as BS@@ -16,17 +21,18 @@ import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T import qualified System.Process as P+import Control.Exception (displayExceptionWithInfo) import Control.Monad.Except import Control.Monad.Trans import Data.Function import Data.Functor import Data.Maybe+import Data.UUID.V4 qualified as UUID import System.IO import GHC.IO.Encoding import Control.Monad.Catch-import Control.Exception (SomeAsyncException, throwIO, IOException)+import Control.Exception (throwIO, IOException) import Control.Concurrent-import GHC.Conc.Sync (labelThread) import Control.Monad import Data.Aeson as Aeson import GHC.Generics@@ -35,7 +41,6 @@ import Data.Functor.Contravariant  import Development.Debug.Adapter-import Development.Debug.Adapter.Exit import Colog.Core as Logger import qualified Development.Debug.Adapter.Output as Output @@ -49,6 +54,10 @@ import DAP import Development.Debug.Adapter.Handles import Development.Debug.Session.Setup+import Development.Debug.Adapter.Proxy+import System.Environment+import Network.Socket (socketPort)+import qualified Network.Socket as Socket  -------------------------------------------------------------------------------- -- * Client@@ -80,20 +89,17 @@ data DAPLog   = DAPSessionSetupLog (WithSeverity SessionSetupLog)   | DAPDebuggerLog Debugger.DebuggerLog+  | RunProxyServerLog (WithSeverity T.Text)  -------------------------------------------------------------------------------- -- * Launch Debugger -------------------------------------------------------------------------------- ---- | Exception type for when hie-bios initialization fails-newtype InitFailed = InitFailed String deriving Show- -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise initDebugger :: LogAction IO DAPLog -> Bool -> Bool-             -> LaunchArgs -> ExceptT InitFailed DebugAdaptor ()+             -> LaunchArgs -> DebugAdaptor () initDebugger l supportsRunInTerminal preferInternalInterpreter                LaunchArgs{ __sessionId                          , projectRoot = givenRoot@@ -104,12 +110,9 @@                          } = do   syncRequests  <- liftIO newEmptyMVar   syncResponses <- liftIO newEmptyMVar-  syncProxyIn   <- liftIO newChan-  syncProxyOut  <- liftIO newChan-  syncProxyErr  <- liftIO newChan    entryFile <- case entryFileMaybe of-    Nothing -> throwError $ InitFailed "Missing \"entryFile\" key in debugger configuration"+    Nothing -> throwError ("Missing \"entryFile\" key in debugger configuration", Nothing)     Just ef -> pure ef    projectRoot <- maybe (liftIO getCurrentDirectory) pure givenRoot@@ -135,66 +138,127 @@           | otherwise -> mempty    liftIO (runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile)) >>= \case-    Left e              -> throwError $ InitFailed e-    Right (Left e)      -> lift       $ exitWithMsg e+    Left e              -> throwError (ErrorMessage (T.pack e), Nothing)+    Right (Left e)      -> throwError (ErrorMessage (T.pack e), Nothing)     Right (Right flags) -> do-      -- Create the stdin handle for the external interpreter-      (readExternalIntStdin, writeExternalIntStdin) <- liftIO P.createPipe-      liftIO $ do-        hSetBuffering readExternalIntStdin LineBuffering-        hSetBuffering writeExternalIntStdin NoBuffering-        hSetEncoding readExternalIntStdin utf8-        hSetEncoding writeExternalIntStdin utf8 -      let nextFreshId = 0-          breakpointMap = mempty-          stackFrameMap = mempty-          variablesMap  = mempty-          defaultRunConf = Debugger.RunDebuggerSettings-            { supportsANSIStyling = True     -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap-            , supportsANSIHyperlinks = False -- VSCode does not support this-            , preferInternalInterpreter-            , externalInterpreterStdinStream = UseHandle readExternalIntStdin-            }+      let+        nextFreshId = 0+        breakpointMap = mempty+        stackFrameMap = mempty+        variablesMap  = mempty -      finished_init <- liftIO $ newEmptyMVar+        mkRunInTerminalProc+          | not supportsRunInTerminal+          = pure NoRunInTerminal+          | not preferInternalInterpreter+          = do+            sock <- openSocketAvailablePort+            port <- socketPort sock+            -- Close socket again to make sure we can open the server socket+            -- later again.+            Socket.close sock+            pure RunExternalInterpreterInTerminal+              { extInterpPort  = port+              }+          | otherwise+          = do+            (syncProxyIn, syncProxyOut, syncProxyErr)+                             <- (,,) <$> newChan <*> newChan <*> newChan+            proxyClientReady <- newEmptyMVar+            pure RunProxyInTerminal{..} +      runInTerminalProc <- liftIO mkRunInTerminalProc+       dbgLog <- liftIO $-        createDebuggerLogger l dapLogger writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr)+        createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc -      let absEntryFile = normalise $ projectRoot </> entryFile-      lift $ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..}-        [ debuggerThread dbgLog finished_init projectRoot flags-            extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses+      (runInTerminalThreads, afterRegisterActions) <-+        mkRunInTerminalThreads l runInTerminalProc preferInternalInterpreter +      let+        defaultRunConf = Debugger.RunDebuggerSettings+          { supportsANSIStyling = True     -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap+          , supportsANSIHyperlinks = False -- VSCode does not support this+          , preferInternalInterpreter+          , externalInterpreterCustomProc = case runInTerminalProc of+              RunExternalInterpreterInTerminal{extInterpPort}+                -> Right extInterpPort+              _ -> Left CreatePipe -- if not runInTerminal, just create a new pipe for stdin+          }+        absEntryFile = normalise $ projectRoot </> entryFile+        daState = DAS{entryFile=absEntryFile,..}++      sessionId <- liftIO $ maybe (("debug-session:" <>) . T.show <$> UUID.nextRandom) (pure . T.pack) __sessionId+      registerNewDebugSession sessionId daState $+        [ debuggerThread dbgLog flags extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses         , \withAdaptor -> forwardHandleToLogger readDAPOutput $             LogAction (\msg -> withAdaptor (Output.neutral msg))--        -- Setup capturing of the process' own stdout and forwarding of the process' own stdin,-        -- but only if we're using the internal interpreter!-        , if preferInternalInterpreter then stdinForwardThread  supportsRunInTerminal syncProxyIn  else mempty-        , if preferInternalInterpreter then stdoutCaptureThread supportsRunInTerminal syncProxyOut else mempty-        , if preferInternalInterpreter then stderrCaptureThread supportsRunInTerminal syncProxyErr else mempty-        , if preferInternalInterpreter-            then mempty-            else const $ do-              -- forward proxy in to external interpreter stdin-              forever $ do-                i <- readChan syncProxyIn-                -- 3. Write to write-end of the pipe-                BS.hPut writeExternalIntStdin i >> hFlush writeExternalIntStdin         ]+        +++        runInTerminalThreads -      -- Do not return until the initialization is finished-      liftIO (takeMVar finished_init) >>= \case-        Right () -> pure ()-        Left e   -> do-          -- The process terminates cleanly with an error code (probably exit failure = 1)-          -- This can happen if compilation fails and the compiler exits cleanly.-          ---          -- Instead of signalInitialized, respond with error and exit.-          lift $ exitCleanupWithMsg readDAPOutput e+      afterRegisterActions +-- | Additional threads to register for this session depending on the process+-- we're running through `runInTerminal` (see 'RunInTerminalProc').+mkRunInTerminalThreads+  :: LogAction IO DAPLog+  -> RunInTerminalProc+  -> Bool -- ^ Use internal interpreter+  -> DebugAdaptor ([(DebugAdaptorCont () -> IO ()) -> IO ()], DebugAdaptor ())+    -- ^ Threads to register in this debug session and additional commands to+    -- run after registering the session.++mkRunInTerminalThreads _ NoRunInTerminal useInternalInterp+  -- Not using the terminal proxy, but we still want to output our own+  -- stdout/err (from the internal interpreter) as console events.+  | True <- useInternalInterp+  = pure ([ stdoutCaptureThread Nothing, stderrCaptureThread Nothing ], pure ())++  | otherwise+  = pure ([], pure ())++mkRunInTerminalThreads _ RunExternalInterpreterInTerminal{..} _+  -- No additional bookkeeping is needed in this case because GHC will+  -- naturally have to wait for the external interpreter in order to start execution+  = do+  thisProg <- liftIO getExecutablePath -- run the same `hdb` executable in `proxy` mode+  pure ([],+    sendRunInTerminalReverseRequest+      RunInTerminalRequestArguments+        { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated+        , runInTerminalRequestArgumentsTitle = Nothing+        , runInTerminalRequestArgumentsCwd = ""+        , runInTerminalRequestArgumentsArgs =+            [T.pack thisProg, "external-interpreter", "--port", T.pack (show extInterpPort)]+        , runInTerminalRequestArgumentsEnv = Nothing+        , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False+        })++mkRunInTerminalThreads l RunProxyInTerminal{..} _+  = do+    (serverPort, serverProxyThread) <-+      mkServerSideHdbProxy (contramap RunProxyServerLog l)+        syncProxyIn syncProxyOut syncProxyErr proxyClientReady++    pure (+      [ ($ serverProxyThread)++      -- Setup capturing of the process' own stdout and forwarding of the process' own stdin,+      -- but only because we're using the internal interpreter!+      , stdinForwardThread  syncProxyIn+      , stdoutCaptureThread (Just syncProxyOut)+      , stderrCaptureThread (Just syncProxyErr)+      ],++      -- When using the internal interpreter and 'runInTerminal' is supported+      -- (the 'RunProxyInTerminal' case), we ask the DAP client to launch the+      -- `hdb proxy` attached to the user's terminal. The proxy forwards+      -- input/output from the user terminal to the debugger+debuggee shared process+      sendRunProxyInTerminal serverPort+      )+ -- | The main debugger thread launches a GHC.Debugger session. -- -- Then, forever:@@ -204,17 +268,7 @@ -- -- Concurrently, it reads from the process's stderr forever and outputs it through OutputEvents. ----- Notes:------ (CWD):---    It's necessary for the GHC session to be run in the project root.---    We do this by setting the current directory on initialize.---    This sets the global CWD for this process, disallowing multiple sessions---    at the same, but that's OK because we currently only support---    single-session mode. Each new session gets a new debugger process. debuggerThread :: LogAction IO Debugger.DebuggerLog-               -> MVar (Either String ()) -- ^ To signal when initialization is complete.-               -> FilePath        -- ^ Working directory for GHC session                -> HieBiosFlags    -- ^ GHC Invocation flags                -> [String]        -- ^ Extra ghc args                -> FilePath@@ -224,10 +278,7 @@                -> (DebugAdaptorCont () -> IO ())                -- ^ Allows unlifting DebugAdaptor actions to IO. See 'registerNewDebugSession'.                -> IO ()-debuggerThread l finished_init workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do--  -- See Notes (CWD) above-  setCurrentDirectory workDir+debuggerThread l HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do    -- Log haskell-debugger invocation   withAdaptor $@@ -236,33 +287,23 @@       "units: " <> unwords units <> "\n" <>       "args: " <> unwords (ghcInvocation ++ extraGhcArgs) -  catches-    (do-      Debugger.runDebugger l rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do-        liftIO $ do-          tid <- myThreadId-          labelThread tid "Main Debugger Thread"-        liftIO $ signalInitialized (Right ())-        forever $ do+  Debugger.runDebugger l rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do+    liftIO $ do+      tid <- myThreadId+      labelThread tid "Main Debugger Thread"+    let loop = do           req <- takeMVar requests & liftIO           resp <- (Debugger.execute req <&> Right)-                    `catch` \(e :: SomeException) ->-                        pure (Left (displayExceptionWithContext e))-          either bad reply resp-    )-    [ Handler $ \(e::SomeAsyncException) -> do-        throwIO e-    , Handler $ \(e::SomeException) -> do-        signalInitialized (Left (displayException e))-    ]--  where-    signalInitialized-          = putMVar finished_init-    reply = liftIO . putMVar replies-    bad m = liftIO $ do-      hPutStrLn stderr m-      putMVar replies (Aborted ("Aborted debugger thread: " ++ m))+                    `catch` \(e :: SomeException) -> do+                        pure (Left (displayExceptionWithInfo e))+          case resp of+            Right x -> do+              liftIO (putMVar replies x)+              loop+            Left m ->+              -- don't loop in this case! just exit.+              liftIO $ putMVar replies (Aborted ("Aborted debugger thread: " ++ m))+    loop  -------------------------------------------------------------------------------- -- * Logging@@ -287,9 +328,9 @@   :: LogAction IO DAPLog   -> LogAction IO T.Text -- ^ Logger that writes to to DAP output   -> Handle              -- ^ Handle to DAP output-  -> (Bool, Chan BS.ByteString, Chan BS.ByteString) -- ^ Proxy channels, and whether is supported+  -> RunInTerminalProc   -> IO (LogAction IO Debugger.DebuggerLog)-createDebuggerLogger l dapLogger writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr) = do+createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc = do   return $     -- (1) (all output is logged to normal logger)     contramap DAPDebuggerLog l <>@@ -300,56 +341,65 @@             dapLogger <& T.pack (show msg)         Debugger.GHCLog logflags msg_class srcSpan msg ->           defaultLogActionWithHandles writeDAPOutput writeDAPOutput logflags msg_class srcSpan msg-        Debugger.LogDebuggeeOut txt -> debuggeeOut dapLogger syncProxyOut txt-        Debugger.LogDebuggeeErr txt -> debuggeeOut dapLogger syncProxyErr txt+        Debugger.LogDebuggeeOut txt -> debuggeeOut dapLogger msyncProxyOut txt+        Debugger.LogDebuggeeErr txt -> debuggeeOut dapLogger msyncProxyErr txt         _ -> pure () -- don't log other messages, already logged to (1)         )   where-    debuggeeOut l' proxyChan txt = do+    debuggeeOut l' mproxyChan txt = do       -- (2)       l' <& txt       -- (3)-      when supportsRunInTerminal $-        writeChan proxyChan $-          T.encodeUtf8 (txt <> "\n")+      case mproxyChan of+        Nothing -> pure ()+        Just proxyChan ->+          writeChan proxyChan $+            T.encodeUtf8 (txt <> "\n") +    (msyncProxyOut, msyncProxyErr)+      | RunProxyInTerminal{syncProxyOut, syncProxyErr} <- runInTerminalProc+      = (Just syncProxyOut, Just syncProxyErr)+      | otherwise+      = (Nothing, Nothing)+ -------------------------------------------------------------------------------- -- * Capturing stdout, stderr, and writing to self stdin --------------------------------------------------------------------------------  -- | Hijack the current process stdin and forward to it the messages from the given channel-stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()-stdinForwardThread runInTerminal syncIn _withAdaptor = do+stdinForwardThread :: Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()+stdinForwardThread syncIn _withAdaptor = do   tid <- myThreadId   labelThread tid "Stdin Forward Thread"-  when runInTerminal $ do-    -- We need to hijack stdin to write to it -    -- 1. Create a new pipe from writeEnd->readEnd-    (readEnd, writeEnd) <- createPipe+  -- We need to hijack stdin to write to it -    -- 2. Substitute the read-end of the pipe by stdin-    _ <- hDuplicateTo readEnd stdin-    hClose readEnd -- we'll never need to read from readEnd+  -- 1. Create a new pipe from writeEnd->readEnd+  (readEnd, writeEnd) <- createPipe -    forever $ do-      i <- readChan syncIn-      -- 3. Write to write-end of the pipe-      BS.hPut writeEnd i >> hFlush writeEnd+  -- 2. Substitute the read-end of the pipe by stdin+  _ <- hDuplicateTo readEnd stdin+  hClose readEnd -- we'll never need to read from readEnd +  forever $ do+    i <- readChan syncIn+    -- 3. Write to write-end of the pipe+    BS.hPut writeEnd i >> hFlush writeEnd+ -- | This thread captures stdout from the debuggee and sends it to the client. -- NOTE, redirecting the stdout handle is a process-global operation. So this thread -- will capture ANY stdout the debuggee emits. Therefore you should never directly -- write to stdout, but always write to the appropiate handle.-stdoutCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()-stdoutCaptureThread runInTerminal syncOut withAdaptor = do+stdoutCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO ()+stdoutCaptureThread msyncOut withAdaptor = do   tid <- myThreadId-  labelThread tid "Stdin Capture Thread"+  labelThread tid "Stdout Capture Thread"   withInterceptedStdout $ \_ interceptedStdout -> do     forever $ do       line <- liftIO $ T.hGetLine interceptedStdout-      when runInTerminal $-        writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n")+      case msyncOut of+        Nothing -> pure ()+        Just syncOut -> writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n")        -- Always output to Debug Console       catch@@ -358,15 +408,16 @@           throwIO (FailedToWriteToAdaptor line))  -- | Like 'stdoutCaptureThread' but for stderr-stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()-stderrCaptureThread runInTerminal syncErr withAdaptor = do+stderrCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO ()+stderrCaptureThread msyncErr withAdaptor = do   tid <- myThreadId   labelThread tid "Stderr Capture Thread"   withInterceptedStderr $ \_ interceptedStderr -> do     forever $ do       line <- liftIO $ T.hGetLine interceptedStderr-      when runInTerminal $-        writeChan syncErr $ T.encodeUtf8 (line <> "\n")+      case msyncErr of+        Nothing -> pure ()+        Just syncErr -> writeChan syncErr $ T.encodeUtf8 (line <> "\n")        -- Always output to Debug Console       catch

@@ -9,7 +9,6 @@  import GHC.Debugger.Interface.Messages as D import Development.Debug.Adapter-import Development.Debug.Adapter.Exit import qualified Development.Debug.Adapter.Output as Output  -- | Synchronously send a command to the debugger and await a response@@ -30,6 +29,8 @@ handleAbort :: Response -> DebugAdaptor Response handleAbort (Aborted e) = do   Output.console (T.pack e)-  exitCleanly (Just e)+  sendTerminatedEvent (TerminatedEvent False)+  destroyDebugSession -- kill this debu session's threads+  -- reply still in thia connection with "ErrorResponse" to pending request+  sendError (ErrorMessage (T.pack e)) Nothing handleAbort r = return r-

@@ -1,11 +1,26 @@-{-# LANGUAGE BlockArguments, OverloadedStrings, DerivingStrategies #-}+{-# LANGUAGE BlockArguments, OverloadedStrings, DerivingStrategies, OrPatterns #-}+{-# LANGUAGE NondecreasingIndentation #-} -- | Run the proxy mode, which forwards stdin/stdout to/from the DAP server and--- is displayed in a terminal in the DAP client using 'runInTerminal'+-- is displayed in a terminal in the DAP client using 'runInTerminal'.+--+-- Note: the proxy program is only launched when 'runInTerminal' is supported+-- and we're using the internal interpreter (--internal-interpreter).+--+-- If the external interpreter is being used (the default), we launch the+-- external interpreter directly with 'runInTerminal' and don't need the proxy+-- at all. module Development.Debug.Adapter.Proxy-  ( serverSideHdbProxy+  ( mkServerSideHdbProxy   , runInTerminalHdbProxy+  , sendRunProxyInTerminal+  , openSocketAvailablePort   ) where +#if !MIN_VERSION_ghc(9,15,0)+-- no longer needs to be imported in 9.15+import GHC.Conc.Sync (labelThread)+#endif+ import DAP  import Control.Concurrent.Async@@ -17,7 +32,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Concurrent-import GHC.Conc.Sync (labelThread) import qualified Data.List.NonEmpty as NE  import qualified Data.Text as T@@ -29,6 +43,7 @@  import Colog.Core import Development.Debug.Adapter+import qualified Control.Exception as E  -- | Fork a new thread to run the server-side of the proxy. --@@ -40,25 +55,21 @@ -- 2. In a loop, -- 2.1 Read stdin from the socket and push it to a Chan -- 2.1 Read from a stdout Chan and write to the socket-serverSideHdbProxy :: LogAction IO (WithSeverity T.Text)+mkServerSideHdbProxy :: LogAction IO (WithSeverity T.Text)+                   -> Chan BS8.ByteString+                   -> Chan BS8.ByteString+                   -> Chan BS8.ByteString                    -> MVar ()-                   -> DebugAdaptor ()-serverSideHdbProxy l client_conn_signal = do-  DAS { syncProxyIn = dbIn-      , syncProxyOut = dbOut-      , syncProxyErr = dbErr } <- getDebugSession--  sock <- liftIO $ do-    let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream }-    addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0")-    -- Bind on "0" to let the OS pick a free port-    openTCPServerSocket addr+                   -> Adaptor DebugAdaptorState r (PortNumber, Adaptor DebugAdaptorState s ())+mkServerSideHdbProxy l dbIn dbOut dbErr client_conn_signal = do +  sock <- liftIO $ openSocketAvailablePort   port <- liftIO $ socketPort sock -  fwd_thr <- liftIO $ async $ ignoreIOException $ do+  return $ (port,) $ liftIO $ do+   ignoreIOException $ do     myThreadId >>= \tid -> labelThread tid "Debug/Adapter/Proxy: TCP Server"-    runTCPServerWithSocket sock $ \scket -> do+    runTCPServerWithSocket' sock $ \scket -> do        infoMsg (T.pack $ "Connected to client on port " ++ show port ++ "...!")       putMVar client_conn_signal () -- signal ready (see #95)@@ -67,16 +78,14 @@         (race_           (-- Read stdout from chan and write to socket            ignoreIOException $ do-             tid <- myThreadId-             labelThread tid "Debug/Adapter/Proxy: Forward stdout"+             labelMe "Debug/Adapter/Proxy: Forward stdout"              forever $ do                bs <- readChan dbOut                debugMsg (T.pack $ "Writing to socket: " ++ BS8.unpack bs)                NBS.sendAll scket bs)           (-- Read stderr from chan and write to socket            ignoreIOException $ do-             tid <- myThreadId-             labelThread tid "Debug/Adapter/Proxy: Forward stderr"+             labelMe "Debug/Adapter/Proxy: Forward stderr"              forever $ do                bs <- readChan dbErr                debugMsg (T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs)@@ -92,16 +101,43 @@               else do                 debugMsg (T.pack $ "Read from socket: " ++ BS8.unpack bs)                 writeChan dbIn bs >> loop-          in ignoreIOException loop)--  liftIO $ link fwd_thr-  sendRunProxyInTerminal port+          in ignoreIOException $ do+              labelMe "Debug/Adapter/Proxy: Read stdin"+              loop)    where     ignoreIOException a = catch a $ \(e::IOException) ->       infoMsg (T.pack $ "Ignoring connection broken to proxy client: " ++ show e)     debugMsg msg = l <& WithSeverity msg Debug     infoMsg msg  = l <& WithSeverity msg Info++-- | A version of @runTCPServerWithSocket@ that kills the forked connection+-- handlers when killed.+runTCPServerWithSocket' :: Socket -> (Socket -> IO a1) -> IO a2+runTCPServerWithSocket' sock server = do+  let+    serverLoop = forever $ E.bracketOnError (accept sock) (close . fst) $+      \(conn, _peer) ->+        mask_ $ withAsyncWithUnmask+          (\ unmask ->+             unmask (labelMe "TCP Server handler" >> server conn)+            `finally` gracefulClose conn 5000)+          (const serverLoop)+  serverLoop++-- | Label the running thread+labelMe :: String -> IO ()+labelMe name = do+    tid <- myThreadId+    labelThread tid name++-- | Open a socket on an available port+openSocketAvailablePort :: IO Socket+openSocketAvailablePort = do+  let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream }+  addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0")+  -- Bind on "0" to let the OS pick a free port+  openTCPServerSocket addr  -- | The proxy code running on the terminal in which the @hdb proxy@ process is launched. --

@@ -99,7 +99,7 @@   varId <- freshVarIx six (scopeToVarRef kind)    source <- fileToSource sourceSpan.file-  return defaultScope+  return Scope     { scopeName = case kind of         LocalVariablesScope -> "Locals"         ModuleVariablesScope -> "Module"@@ -109,12 +109,14 @@         ModuleVariablesScope -> ScopePresentationHint "module"         GlobalVariablesScope -> ScopePresentationHint "globals"     , scopeNamedVariables = numVars+    , scopeIndexedVariables = Nothing     , scopeSource = Just source     , scopeLine = Just sourceSpan.startLine     , scopeColumn = Just sourceSpan.startCol     , scopeEndLine = Just sourceSpan.endLine     , scopeEndColumn = Just sourceSpan.endCol     , scopeVariablesReference = varId+    , scopeExpensive = expensive     }  --------------------------------------------------------------------------------

@@ -103,10 +103,11 @@               printResponse out         Just input -> do           mcmd <- parseCmd input-          lift $ modify (\ o -> o { runLastCommand = mcmd })           case mcmd of             Nothing -> return ()-            Just cmd -> do+            Just Exit -> outputStrLn "Exiting..." >> liftIO (exitWith ExitSuccess)+            Just (Do cmd) -> do+              lift $ modify (\ o -> o { runLastCommand = Just cmd })               out <- lift . lift $ execute cmd               printResponse out       loop@@ -274,12 +275,12 @@    <> metavar "N:INT"    <> help "Ignore first N:INT times this breakpoint is hit" )) +data OrExit a = Do a+              | Exit+  deriving Functor+ runParser :: RunOptions -> Parser Command runParser opts =-  -- --entry <name> with some args-  -- (DebugExecution <$> parseEntry <*> parseSomeArgs)-  -- --entry <name> without any args-  -- <|> (DebugExecution <$> parseEntry <*> pure [])   -- just some args   (DebugExecution (mkEntry (runEntryPoint opts)) (runEntryFile opts) <$> parseSomeArgs)   -- just "run"@@ -301,58 +302,62 @@       | otherwise = FunctionEntry (runEntryPoint opts)  -- | Combined parser for 'Command'-cmdParser :: RunOptions -> RunContext -> Parser Command+cmdParser :: RunOptions -> RunContext -> Parser (OrExit Command) cmdParser opts ctx = hsubparser    (     Options.Applicative.command "delete"-    ( info (DelBreakpoint <$> breakpointParser)+    ( info (Do . DelBreakpoint <$> breakpointParser)       ( progDesc "Delete a breakpoint" ) )   <>     Options.Applicative.command "run"-    ( info (runParser opts)+    ( info (Do <$> runParser opts)       ( progDesc "Run the debuggee" ) )   <>     Options.Applicative.command "next"-    ( info (pure DoStepLocal)+    ( info (pure $ Do DoStepLocal)       ( progDesc "Step over to the next line" ) )   <>     Options.Applicative.command "step"-    ( info (pure DoSingleStep)+    ( info (pure $ Do DoSingleStep)       ( progDesc "Step-in to the next immediate location" ) )   <>     Options.Applicative.command "finish"-    ( info (pure DoStepOut)+    ( info (pure $ Do DoStepOut)       ( progDesc "Step-out of the current function into the caller/its continuation" ) )   <>     Options.Applicative.command "continue"-    ( info (pure DoContinue)+    ( info (pure $ Do DoContinue)       ( progDesc "Continue executing from the current breakpoint" ) )   <>     Options.Applicative.command "print"-    ( info (DoEval . unwords <$> many (argument str ( metavar "EXPRESSION"+    ( info (Do . DoEval . unwords <$> many (argument str ( metavar "EXPRESSION"      <> help "Expression to evaluate in the current context" )))       ( progDesc "Evaluate an expression in the current context" ) )   <>     Options.Applicative.command "exit"-    ( info (pure TerminateProcess)+    ( info (pure Exit)       ( progDesc "Terminate and exit the debugger session" ) )   <>     Options.Applicative.command "threads"-    ( info (pure GetThreads)+    ( info (pure $ Do GetThreads)       ( progDesc "Print all user threads" ) )   <>     Options.Applicative.command "backtrace"-    ( info (stackTraceParser ctx <**> helper)+    ( info (Do <$> stackTraceParser ctx <**> helper)       ( progDesc "Print stack trace" ) )   <>     Options.Applicative.command "variables"-    ( info (variablesParser ctx <**> helper)+    ( info (Do <$> variablesParser ctx <**> helper)       ( progDesc "Print local variables" ) )   <> Options.Applicative.command "break"-    ( info (SetBreakpoint <$> breakpointParser <*> hitCountBreakParser <*> conditionalBreakParser)+    ( info (Do <$> (SetBreakpoint <$> breakpointParser <*> hitCountBreakParser <*> conditionalBreakParser <*> logMessageParser))       ( progDesc "Set a breakpoint" ) )   ) +-- | TODO: handle this as part of issue #144+logMessageParser :: Parser (Maybe String)+logMessageParser = pure Nothing+ stackTraceParser :: RunContext -> Parser Command stackTraceParser ctx =   GetStacktrace <$> threadIdParser ctx "Print backtrace of THREAD_ID. Defaults to current thread at breakpoint."@@ -370,12 +375,12 @@  <|> Maybe.maybe (empty <**> abortOption (ErrorMsg "Not stopped at a Breakpoint") mempty) pure (runCurrentThread ctx)  -- | Main parser info-cmdParserInfo :: RunOptions -> RunContext -> ParserInfo Command+cmdParserInfo :: RunOptions -> RunContext -> ParserInfo (OrExit Command) cmdParserInfo opts ctx = info (cmdParser opts ctx)   ( fullDesc )  -- | Parse command line arguments-parseCmd :: String -> InteractiveDM (Maybe Command)+parseCmd :: String -> InteractiveDM (Maybe (OrExit Command)) parseCmd input = do   opts <- lift ask   ctx <- lift get@@ -385,8 +390,8 @@      (cmdParserInfo opts ctx)      (words input)    in case res of-    Success x ->-      return (Just x)+    Success cmd ->+      return (Just cmd)     Failure bad ->       let (msg, _exit) = renderFailure bad "(hdb)"        in outputStrLn msg >> pure Nothing

@@ -30,15 +30,20 @@   -- | @proxy --port <port>@   --   -- The proxy command serves as a middle man between the user and the debugger.-  -- It is used implicitly by DAP mode: upon initialization, the debugger-  -- server asks the DAP client to @runInTerminal@ the @hdb proxy --port ...@-  -- command at a port determined by the debugger server.+  -- It is used implicitly by DAP mode when using the internal interpreter:+  -- upon initialization, the debugger server asks the DAP client to+  -- @runInTerminal@ the @hdb proxy --port ...@ command at a port determined by+  -- the debugger server.   --   -- The proxy mode will forward stdin to the debugger server and will be   -- forwarded the debuggee's stdout. This essentially enables the user to   -- observe and interact with the execution of the debugger, in a standalone   -- terminal.   --+  -- (When using the external interpreter, the proxy isn't necessary because+  -- the DAP server can launch directly the external interpreter attached to+  -- the user's terminal)+  --   -- See #44 for the original ticket   | HdbProxy     { port :: Int@@ -65,3 +70,8 @@       , readFd  :: Int       } +  -- | Launch the custom-for-the-debugger external interpreter and connect it+  -- to the debugger through a TCP socket.+  | HdbExternalInterpreterPort+      { port :: Int+      }

@@ -89,16 +89,24 @@      <> help "proxy port to which the debugger connects" )   <*> verbosityParser Warning --- | Parser for @hdb external-interpreter <write-fd> <read-fd>@+-- | Parser for @hdb external-interpreter <write-fd> <read-fd>@ or+-- @hdb external-interpreter --port <port>@ -- See Note [Custom external interpreter] extInterpParser :: Parser HdbOptions-extInterpParser = HdbExternalInterpreter-  <$> argument auto-    ( metavar "WRITE_FD"-   <> help "external interpreter write file descriptor" )-  <*> argument auto-    ( metavar "READ_FD"-   <> help "external interpreter read file descriptor" )+extInterpParser =+      HdbExternalInterpreterPort+        <$> option auto+          ( long "port"+         <> short 'p'+         <> metavar "PORT"+         <> help "port on which the external interpreter should connect to the debugger" )+  <|> HdbExternalInterpreter+        <$> argument auto+          ( metavar "WRITE_FD"+         <> help "external interpreter write file descriptor" )+        <*> argument auto+          ( metavar "READ_FD"+         <> help "external interpreter read file descriptor" )  -- | Combined parser for HdbOptions hdbOptionsParser :: Parser HdbOptions@@ -111,7 +119,7 @@       ( progDesc "Debug a Haskell program in CLI mode" ) )  <> Options.Applicative.command "proxy"     ( info proxyParser-      ( progDesc "Internal mode used by the DAP server to proxy the stdin/stdout to the DAP client's terminal" ) )+      ( progDesc "Internal mode used by the DAP server to proxy stdin/stdout to the DAP client's terminal when using the internal interpreter" ) )  <> Options.Applicative.command "external-interpreter"     ( info extInterpParser       ( progDesc "Start the custom-for-debugger external interpreter" ) )

@@ -15,6 +15,7 @@   ) where  import Control.Applicative ((<|>))+import Control.Concurrent (newMVar, MVar, withMVar) import Control.Exception (handleJust) import Control.Monad import Control.Monad.Except@@ -26,11 +27,13 @@ import Data.Maybe import Data.Version import Data.Void-import System.Directory hiding (findFile)+import System.Directory hiding (withCurrentDirectory, findFile)+import System.Directory qualified as D import System.FilePath import System.IO.Error import Text.ParserCombinators.ReadP (readP_to_S) import Data.Functor.Contravariant+import GHC.IO (unsafePerformIO)  import qualified Data.Text as T @@ -345,3 +348,10 @@ forgetPatchVersion v = case versionBranch v of   (major:minor:_patches) -> makeVersion [major, minor]   _ -> v++{-# NOINLINE cwdLock #-}+cwdLock :: MVar ()+cwdLock = unsafePerformIO $ newMVar ()++withCurrentDirectory :: FilePath -> IO b -> IO b+withCurrentDirectory fp m = withMVar cwdLock $ \ _ -> D.withCurrentDirectory fp m

@@ -11,8 +11,7 @@ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Except-import Control.Exception (uninterruptibleMask)+import Control.Exception (bracket, uninterruptibleMask, bracketOnError) import Control.Exception.Backtrace  import DAP@@ -24,17 +23,28 @@ import Development.Debug.Adapter.Evaluation import Development.Debug.Adapter.ExceptionInfo import Development.Debug.Adapter.Exit+import Development.Debug.Adapter.Exit.Helpers import Development.Debug.Adapter.Handles import Colog.Core  import Data.Time-import System.IO (hSetBuffering, BufferMode(LineBuffering), Handle, openFile, IOMode(ReadMode))+import System.IO+  ( hFlush+  , hClose+  , hPutStrLn+  , hSetBuffering+  , BufferMode(..)+  , Handle+  , openFile+  , IOMode(ReadMode, ReadWriteMode)+  ) import qualified DAP.Log as DAP import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Handle.FD import Data.Functor.Contravariant+import Network.Socket hiding (Debug)  import qualified GHCi.Server as GHCi import qualified GHCi.Signals as GHCi@@ -48,7 +58,12 @@ import Development.Debug.Adapter import Development.Debug.Adapter.Proxy import Development.Debug.Interactive+import GHC.Stack.Annotation (annotateCallStackIO) +#if MIN_VERSION_ghc(9,15,0)+import GHC.Debugger.Runtime.Interpreter.Custom (dbgInterpCmdHandler)+#endif+ --------------------------------------------------------------------------------  main :: IO ()@@ -72,11 +87,9 @@         hSetBuffering realStdout LineBuffering         l <- mainLogger hdbOpts.verbosity realStdout         init_var <- liftIO (newIORef False{-not supported by default-})-        pid_var  <- liftIO (newIORef Nothing)-        ccon_var <- liftIO newEmptyMVar         runDAPServerWithLogger (contramap DAPLibraryLog l) config-          (talk l init_var pid_var ccon_var internalInterpreter)-          (ack l pid_var)+          (talk l init_var internalInterpreter)+          (ack l )     HdbCLI{..} -> do         setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces)         l <- mainLogger hdbOpts.verbosity stdout@@ -87,7 +100,7 @@               { supportsANSIStyling = True -- todo: check!!               , supportsANSIHyperlinks = False               , preferInternalInterpreter = internalInterpreter-              , externalInterpreterStdinStream = stdinStream+              , externalInterpreterCustomProc = Left stdinStream               }         runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs           runConf debugInteractive@@ -98,14 +111,49 @@     HdbExternalInterpreter{writeFd, readFd} -> do       inh  <- GHCi.readGhcHandle (show readFd)       outh <- GHCi.readGhcHandle (show writeFd)+      runExternalInterpreterServer inh outh+    HdbExternalInterpreterPort{port} -> do+      pid <- getCurrentPid+      withExternalInterpreterPort (fromIntegral port) $ \h -> do+        hPutStrLn h (show pid)+        hFlush h+        runExternalInterpreterServer h h+  where+    runExternalInterpreterServer inh outh = do       GHCi.installSignalHandlers       pipe <- GHCi.mkPipeFromHandles inh outh       let verbose = False+#if MIN_VERSION_ghc(9,15,0)+      uninterruptibleMask $ \restore ->+        GHCi.servWithCustom verbose hook pipe restore dbgInterpCmdHandler+#else       uninterruptibleMask $ GHCi.serv verbose hook pipe+#endif       where hook = return -- empty hook         -- we cannot allow any async exceptions while communicating, because         -- we will lose sync in the protocol, hence uninterruptibleMask.-  where++    withExternalInterpreterPort :: PortNumber -> (Handle -> IO a) -> IO a+    withExternalInterpreterPort port k = do+      bracket (mkHandleFromPortSock "127.0.0.1" port) hClose $ \ h -> do+        annotateCallStackIO $ k h++    mkHandleFromPortSock :: HostName -> PortNumber -> IO Handle+    mkHandleFromPortSock host port = do+      let hints = defaultHints { addrSocketType = Stream }+      addr:_ <- getAddrInfo (Just hints) (Just host) (Just (show port))++      Control.Exception.bracketOnError+        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))+        close+        (\sock -> do+            -- Don't delay, avoids batching+            setSocketOption sock NoDelay 1+            connect sock (addrAddress addr)+            h <- socketToHandle sock ReadWriteMode+            hSetBuffering h NoBuffering+            return h)+     -- When using the internal interpreter in DAP mode, we can't write to     -- stdout directly because there will also be a thread forwarding the     -- debuggee stdout by capturing it from stdout (and we'd get into a loop@@ -165,14 +213,14 @@       , supportsExceptionOptions              = True       , supportsValueFormattingOptions        = True       , supportsExceptionInfoRequest          = True-      , supportTerminateDebuggee              = True+      , supportTerminateDebuggee              = False -- for now, when debugger is disconnected, we always kill the debuggee       , supportSuspendDebuggee                = False       , supportsDelayedStackTraceLoading      = False       , supportsLoadedSourcesRequest          = False-      , supportsLogPoints                     = False+      , supportsLogPoints                     = True       , supportsTerminateThreadsRequest       = False       , supportsSetExpression                 = False-      , supportsTerminateRequest              = False+      , supportsTerminateRequest              = True       , supportsDataBreakpoints               = False       , supportsReadMemoryRequest             = False       , supportsWriteMemoryRequest            = False@@ -203,16 +251,11 @@ talk :: LogAction IO MainLog      -> IORef Bool      -- ^ Whether the client supports runInTerminal-     -> IORef (Maybe Int)-     -- ^ The PID of the runInTerminal proxy process-     -> MVar ()-     -- ^ A var to block on waiting for the proxy client to connect, if a proxy-     -- connection is expected. See #95.      -> Bool      -- ^ Prefer internal interpreter      -> Command -> DebugAdaptor () ---------------------------------------------------------------------------------talk l support_rit_var _pid_var client_proxy_signal prefer_internal_interpreter = \ case+talk l support_rit_var prefer_internal_interpreter = \ case   CommandInitialize -> do     InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments #ifdef mingw32_HOST_OS@@ -222,43 +265,36 @@ #else     let runInTerminal = fromMaybe False supportsRunInTerminalRequest #endif+    -- This global variable is wrong. Even though we only register the session+    -- and the per-session state on Launch (which gives us __sessionId), the+    -- *initialize* command is run once per new session on a new connection and+    -- two different clients which may differ in their support for+    -- 'runInTerminal'.+    --+    -- The `dap` library should likely keep track of the client capabilities+    -- per connection.     liftIO $ writeIORef support_rit_var runInTerminal     sendInitializeResponse--    -- If runInTerminal is not supported by the client, signal readiness right away-    when (not runInTerminal) $-      liftIO $ putMVar client_proxy_signal () --------------------------------------------------------------------------------   CommandLaunch -> do     launch_args <- getArguments +    -- Wrong-ish. See above where this variable is written     supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var -    merror <- runExceptT $-      initDebugger (contramap DAPLog l)-        supportsRunInTerminalRequest prefer_internal_interpreter-        launch_args-    case merror of-      Right () -> do-        sendLaunchResponse   -- ack-        sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session--        -- Run the proxy in a separate terminal to accept stdin / forward stdout-        -- if it is supported-        when supportsRunInTerminalRequest $ do-          -- Run proxy thread, server side, and-          -- send the 'runInTerminal' request-          serverSideHdbProxy (contramap RunProxyServerLog l) client_proxy_signal+    initDebugger (contramap DAPLog l)+      supportsRunInTerminalRequest prefer_internal_interpreter+      launch_args -        liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info)+    sendLaunchResponse   -- ack+    sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session -      Left (InitFailed err) -> do-        sendErrorResponse (ErrorMessage (T.pack err)) Nothing-        exitCleanly Nothing+    liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info) --------------------------------------------------------------------------------   CommandAttach -> do-    sendErrorResponse (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing-    exitCleanly Nothing+    sendTerminatedEvent (TerminatedEvent False)+    destroyDebugSession+    sendError (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing --------------------------------------------------------------------------------   CommandBreakpointLocations       -> commandBreakpointLocations   CommandSetBreakpoints            -> commandSetBreakpoints@@ -272,10 +308,16 @@ ----------------------------------------------------------------------------   CommandConfigurationDone -> do     sendConfigurationDoneResponse-    -- now that it has been configured, start executing until it halts, then send an event -    -- wait for the proxy client to connect before starting the execution (#95)-    () <- liftIO $ takeMVar client_proxy_signal+    DAS{runInTerminalProc} <- getDebugSession+    case runInTerminalProc of+      RunProxyInTerminal{proxyClientReady} -> liftIO $ do+        -- Only start executing after proxy client connects succesfully (#95)+        takeMVar proxyClientReady+      _ ->+        pure ()++    -- Configuration is finished. Start executing until it halts.     startExecution >>= handleEvalResult False ----------------------------------------------------------------------------   CommandThreads    -> commandThreads@@ -292,32 +334,36 @@ ----------------------------------------------------------------------------   CommandEvaluate   -> commandEvaluate -----------------------------------------------------------------------------  CommandTerminate  -> do-    commandTerminate+  CommandTerminate  -> commandTerminate   CommandDisconnect -> commandDisconnect ----------------------------------------------------------------------------   CommandModules -> sendModulesResponse (ModulesResponse [] Nothing)   CommandSource -> undefined   CommandPause -> pure () -- TODO   (CustomCommand "mycustomcommand") -> undefined-  (CustomCommand "runInTerminal") -> do-    -- Ignore result of runInTerminal (reverse request) response.-    -- If it fails, we simply continue without that functionality.-    pure ()   other -> do-    sendErrorResponse (ErrorMessage (T.pack ("Unsupported command: " <> show other))) Nothing-    exitCleanly Nothing-------------------------------------------------------------------------------- talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd)-----------------------------------------------------------------------------+    terminateWithError ("Unsupported command: " <> show other)  -- | Receive reverse request responses (such as runInTerminal response) ack :: LogAction IO MainLog-    -> IORef (Maybe Int)-    -- ^ Reference to PID of runInTerminal proxy process running     -> ReverseRequestResponse -> DebugAdaptorCont ()-ack l _ref rrr = case rrr.reverseRequestCommand of+ack l rrr = case rrr.reverseRequestCommand of   ReverseCommandRunInTerminal -> do++    RunInTerminalResponse{} <- getReverseRequestResponseBody rrr++    -- TODO: keep track of body.shellProcessId to then kill the proxy when the+    -- session is terminated:+    -- [stdout] [127.0.0.1:54427][DEBUG][RECEIVED]+    --  {+    --      "body": {+    --          "shellProcessId": 2092+    --      },+    --      "command": "runInTerminal",+    --      "seq": 14,+    --      "success": true,+    --      "type": "response"+    --  }     when rrr.success $ do       liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info)   _ -> pure ()@@ -329,7 +375,6 @@ data MainLog   = DAPLog DAPLog   | InteractiveLog InteractiveLog-  | RunProxyServerLog (WithSeverity T.Text)   | RunProxyClientLog (WithSeverity T.Text)   | DAPLaunchLog (WithSeverity T.Text)   | DAPLibraryLog DAP.DAPLog@@ -368,9 +413,9 @@   pure $ LogAction $ \case     DAPLog (DAPSessionSetupLog sessionLog)       -> logSessionLog sessionLog     DAPLog (DAPDebuggerLog debuggerLog)          -> logDebuggerLog debuggerLog+    DAPLog (RunProxyServerLog sev_msg) -> defaultLog sev_msg     InteractiveLog (ISessionSetupLog sessionLog) -> logSessionLog sessionLog     InteractiveLog (IDebuggerLog debuggerLog)    -> logDebuggerLog debuggerLog-    RunProxyServerLog sev_msg -> defaultLog sev_msg     RunProxyClientLog sev_msg -> defaultLog sev_msg     DAPLaunchLog sev_msg      -> defaultLog sev_msg     DAPLibraryLog t ->

@@ -0,0 +1,24 @@+cabal-version:   3.14+name:            T130+version:         0.1.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  Lib+    build-depends:    base, haskell-debugger-view == 0.1.0.0+    hs-source-dirs:   lib+    default-language: Haskell2010++executable T130+    import:           warnings+    main-is:          Main.hs+    build-depends:    base, T130+    hs-source-dirs:   app+    default-language: Haskell2010

@@ -0,0 +1,2 @@+Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3)+While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3)

@@ -0,0 +1,2 @@+Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3)+While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3)

@@ -1,1 +0,0 @@-Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3)

@@ -0,0 +1,24 @@+cabal-version:   3.14+name:            T130b+version:         0.1.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  Lib+    build-depends:    base, haskell-debugger-view == 0.2.0.0+    hs-source-dirs:   lib+    default-language: Haskell2010++executable T130b+    import:           warnings+    main-is:          Main.hs+    build-depends:    base, T130b+    hs-source-dirs:   app+    default-language: Haskell2010

@@ -0,0 +1,4 @@+[1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b]+(hdb) MyType+()+(hdb) Exiting...

@@ -0,0 +1,4 @@+[1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b]+(hdb) MyType+()+(hdb) Exiting...

@@ -1,4 +0,0 @@-[1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b]-(hdb) MyType-()-(hdb) Exiting...

@@ -0,0 +1,18 @@+cabal-version:   3.14+name:            T130c+version:         0.1.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  Lib+    build-depends:    base, haskell-debugger-view+    hs-source-dirs:   lib+    default-language: Haskell2010+

@@ -0,0 +1,7 @@+[1 of 1] Compiling Lib              ( <TEMPORARY-DIRECTORY>/lib/Lib.hs, interpreted )[T130c-0.1.0.0-inplace]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/lib/Lib.hs", startLine = 16, endLine = 16, startCol = 3, endCol = 14}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : ColonList = _+  value : ColonList = alpha:beta:gamma+(hdb) Exiting...

@@ -0,0 +1,3 @@+break lib/Lib.hs 16+run+variables

@@ -0,0 +1,3 @@+#!/bin/sh++$HDB -v0 --entry-point mainish lib/Lib.hs 2>&1 < T130c.hdb-stdin

@@ -0,0 +1,19 @@+module Lib (mainish) where++import Data.List (intercalate)+import GHC.Debugger.View.Class++data ColonList = ColonList [String]+  deriving Show++instance DebugView ColonList where+  debugValue (ColonList xs) = simpleValue (intercalate ":" xs) False+  debugFields _ = pure (VarFields [])++mainish :: IO ()+mainish = do+  let value = mkValue+  print value++mkValue :: ColonList+mkValue = ColonList ["alpha", "beta", "gamma"]

@@ -0,0 +1,13 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp]+[;1m<TEMPORARY-DIRECTORY>/myapp/app/Main.hs:3:1: [;1m[35mwarning[0m[0m[;1m: [GHC-66111] [[;1m[35m-Wunused-imports[0m[0m[;1m][0m[0m[;1m+    The import of ‘MyLib’ is redundant+      except perhaps to import instances from ‘MyLib’+    To import instances alone, use: import MyLib()[0m[0m+[;1m[34m  |[0m[0m+[;1m[34m3 |[0m[0m [;1m[35mimport MyLib (someFunc)[0m[0m+[;1m[34m  |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^[0m[0m++(hdb) Hello, Haskell!+()+(hdb) Exiting...

@@ -0,0 +1,13 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/myapp/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[myapp-0.1.0.0-inplace-myapp]+[;1m<TEMPORARY-DIRECTORY>/myapp/app/Main.hs:3:1: [;1m[35mwarning[0m[0m[;1m: [GHC-66111] [[;1m[35m-Wunused-imports[0m[0m[;1m][0m[0m[;1m+    The import of ‘MyLib’ is redundant+      except perhaps to import instances from ‘MyLib’+    To import instances alone, use: import MyLib()[0m[0m+[;1m[34m  |[0m[0m+[;1m[34m3 |[0m[0m [;1m[35mimport MyLib (someFunc)[0m[0m+[;1m[34m  |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^[0m[0m++(hdb) Hello, Haskell!+()+(hdb) Exiting...

@@ -1,13 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp]-[;1m<TEMPORARY-DIRECTORY>/myapp/app/Main.hs:3:1: [;1m[35mwarning[0m[0m[;1m: [GHC-66111] [[;1m[35m-Wunused-imports[0m[0m[;1m][0m[0m[;1m-    The import of ‘MyLib’ is redundant-      except perhaps to import instances from ‘MyLib’-    To import instances alone, use: import MyLib()[0m[0m-[;1m[34m  |[0m[0m-[;1m[34m3 |[0m[0m [;1m[35mimport MyLib (someFunc)[0m[0m-[;1m[34m  |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^[0m[0m--(hdb) Hello, Haskell!-()-(hdb) Exiting...

@@ -0,0 +1,1 @@+packages: mylib myapp

@@ -0,0 +1,6 @@+cradle:+  cabal:+    - path: "./mylib"+      component: "lib:mylib"+    - path: "./myapp/"+      component: "myapp"

@@ -0,0 +1,17 @@+cabal-version:   3.14+name:            myapp+version:         0.1.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple++common warnings+    ghc-options: -Wall++executable myapp+    import:           warnings+    main-is:          Main.hs+    build-depends:    base, mylib >= 0.1234+    hs-source-dirs:   app+    default-language: Haskell2010

@@ -0,0 +1,17 @@+cabal-version:   3.14+name:            mylib+version:         0.1234.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  MyLib+    build-depends:    base+    hs-source-dirs:   src+    default-language: Haskell2010

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) hello+()+(hdb) Exiting...

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) hello+()+(hdb) Exiting...

@@ -1,5 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]-(hdb) hello-()-(hdb) Exiting...

@@ -0,0 +1,6 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T159.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}+(hdb) Stopped at breakpoint+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}]+(hdb) Exiting...

@@ -0,0 +1,6 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T159.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}+(hdb) Stopped at breakpoint+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation, called at <TEMPORARY-DIRECTORY>/T159.hs:7:7 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4], called at <TEMPORARY-DIRECTORY>/T159.hs:6:5 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}]+(hdb) Exiting...

@@ -1,6 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T159.hs, interpreted )[main]-(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}-(hdb) Stopped at breakpoint-(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}]-(hdb) Exiting...

@@ -0,0 +1,8 @@+cradle:+  direct:+    arguments: +      - -i+      - -i.+      - T159.hs+      - -package base+      - -package ghc-experimental

@@ -0,0 +1,25 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+existentialFoo : Foo = Foo+  _1 : r0 = _+  _2 : [Char] = "value"+existentialFoo2 : Foo2 = Foo2+  _1 : r0 = _+  foo : [Char] = "value2"+foo3 : Foo3 = Foo3+  _1 : Int = 0+  _2 : Word = 1+  _3 : Int = 2+  _4 : Int = 3+foo4 : Foo4 = Foo4+  _1 : Word32 = 0+  _2 : Word16 = 1+  _3 : Word64 = 2+  _4 : Word16 = 3+foo5 : Foo5 = Foo5+  _1 : ?impl::String = _+  _2 : String = _+(hdb) Exiting...

@@ -0,0 +1,27 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = _+*** Ignoring breakpoint [<TEMPORARY-DIRECTORY>/Main.hs:42:3-69]+  _result : IO () = _+existentialFoo : Foo = Foo+  _1 : r0 = _+  _2 : [Char] = "value"+existentialFoo2 : Foo2 = Foo2+  _1 : r0 = _+  foo : [Char] = "value2"+foo3 : Foo3 = Foo3+  _1 : Int = 0+  _2 : Word = 1+  _3 : Int = 2+  _4 : Int = 3+foo4 : Foo4 = Foo4+  _1 : Word32 = 0+  _2 : Word16 = 1+  _3 : Word64 = 2+  _4 : Word16 = 3+foo5 : Foo5 = Foo5+  _1 : ?impl::String = _+  _2 : String = _+(hdb) 

@@ -1,27 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]-(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}}-(hdb) Stopped at breakpoint-(hdb) _result : IO () = _-*** Ignoring breakpoint [<TEMPORARY-DIRECTORY>/Main.hs:42:3-69]-  _result : IO () = _-existentialFoo : Foo = Foo-  _1 : r0 = _-  _2 : [Char] = "value"-existentialFoo2 : Foo2 = Foo2-  _1 : r0 = _-  foo : [Char] = "value2"-foo3 : Foo3 = Foo3-  _1 : Int = 0-  _2 : Word = 1-  _3 : Int = 2-  _4 : Int = 3-foo4 : Foo4 = Foo4-  _1 : Word32 = 0-  _2 : Word16 = 1-  _3 : Word64 = 2-  _4 : Word16 = 3-foo5 : Foo5 = Foo5-  _1 : ?impl::String = _-  _2 : String = _-(hdb) 

@@ -0,0 +1,3 @@+module Main where++main = return ()

@@ -0,0 +1,17 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) 1+(hdb) 1+(hdb) Prelude.undefined++HasCallStack backtrace:+  undefined, called at <interactive>:1:1 in interactive:Ghci4++(hdb) Prelude.undefined++HasCallStack backtrace:+  undefined, called at <interactive>:1:1 in interactive:Ghci4++(hdb) _+(hdb) [...]+(hdb) Exiting...

@@ -0,0 +1,6 @@+print 1+print let x = 1+print undefined+print undefined :: Int+print x <- readFile "Main.hs"+print let a = [1]; b = [2,3]

@@ -0,0 +1,17 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) 1+(hdb) 1+(hdb) Prelude.undefined++HasCallStack backtrace:+  undefined, called at <interactive>:1:1 in interactive:Ghci4++(hdb) Prelude.undefined++HasCallStack backtrace:+  undefined, called at <interactive>:1:1 in interactive:Ghci4++(hdb) _+(hdb) [...]+(hdb) Exiting...

@@ -0,0 +1,1 @@+$HDB Main.hs -v 0 < T166.hdb-stdin

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) hello+()+(hdb) Exiting...

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) hello+()+(hdb) Exiting...

@@ -1,5 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]-(hdb) hello-()-(hdb) Exiting...

@@ -0,0 +1,10 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169b.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}}+(hdb) Stopped at breakpoint+(hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}]+(hdb) Debuggee writing something to stdout+[ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}]+(hdb) Debuggee writing something to stderr+()+(hdb) Exiting...

@@ -0,0 +1,10 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169b.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}}+(hdb) Stopped at breakpoint+(hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 354, expensive = True}]+(hdb) Debuggee writing something to stdout+[ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 354, expensive = True}]+(hdb) Debuggee writing something to stderr+()+(hdb) Exiting...

@@ -1,10 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169b.hs, interpreted )[main]-(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}}-(hdb) Stopped at breakpoint-(hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}]-(hdb) Debuggee writing something to stdout-[ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}]-(hdb) Debuggee writing something to stderr-()-(hdb) Exiting...

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169c.hs, interpreted )[main]+(hdb) "hello there"+()+(hdb) Exiting...

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169c.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) "hello there"+()+(hdb) Exiting...

@@ -1,5 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169c.hs, interpreted )[main]-(hdb) "hello there"-()-(hdb) Exiting...

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169c.hs, interpreted )[main]+(hdb) "hello world"+()+(hdb) Exiting...

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169c.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) "hello world"+()+(hdb) Exiting...

@@ -1,5 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/T169c.hs, interpreted )[main]-(hdb) "hello world"-()-(hdb) Exiting...

@@ -0,0 +1,20 @@+newtype D a = D {unD :: D a -> a}+newtype B = B (Either String Bool)+  deriving Show+{-# OPAQUE f #-}+f :: B -> Either B B+f b = Left b++main = do+  let doit = const (pure () :: IO ())+  let y = D (const $ 'y')+  let x :: (a ~ IO ()) => a+      x = print ()+  -- to preserve newtype constructor `B` in reconstructed Term we must not force `ix`+  -- until after the breakpoint.+  ix <- pure $ B (Left "A")+  putStrLn "helio"+  doit ()+  print $ unD y y+  x+  print (f ix)

@@ -0,0 +1,12 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 13], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 17, endLine = 17, startCol = 3, endCol = 10}}+(hdb) helio+Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+x : forall a. (a ~ IO ()) => a = <fn> :: forall a. (a ~ IO ()) => a+y : D Char -> Char = <fn> :: D Char -> Char+doit : forall {b}. b -> IO () = <fn> :: forall {b}. b -> IO ()+ix : B = _+  ix : B = B (Left _)+(hdb) Exiting...

@@ -0,0 +1,3 @@+break Main.hs 17+run+variables

@@ -0,0 +1,1 @@+$HDB Main.hs -v 0 < T217.hdb-stdin

@@ -0,0 +1,3 @@+module Main where++main = return ()

@@ -0,0 +1,12 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) Aborted: <interactive>:1:1: error: [GHC-88464]+    Variable not in scope: isLetter+(hdb) +(hdb) <fn> :: Char -> Bool+(hdb) True+(hdb) False+(hdb) Aborted: <interactive>:1:1: error: [GHC-87110]+    Could not find module `Does.Not.Exist'.+    Use -v to see a list of the files searched for.+(hdb) Exiting...

@@ -0,0 +1,6 @@+print isLetter+print import Data.Char+print isLetter+print isLetter 'a'+print isLetter '1'+print import Does.Not.Exist

@@ -0,0 +1,12 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) Aborted: <interactive>:1:1: error: [GHC-88464]+    Variable not in scope: isLetter+(hdb) +(hdb) <fn> :: Char -> Bool+(hdb) True+(hdb) False+(hdb) Aborted: <interactive>:1:1: error: [GHC-87110]+    Could not find module `Does.Not.Exist'.+    Use -v to see a list of the files searched for.+(hdb) Exiting...

@@ -0,0 +1,1 @@+$HDB Main.hs -v 0 < T218.hdb-stdin

@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedLists, GeneralizedNewtypeDeriving, DerivingStrategies, UndecidableInstances #-}+module Main where++import GHC.IsList++newtype List a = List [a]+  deriving Show+  deriving newtype IsList++main = do+  return ()+  return ()

@@ -0,0 +1,6 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 12}}+(hdb) Stopped at breakpoint+(hdb) "List [1]"+(hdb) Exiting...

@@ -0,0 +1,3 @@+break Main.hs 11+run+print show ([1] :: List Int)

@@ -0,0 +1,6 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 12}}+(hdb) Stopped at breakpoint+(hdb) "List [1]"+(hdb) Exiting...

@@ -0,0 +1,1 @@+$HDB Main.hs -v 0 < T225.hdb-stdin

@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedLists #-}+module B where++import Data.Set qualified as Set++ex :: Set.Set Int+ex = [1,2,3]++f = do+  print 1+  got <- return ex+  print got+  pure ()

@@ -0,0 +1,8 @@+module A where++import B+++main = do+  B.f+  return ()

@@ -0,0 +1,9 @@+[1 of 4] Compiling B                ( <TEMPORARY-DIRECTORY>/B.hs, interpreted )[main]+[2 of 4] Compiling A                ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[3 of 4] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[4 of 4] Compiling GHC.Debugger.View.Containers ( in-memory:GHC.Debugger.View.Containers, interpreted )[haskell-debugger-view-in-memory]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId B 3], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/./B.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 19}}+(hdb) 1+Stopped at breakpoint+(hdb) "fromList [1,2,3]"+(hdb) Exiting...

@@ -0,0 +1,3 @@+break B.hs 11+run+print (show ([1,2,3] :: Set.Set Int))

@@ -0,0 +1,9 @@+[1 of 4] Compiling B                ( <TEMPORARY-DIRECTORY>/B.hs, interpreted )[main]+[2 of 4] Compiling A                ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[3 of 4] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[4 of 4] Compiling GHC.Debugger.View.Containers ( in-memory:GHC.Debugger.View.Containers, interpreted )[haskell-debugger-view-in-memory]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId B 3], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/./B.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 19}}+(hdb) 1+Stopped at breakpoint+(hdb) "fromList [1,2,3]"+(hdb) Exiting...

@@ -0,0 +1,1 @@+$HDB Main.hs -v 0 < T225b.hdb-stdin

@@ -0,0 +1,17 @@+cabal-version:   3.14+name:            T234+version:         0.1.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  Lib+    build-depends:    base, haskell-debugger-view+    hs-source-dirs:   lib+    default-language: Haskell2010

@@ -0,0 +1,7 @@+[1 of 1] Compiling Lib              ( <TEMPORARY-DIRECTORY>/lib/Lib.hs, interpreted )[T234-0.1.0.0-inplace]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/lib/Lib.hs", startLine = 16, endLine = 16, startCol = 3, endCol = 14}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : ColonList = _+  value : ColonList = alpha:beta:gamma+(hdb) Exiting...

@@ -0,0 +1,3 @@+break lib/Lib.hs 16+run+variables

@@ -0,0 +1,3 @@+#!/bin/sh++$HDB -v0 --entry-point mainish lib/Lib.hs 2>&1 < T234.hdb-stdin

@@ -0,0 +1,20 @@+module Lib (mainish) where++import Data.List (intercalate)+import GHC.Debugger.View.Class++newtype ColonList = ColonList [String]+  deriving Show++instance DebugView ColonList where+  debugValue (ColonList xs) = simpleValue (intercalate ":" xs) False+  debugFields _ = pure (VarFields [])++mainish :: IO ()+mainish = do+  let value = mkValue+  print value++mkValue :: ColonList+mkValue = ColonList ["alpha", "beta", "gamma"]+{-# OPAQUE mkValue #-}

@@ -0,0 +1,17 @@+cabal-version:   3.14+name:            T234b+version:         0.1.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  Lib+    build-depends:    base, haskell-debugger-view+    hs-source-dirs:   lib+    default-language: Haskell2010

@@ -0,0 +1,7 @@+[1 of 1] Compiling Lib              ( <TEMPORARY-DIRECTORY>/lib/Lib.hs, interpreted )[T234b-0.1.0.0-inplace]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/lib/Lib.hs", startLine = 18, endLine = 18, startCol = 3, endCol = 14}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : ColonList = _+  value : ColonList = This is an IORef!+(hdb) Exiting...

@@ -0,0 +1,3 @@+break lib/Lib.hs 18+run+variables

@@ -0,0 +1,1 @@+$HDB -v0 --entry-point mainish lib/Lib.hs 2>&1 < T234b.hdb-stdin

@@ -0,0 +1,21 @@+module Lib (mainish) where++import Data.IORef (IORef, newIORef)+import GHC.Debugger.View.Class++newtype ColonList = ColonList (IORef [String])++instance Show ColonList where+  show _ = "<colon-list>"++instance DebugView ColonList where+  debugValue _ = simpleValue "This is an IORef!" False+  debugFields _ = pure (VarFields [])++mainish :: IO ()+mainish = do+  value <- mkValue+  print value++mkValue :: IO ColonList+mkValue = ColonList <$> newIORef ["alpha", "beta", "gamma"]

@@ -0,0 +1,24 @@+cabal-version:   3.14+name:            T237+version:         0.1.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  MyType+    build-depends:    base+    hs-source-dirs:   lib+    default-language: Haskell2010++executable T237+    import:           warnings+    main-is:          Main.hs+    build-depends:    base, T237, haskell-debugger-view+    hs-source-dirs:   app+    default-language: Haskell2010

@@ -0,0 +1,16 @@+[1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T237-0.1.0.0-inplace-T237]+[;1m<TEMPORARY-DIRECTORY>/app/Main.hs:8:1: [;1m[35mwarning[0m[0m[;1m: [GHC-90177] [[;1m[35m-Worphans[0m[0m[;1m][0m[0m[;1m+    Orphan class instance: instance DebugView MyType+    Suggested fix:+      Move the instance declaration to the module of the class or of the type, or+      wrap the type with a newtype and declare the instance on the new type.[0m[0m+[;1m[34m  |[0m[0m+[;1m[34m8 |[0m[0m [;1m[35minstance DebugView MyType where[0m[0m+[;1m[34m  |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...[0m[0m++(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/app/Main.hs", startLine = 15, endLine = 15, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : MyType = _+  value : MyType = alpha:beta:gamma+(hdb) Exiting...

@@ -0,0 +1,3 @@+break app/Main.hs 15+run+variables

@@ -0,0 +1,1 @@+$HDB -v0 app/Main.hs 2>&1 < T237.hdb-stdin || true

@@ -0,0 +1,15 @@+module Main (main) where++import Data.List (intercalate)++import GHC.Debugger.View.Class+import MyType++instance DebugView MyType where+  debugValue (MyType xs) = simpleValue (intercalate ":" xs) False+  debugFields _ = pure (VarFields [])++main :: IO ()+main = do+  let value = mkValue+  const (print value) value

@@ -0,0 +1,11 @@+module MyType+  ( MyType(..)+  , mkValue+  ) where++newtype MyType = MyType [String]+  deriving Show++mkValue :: MyType+mkValue = MyType ["alpha", "beta", "gamma"]+{-# OPAQUE mkValue #-}

@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -O -fno-unoptimized-core-for-interpreter #-}+{-# LANGUAGE BangPatterns #-}++module Main where++data Packed = Packed -- Unpacking only happens with optimizations, hence the -O.+  { packedLeft :: {-# UNPACK #-} !Char+  , packedRight :: {-# UNPACK #-} !Char+  }+  deriving Show++data Container = Container+  { containerBefore :: Int+  , containerPacked :: {-# UNPACK #-} !Packed+  , containerPacked2 :: {-# UNPACK #-} !Packed+  , containerAfter :: Int+  }+  deriving Show++mkContainer :: Container+mkContainer = Container 10 (Packed 'a' 'b') (Packed 'c' 'd') 40+{-# OPAQUE mkContainer #-}++main :: IO ()+main = do+  let !container = mkContainer+  const (pure ()) container+  print container

@@ -0,0 +1,11 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 2], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 27, endLine = 27, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+container : Container = Container+  containerBefore : Int = _+  containerPacked : Packed = Packed+  containerPacked2 : Packed = Packed+  containerAfter : Int = _+(hdb) (hdb) Exiting...

@@ -0,0 +1,1 @@+$HDB Main.hs -v 0 < T239.hdb-stdin

@@ -0,0 +1,4 @@+break Main.hs 27+run+variables+exit

@@ -0,0 +1,12 @@+f () = do+  let xs = [3,2,1]+  pure ()+  print xs++main = do+  let doit = const (pure () :: IO ())+  let xs = [4,5,6]+  doit ()+  f ()+  print xs+  putStrLn "done"

@@ -0,0 +1,14 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 9, endLine = 9, startCol = 3, endCol = 10}}+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 11], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 3, endLine = 3, startCol = 3, endCol = 10}}+(hdb) Stopped at breakpoint+(hdb) Aborted: <interactive>:1:8: error: [GHC-88464]+    Variable not in scope: sort :: [Integer] -> a0+(hdb) +(hdb) [4,5,6]+()+(hdb) Stopped at breakpoint+(hdb) [1,2,3]+()+(hdb) Exiting...

@@ -0,0 +1,8 @@+break Main.hs 9+break Main.hs 3+run+print print (sort xs)+print import Data.List+print print (sort xs)+continue+print print (sort xs)

@@ -0,0 +1,1 @@+$HDB Main.hs -v 0 < T242.hdb-stdin

@@ -0,0 +1,18 @@+cabal-version:   3.16+name:            T283+version:         0.1.0.0+license:         NONE+author:          Rodrigo Mesquita+maintainer:      rodrigo.m.mesquita@gmail.com+build-type:      Simple+extra-doc-files: CHANGELOG.md++common warnings+    ghc-options: -Wall++executable T283+    import:           warnings+    main-is:          Main.hs+    build-depends:    base+    hs-source-dirs:   app+    default-language: Haskell2010

@@ -0,0 +1,10 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T283-0.1.0.0-inplace-T283]+(hdb) +(hdb) THIS IS A PACKAGE+()+(hdb) Aborted: <interactive>:1:1: error: [GHC-35235]+    Could not find module `Main'.+    It is not a module in the current program, or in any known package.+(hdb) "If an older version of T283 was installed, we'd now shadow the home-unit Main with the outdated installed Main!"+(hdb) Exiting...

@@ -0,0 +1,4 @@+p import Main+p main+p import "T283" Main+p "If an older version of T283 was installed, we'd now shadow the home-unit Main with the outdated installed Main!"

@@ -0,0 +1,4 @@+#!/bin/sh++# Witnesses that package-qualified imports bypass home units (#283)+$HDB -v0 app/Main.hs 2>&1 < T283.hdb-stdin

@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "THIS IS A PACKAGE"

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/x/Main.hs, interpreted )[main]+(hdb) wrks+()+(hdb) Exiting...

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/x/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) wrks+()+(hdb) Exiting...

@@ -1,5 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/x/Main.hs, interpreted )[main]-(hdb) wrks-()-(hdb) Exiting...

@@ -0,0 +1,14 @@+[Info] Using cabal specification: <VERSION>+[Warn] unknown license type, you must put a copy in LICENSE yourself.+[Info] Creating fresh file CHANGELOG.md...+[Info] Creating fresh directory ./app...+[Info] Creating fresh file app/Main.hs...+[Info] Creating fresh file T79-tmp.cabal...+[Warn] No synopsis given. You should edit the .cabal file and add one.+[Info] You may want to edit the .cabal file and add a Description field.++[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp]+(hdb) Hello, Haskell!+()+(hdb) Exiting...

@@ -0,0 +1,14 @@+[Info] Using cabal specification: <VERSION>+[Warn] unknown license type, you must put a copy in LICENSE yourself.+[Info] Creating fresh file CHANGELOG.md...+[Info] Creating fresh directory ./app...+[Info] Creating fresh file app/Main.hs...+[Info] Creating fresh file T79-tmp.cabal...+[Warn] No synopsis given. You should edit the .cabal file and add one.+[Info] You may want to edit the .cabal file and add a Description field.++[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[T79-tmp-0.1.0.0-inplace-T79-tmp]+(hdb) Hello, Haskell!+()+(hdb) 

@@ -1,14 +0,0 @@-[Info] Using cabal specification: <VERSION>-[Warn] unknown license type, you must put a copy in LICENSE yourself.-[Info] Creating fresh file CHANGELOG.md...-[Info] Creating fresh directory ./app...-[Info] Creating fresh file app/Main.hs...-[Info] Creating fresh file T79-tmp.cabal...-[Warn] No synopsis given. You should edit the .cabal file and add one.-[Info] You may want to edit the .cabal file and add a Description field.--[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp]-(hdb) Hello, Haskell!-()-(hdb) 

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) Heli+()+(hdb) Exiting...

@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) Heli+()+(hdb) Exiting...

@@ -1,5 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]-(hdb) Heli-()-(hdb) Exiting...

@@ -0,0 +1,23 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw first+Stopped at breakpoint+Exception: ErrorCall+Message: boom first+Call stack:+  HasCallStack backtrace:+    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10+(hdb) Handled first exception: boom first+Continuing after first exception+Stopped at breakpoint+Exception: ErrorCall+Message: boom second+Call stack:+  HasCallStack backtrace:+    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:10:3 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:10:3+(hdb) Exiting...

@@ -0,0 +1,23 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw first+Stopped at breakpoint+Exception: ErrorCall+Message: boom first+Call stack:+  HasCallStack backtrace:+    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10+(hdb) Handled first exception: boom first+Continuing after first exception+Stopped at breakpoint+Exception: ErrorCall+Message: boom second+Call stack:+  HasCallStack backtrace:+    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:10:3 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:10:3+(hdb) 

@@ -1,23 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]-(hdb) BreakFoundNoLoc {changed = True}-(hdb) About to throw first-Stopped at breakpoint-Exception: ErrorCall-Message: boom first-Call stack:-  HasCallStack backtrace:-    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main--Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10-(hdb) Handled first exception: boom first-Continuing after first exception-Stopped at breakpoint-Exception: ErrorCall-Message: boom second-Call stack:-  HasCallStack backtrace:-    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:10:3 in main:Main--Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:10:3-(hdb) 

@@ -0,0 +1,22 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw+Handling exception: boom outer+Stopped at breakpoint+Exception: ErrorCall+Message: boom while handling+Call stack:+  While handling boom outer+  +  HasCallStack backtrace:+    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:14:3 in main:Main+Inner exceptions:+  Exception: ErrorCall+  Message: boom outer+  Call stack:+    HasCallStack backtrace:+      error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:14:3+(hdb) Exiting...

@@ -0,0 +1,22 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw+Handling exception: boom outer+Stopped at breakpoint+Exception: ErrorCall+Message: boom while handling+Call stack:+  While handling boom outer+  +  HasCallStack backtrace:+    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:14:3 in main:Main+Inner exceptions:+  Exception: ErrorCall+  Message: boom outer+  Call stack:+    HasCallStack backtrace:+      error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:14:3+(hdb) 

@@ -1,22 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]-(hdb) BreakFoundNoLoc {changed = True}-(hdb) About to throw-Handling exception: boom outer-Stopped at breakpoint-Exception: ErrorCall-Message: boom while handling-Call stack:-  While handling boom outer-  -  HasCallStack backtrace:-    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:14:3 in main:Main-Inner exceptions:-  Exception: ErrorCall-  Message: boom outer-  Call stack:-    HasCallStack backtrace:-      error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main--Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:14:3-(hdb) 

@@ -0,0 +1,13 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw+Stopped at breakpoint+Exception: ErrorCall+Message: boom+Call stack:+  HasCallStack backtrace:+    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:6:3 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:6:3+(hdb) Exiting...

@@ -0,0 +1,13 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw+Stopped at breakpoint+Exception: ErrorCall+Message: boom+Call stack:+  HasCallStack backtrace:+    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:6:3 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:6:3+(hdb) 

@@ -1,13 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]-(hdb) BreakFoundNoLoc {changed = True}-(hdb) About to throw-Stopped at breakpoint-Exception: ErrorCall-Message: boom-Call stack:-  HasCallStack backtrace:-    error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:6:3 in main:Main--Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:6:3-(hdb) 

@@ -0,0 +1,1 @@+main = putStrLn "Running this program inside the debugger(which is running inside the debugger)"

@@ -0,0 +1,5 @@+break --name runDebugger+run cli test/golden/self-debug-cli/Main.hs+print mkFastString "this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS)."+print mkFastString "We have a DebugView FastString instance at this breakpoint."+exit

@@ -0,0 +1,56 @@+[ 1 of 53] Compiling Development.Debug.Adapter.Handles ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Handles.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[ 2 of 53] Compiling Development.Debug.Options ( <PROJECT-ROOT>/hdb/Development/Debug/Options.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[ 3 of 53] Compiling Development.Debug.Session.Setup ( <PROJECT-ROOT>/hdb/Development/Debug/Session/Setup.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[ 4 of 53] Compiling GHC.Debugger.Breakpoint.Map ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Breakpoint/Map.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[ 5 of 53] Compiling GHC.Debugger.Runtime.Compile.Cache ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Compile/Cache.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[ 6 of 53] Compiling GHC.Debugger.Runtime.Term.Key ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[ 7 of 53] Compiling GHC.Debugger.Interface.Messages ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Interface/Messages.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[ 8 of 53] Compiling GHC.Debugger.Runtime.Interpreter.Custom ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[ 9 of 53] Compiling Development.Debug.Adapter ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[10 of 53] Compiling Development.Debug.Adapter.Proxy ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Proxy.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[11 of 53] Compiling Development.Debug.Adapter.Output ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Output.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[12 of 53] Compiling Development.Debug.Adapter.Interface ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Interface.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[13 of 53] Compiling Development.Debug.Adapter.Stopped ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Stopped.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[14 of 53] Compiling Development.Debug.Adapter.Exit.Helpers ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Exit/Helpers.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[15 of 53] Compiling Development.Debug.Adapter.Exit ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Exit.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[16 of 53] Compiling Development.Debug.Adapter.ExceptionInfo ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/ExceptionInfo.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[17 of 53] Compiling Development.Debug.Adapter.Evaluation ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Evaluation.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[18 of 53] Compiling Development.Debug.Adapter.Stepping ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Stepping.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[19 of 53] Compiling Development.Debug.Adapter.Breakpoints ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Breakpoints.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[20 of 53] Compiling GHC.Debugger.Runtime.Thread.Map ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Thread/Map.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[21 of 53] Compiling GHC.Debugger.Session ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Session.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[22 of 53] Compiling GHC.Debugger.Session.Builtin ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Session/Builtin.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[23 of 53] Compiling GHC.Debugger.Session.Interactive ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Session/Interactive.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[24 of 53] Compiling GHC.Debugger.Utils ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Utils.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[25 of 53] Compiling GHC.Debugger.View.Class ( <PROJECT-ROOT>/haskell-debugger-view/src/GHC/Debugger/View/Class.hs, interpreted )[haskell-debugger-view-<VERSION>-inplace]+[26 of 53] Compiling GHC.Debugger.View.ByteString ( <PROJECT-ROOT>/haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs, interpreted )[haskell-debugger-view-<VERSION>-inplace]+[27 of 53] Compiling GHC.Debugger.Utils.Orphans ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Utils/Orphans.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[28 of 53] Compiling GHC.Debugger.Runtime.Instances.Discover[boot] ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs-boot, interpreted )[haskell-debugger-<VERSION>-inplace]+[29 of 53] Compiling GHC.Debugger.Monad ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Monad.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[30 of 53] Compiling GHC.Debugger.Runtime.Instances.Discover ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[31 of 53] Compiling GHC.Debugger.Runtime.Eval ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Eval.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[32 of 53] Compiling GHC.Debugger.Runtime.Compile ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Compile.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[33 of 53] Compiling GHC.Debugger.Runtime.Eval.RemoteExpr ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[34 of 53] Compiling GHC.Debugger.Runtime.Term.Parser ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[35 of 53] Compiling GHC.Debugger.Runtime.Instances ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Instances.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[36 of 53] Compiling GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[37 of 53] Compiling GHC.Debugger.Runtime.Thread.Stack ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[38 of 53] Compiling GHC.Debugger.Runtime.Thread ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime/Thread.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[39 of 53] Compiling GHC.Debugger.Stopped.Exception ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Stopped/Exception.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[40 of 53] Compiling GHC.Debugger.Runtime ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Runtime.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[41 of 53] Compiling GHC.Debugger.Stopped.Variables ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Stopped/Variables.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[42 of 53] Compiling GHC.Debugger.Stopped ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Stopped.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[43 of 53] Compiling GHC.Debugger.Run ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Run.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[44 of 53] Compiling GHC.Debugger.Breakpoint ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger/Breakpoint.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[45 of 53] Compiling GHC.Debugger     ( <PROJECT-ROOT>/haskell-debugger/GHC/Debugger.hs, interpreted )[haskell-debugger-<VERSION>-inplace]+[46 of 53] Compiling Development.Debug.Interactive ( <PROJECT-ROOT>/hdb/Development/Debug/Interactive.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[47 of 53] Compiling Development.Debug.Adapter.Init ( <PROJECT-ROOT>/hdb/Development/Debug/Adapter/Init.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[48 of 53] Compiling GHC.Debugger.View.Containers ( <PROJECT-ROOT>/haskell-debugger-view/src/GHC/Debugger/View/Containers.hs, interpreted )[haskell-debugger-view-<VERSION>-inplace]+[49 of 53] Compiling GHC.Debugger.View.Text ( <PROJECT-ROOT>/haskell-debugger-view/src/GHC/Debugger/View/Text.hs, interpreted )[haskell-debugger-view-<VERSION>-inplace]+[50 of 53] Compiling Paths_haskell_debugger ( <AUTOGEN-DIR>/Paths_haskell_debugger.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[51 of 53] Compiling Development.Debug.Options.Parser ( <PROJECT-ROOT>/hdb/Development/Debug/Options/Parser.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+[52 of 53] Compiling Main             ( <PROJECT-ROOT>/hdb/Main.hs, interpreted )[haskell-debugger-<VERSION>-inplace-hdb]+(hdb) Stopped at breakpoint+(hdb) this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS).+(hdb) We have a DebugView FastString instance at this breakpoint.+(hdb) Exiting...

@@ -0,0 +1,34 @@+#!/bin/sh++# 1) Run only in .external mode because there are some issues in loading ghc into+# itself with the internal interpreter. Didn't investigate thoroughly.+#+# 2) Since this test is named `....no-tmp-dir....` then it will be run in the root of the tree+#+# 3) Grep out the `BreakFound` word. It doesn't matter for the test and it is+# too prone to changing because it reports source lines of the actual debugger+# source, which we change all the time (unlike testsuite programs).+#+# 4) Normalize cabal autogen paths (e.g. `Paths_haskell_debugger.hs`).+# It's not immediately clear why these go in .cache/hie-bios/... rather than in+# $HDB_CACHE_DIR, but I guess it's an autogen thing rather than the actual+# compilation artifacts cache (.hi, ...)+#+# 5) When testing the sdist (just the packaged things), the root doesn't have a hie.yaml.+#    Add one temporarily+created_yaml=false+if [ ! -f hie.yaml ]; then+    echo 'cradle:\n  cabal:\n    component: "all"' > hie.yaml+    created_yaml=true;+fi++$HDB -v0 hdb/Main.hs < "test/golden/self-debug-cli/self-debug-cli.hdb-stdin" 2>&1 \+  | grep -v "BreakFound" \+  | sed \+      -e 's|[^ ]*/Paths_haskell_debugger.hs|<AUTOGEN-DIR>/Paths_haskell_debugger.hs|g' \+      -e 's|haskell-debugger-[0-9.][0-9.]*-inplace|haskell-debugger-<VERSION>-inplace|g' \+      -e 's|haskell-debugger-view-[0-9.][0-9.]*-inplace|haskell-debugger-view-<VERSION>-inplace|g'++if [ $created_yaml = true ]; then+    rm hie.yaml+fi

@@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes, CPP #-} module Main (main) where -import Data.List (isSuffixOf)+import Data.List (isSuffixOf, isInfixOf) import qualified Data.Set as Set import Text.RE.TDFA.Text.Lazy import Text.Printf@@ -10,6 +10,7 @@ import qualified Data.Text.Lazy.IO as LT import qualified Data.ByteString.Lazy.Char8 as LBS import qualified System.Process as P+import System.Directory import System.FilePath import qualified System.FilePath.Posix as Posix import System.IO.Temp@@ -23,14 +24,35 @@ import Test.Tasty.Golden as G import Test.Tasty.Golden.Advanced as G -import Test.DAP.RunInTerminal+import Test.Integration.LogMessage (logMessageTests)+import Test.Integration.Persistent (persistentTests)+import Test.Integration.RunInTerminal (runInTerminalTests)+import Test.Integration.Scopes (scopesTests)+import Test.Integration.Basic (basicTests)+import Test.Integration.Exceptions (exceptionTests)+import Test.Integration.MultiMain (multiMainTests)+import Test.Integration.MultiHomeUnit (multiHomeUnitTests)+import Test.Integration.Variables (variableTests)+import Test.Integration.StepOut (stepOutTests)+import Test.Integration.Stdout (stdoutTests)+import Test.Integration.Conditional (conditionalTests)+import Test.Integration.Evaluate (evaluateTests)+import Test.Integration.StackTrace (stackTraceTests) import Test.Utils+import qualified Data.Char as C+import qualified Data.Text as T  main :: IO () main = do   env <- getEnvironment-  let mkTest = mkGoldenTest False env+  let mkTest = mkGoldenTest (maybe False read (lookup "KEEP_TEMP_DIRS" env)) env   golden_tests_paths <- findByExtension [".hdb-test"] "test/golden"+    `catch` \(e::IOException) -> do+       hPutStrLn stderr "-- !! ERROR !! -----------------------------------------------------------------"+       hPutStrLn stderr "Failed to find golden tests by `*.hdb-test` extension."+       hPutStrLn stderr "Make sure that the testsuite is being run from the project root (where the relative path `test/golden` is valid)."+       hPutStrLn stderr "--------------------------------------------------------------------------------"+       throwIO e    let internalOnlyTests = filter (\p -> ".internal" `isSuffixOf` takeBaseName p) golden_tests_paths   let externalOnlyTests = filter (\p -> ".external" `isSuffixOf` takeBaseName p) golden_tests_paths@@ -50,8 +72,8 @@   -- (since they run as separate processes). To use a single golden test file for   -- both modes, we disable IPE backtraces by default in tests.   let baseFlags = "--disable-ipe-backtraces"-  default_goldens   <- mapM (mkTest baseFlags) testsForExternal-  intinterp_goldens <- mapM (mkTest ("--internal-interpreter " ++ baseFlags)) testsForInternal+  let default_goldens   = map (mkTest baseFlags) testsForExternal+  let intinterp_goldens = map (mkTest ("--internal-interpreter " ++ baseFlags)) testsForInternal    defaultMain $     testGroup "Tests"@@ -67,31 +89,54 @@ unitTests :: [TestTree] unitTests =   [ runInTerminalTests+  , scopesTests+  , logMessageTests+  , persistentTests+  , basicTests+  , exceptionTests+  , multiMainTests+  , multiHomeUnitTests+  , variableTests+  , stepOutTests+  , stdoutTests+  , conditionalTests+  , evaluateTests+  , stackTraceTests   ]  -- | Receives as an argument the path to the @*.hdb-test@ which contains the -- shell invocation for running-mkGoldenTest :: Bool -> [(String, String)] -> FilePath -> String -> IO TestTree-mkGoldenTest keepTmpDirs inheritedEnv flags path = do-  let testName   = takeBaseName     path-  let goldenPath = replaceExtension path ".hdb-stdout"-  return $ goldenVsStringComparing testName goldenPath action+mkGoldenTest :: Bool -> [(String, String)] -> FilePath -> String -> TestTree+mkGoldenTest keepTmpDirs inheritedEnv flags path = goldenVsStringComparing testName goldenPath topAction   where-    action :: IO LBS.ByteString-    action = do-      withHermeticDir keepTmpDirs (takeDirectory path) $ \test_dir -> do-        (_, Just hout, _, p)-          <- P.createProcess (P.proc "sh" [takeFileName path])-            { P.cwd = Just test_dir, P.std_out = P.CreatePipe-            , P.env = Just $-              inheritedEnv ++-              [ ("HDB", "hdb " ++ flags)-              ]-            }-        P.waitForProcess p >>= \case-          ExitSuccess   -> LBS.hGetContents hout-          ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c+    ghcVersionTag :: String+    ghcVersionTag = show (__GLASGOW_HASKELL__ :: Int) +    testName   = takeBaseName     path+    goldenPath = replaceExtension path (".ghc-" ++ ghcVersionTag ++ ".hdb-stdout")++    noTmpDir = ".no-tmp-dir" `isInfixOf` testName++    topAction :: IO LBS.ByteString+    topAction | noTmpDir  = testAction path =<< getCurrentDirectory -- a bit dangerous! used in the self-debug-cli test+              | otherwise = withHermeticDir keepTmpDirs (takeDirectory path) (testAction (takeFileName path))+++    testAction :: FilePath -> FilePath -> IO LBS.ByteString+    testAction test_path test_dir = do+      (_, Just hout, _, p)+        <- P.createProcess (P.proc "sh" [test_path])+          { P.cwd = Just test_dir, P.std_out = P.CreatePipe+          , P.env = Just $+            inheritedEnv +++            [ ("HDB_CACHE_DIR", test_dir </> ".hdb-cache")+            , ("HDB", "hdb " ++ flags)+            ]+          }+      P.waitForProcess p >>= \case+        ExitSuccess   -> LBS.hGetContents hout+        ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c+ -------------------------------------------------------------------------------- -- Tasty Golden Advanced wrapper --------------------------------------------------------------------------------@@ -106,10 +151,11 @@   -- ^ action that returns a string   -> TestTree   -- ^ the test verifies that the returned string is the same as the golden file contents-goldenVsStringComparing name ref act = do+goldenVsStringComparing name ref act = -  -- Normalise the output. The test file should already be saved normalised.-  goldenTest name (LT.decodeUtf8 <$> readFileStrict ref) normalisingAct cmpNormalising upd+  maybeExpectFail $+    -- Normalise the output. The test file should already be saved normalised.+    goldenTest name (LT.decodeUtf8 <$> readFileStrict ref) normalisingAct cmpNormalising upd    where   upd = createDirectoriesAndWriteFile ref . LT.encodeUtf8@@ -133,6 +179,7 @@   -- Normalise the action producing the output   normalisingAct = do     tmpDir <- getCanonicalTemporaryDirectory+    cwd    <- getCurrentDirectory     let       winTempDirWithForwardSlashes = useForwardSlashes tmpDir     let posixTempDirRegex =@@ -149,6 +196,10 @@       , ( "\\\\", "/" )     -- Use forward slash       , ( posixTempDirRegex {- the folder in which the test is run, inside the canonical temp dir-}         , "<TEMPORARY-DIRECTORY>" )+      , ( "\\.hdb-cache/[^/]+/"+        , ".hdb-cache/<CACHE-ENTRY>/" )+      , ( escapeRegex cwd+        , "<PROJECT-ROOT>" )      ]      let normalising (LT.decodeUtf8 -> txt) = LT.filter (/= '\r') $ foldl' (*=~/) txt replaceREs@@ -163,6 +214,13 @@    forceLbs :: LBS.ByteString -> ()   forceLbs = LBS.foldr seq ()++  -- if testname contains `.fails-234` we expect a failure described by ticket #234+  maybeExpectFail = case T.breakOn ".fails-" (T.pack name) of+    (_, rest)+      | let num = T.takeWhile C.isDigit (T.drop (T.length ".fails-") rest)+      , not (T.null num) -> expectFailBecause ("#" ++ T.unpack num)+      | otherwise -> id  -------------------------------------------------------------------------------- -- Normalisation

@@ -1,122 +1,584 @@--- | Utils essentially copied from `dap`'s test suite+{-# LANGUAGE CPP #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-}-module Test.DAP where+{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------import           Control.Applicative-import           Control.Concurrent-import           Data.Aeson.Encode.Pretty-import           Data.Aeson.Types-import           Data.Aeson.KeyMap-import           Control.Exception hiding (handle)-import qualified Data.ByteString.Lazy.Char8 as BL8 ( hPutStrLn )-import qualified Data.ByteString.Lazy       as LBS-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Char8      as B8 ( hPutStrLn )+module Test.DAP+  ( module Test.DAP+  , module Test.DAP.Init+  , module Test.DAP.Messages+  ) where++import qualified Data.Map as M+import Control.Concurrent.STM+import Control.Monad.IO.Class+import Data.Aeson+import Control.Monad.Reader+import Test.DAP.Init+import Test.DAP.Messages+import Test.DAP.Messages.Parser+import Control.Concurrent.Async+import Control.Monad.Cont+import Control.Monad+import Data.Maybe import qualified Data.HashMap.Strict as H-import           Network.Run.TCP-import           Network.Socket             (socketToHandle)-import           System.IO-import           System.Exit-import           Data.IORef------------------------------------------------------------------------------import           DAP.Utils-import           DAP.Server-import           DAP.Types (Command)------------------------------------------------------------------------------import           Test.Tasty.HUnit+import System.FilePath+import qualified Data.Text as T+import Data.Aeson.Types+import Test.Tasty.HUnit+import DAP (ScopesArguments(..), StackTraceArguments(..), DisconnectArguments(..))+import qualified DAP+import Test.DAP.Orphans ()+import DAP.Types --- | Sends a DAP request to the given handle-sendDAPRequest :: ToJSON a => Handle -> Command -> a -> IO ()-sendDAPRequest handle cmd args = do-  send handle-    [ "seq"      .= (1 :: Int)-    , "type"     .= ("request" :: String)-    , "command"  .= cmd-    , "arguments".= args-    ]+import qualified Data.List as List --- | Receive and decode DAP message-recvDAPResponse-  :: FromJSON a-  => Handle-  -- ^ Handle to receive bytes from-  -> IO a-  -- ^ The decoded DAP message-recvDAPResponse h = do-  readPayload h >>= \case-    Left e -> fail e-    Right actual ->-      -- Read field "body" or "arguments" (for reverse requests)-      case parseMaybe (withObject "response/rev request" $ \r -> (do-              ("response" :: String) <- r .: "type"-              True                   <- r .: "success"-              r .: "body") <|> (do-                ("request" :: String) <- r .: "type"-                r .: "arguments")-            ) actual of-        Nothing -> fail $ "Failed to parse DAP response body: " ++ show actual-        Just body ->-          case parseMaybe parseJSON body of-            Nothing -> fail $ "Failed to parse DAP response body content: " ++ show body-            Just res -> pure res+--------------------------------------------------------------------------------+-- * DSL+--------------------------------------------------------------------------------+-- fill as needed; some parts of the highest level DSL will prefer NOT to be sync. +next, stepIn :: TestDAP ()+next   = void . sync $ nextRequest @Value @Value Null+stepIn = void . sync $ stepInRequest @Value @Value Null++threads :: TestDAP [Thread]+threads = do+  Response{responseBody=Just ThreadsResponse{threads=ts}} <- sync threadsRequest+  return ts++stackTrace :: Int -> TestDAP [StackFrame]+stackTrace tid = do+  Response{responseBody=Just StackTraceResponse{stackFrames=fs}} <- sync $ stackTraceRequest $+    StackTraceArguments+      { DAP.stackTraceArgumentsThreadId = tid+      , DAP.stackTraceArgumentsStartFrame = Nothing+      , DAP.stackTraceArgumentsLevels = Nothing+      , DAP.stackTraceArgumentsFormat = Nothing+      }+  return fs++scopes :: Int {- stack frame id -} -> TestDAP [Scope]+scopes frameId = do+  Response{responseBody=Just ScopesResponse{scopes=scs}} <- sync $ scopesRequest $+    ScopesArguments { DAP.scopesArgumentsFrameId = frameId }+  return scs++configurationDone :: ResponseCont Value a -> TestDAP a+configurationDone = configurationDoneRequest Nothing+ --------------------------------------------------------------------------------+-- ** "Scenarios"+-------------------------------------------------------------------------------- --- | Sample host shared amongst client and server----testHost :: String-testHost = "127.0.0.1"+-- | Register handler that will reply to runInTerminal reverse request+handleRunInTerminal :: AsyncCont (Maybe (H.HashMap T.Text T.Text), [T.Text]) (a, Int)+                    -- ^ Continuation receives async with args of runInTerm req.+                    --+                    -- - Waiting means block waiting for reverse request to be received+                    -- - Returns the process id of the launched runInTerminal process.+                    -> TestDAP a+handleRunInTerminal k = do+  ctx <- ask+  liftIO $+    withAsync (upd <$> runTestDAP waitForReverseRequest ctx) $ \a ->+      runTestDAP (k a >>= \(x, pid) -> do+        respondWithBody 0{-hardcode seqn-} "runInTerminal" (object [ "shellProcessId" .= pid ])+        return x+        ) ctx+  where+    upd :: Value -> (Maybe (H.HashMap T.Text T.Text), [T.Text])+    upd orig =+      fromMaybe (error $ "Failed to parse runInTerminal request: " ++ show orig) $+      parseMaybe parser orig --- | Spawns a new mock client that connects to the mock server.----withNewClient :: Int -- ^ Port-              -> IORef Bool-              -- ^ True if we've already connected once and therefore should no longer retry-              -> (Handle -> IO ())-              -> IO ()-withNewClient port retryVar continue = flip catch exceptionHandler $-  runTCPClient testHost (show port) $ \socket -> do-    h <- socketToHandle socket ReadWriteMode-    hSetNewlineMode h NewlineMode { inputNL = CRLF, outputNL = CRLF }-    continue h `finally` hClose h-      where-        exceptionHandler :: SomeException -> IO ()-        exceptionHandler e = do-          do_retry <- readIORef retryVar-          if do_retry then do-            threadDelay 100_000 -- 0.1s-            -- Do it silently:-            -- putStrLn "Retrying connection..."-            withNewClient port retryVar continue-          else do-            putStrLn $ displayException e-            exitWith (ExitFailure 22)+    parser :: Value -> Parser (Maybe (H.HashMap T.Text T.Text), [T.Text])+    parser = withObject "runInTerminal request" $ \o -> do+      ("request" :: String) <- o .: "type"+      ("runInTerminal" :: String) <- o .: "command"+      argsObj <- o .: "arguments"+      withObject "runInTerminal arguments" (\a -> do+        env :: Maybe (H.HashMap T.Text T.Text) <- a .:? "env"+        args :: [T.Text] <- a .: "args"+        pure (env, args)+        ) argsObj --- | Helper to send JSON payloads to the server----send :: Handle -> [Pair] -> IO ()-send h message-  = BS.hPutStr h $ encodeBaseProtocolMessage (object message)+-- | Launch a config, run to completion and assert the exit code.+runToEnd :: LaunchConfig -> TestDAP ()+runToEnd cfg = do+  _ <- sync $ launchWith cfg+  waitFiltering_ EventTy "initialized"+  _ <- sync configurationDone+  waitForExitCode 0 --- | Helper to receive JSON payloads to the client--- checks if 'Handle' returns a subset expected payload+--------------------------------------------------------------------------------+-- ** Custom launch configs+--------------------------------------------------------------------------------++-- | Launch configuration for the debugger. Mirrors the NodeJS test config.+data LaunchConfig = LaunchConfig+  { lcProjectRoot :: FilePath+  , lcEntryFile :: Maybe FilePath+  , lcEntryPoint :: Maybe String+  , lcEntryArgs :: [String]+  , lcExtraGhcArgs :: [String]+  , lcInternalInterpreter :: Maybe Bool+  }++-- | A launch config with the given project root and entry file. @entryPoint@+-- defaults to @main@ and there are no extra args.+mkLaunchConfig :: FilePath -> FilePath -> LaunchConfig+mkLaunchConfig projectRoot entryFile = LaunchConfig+  { lcProjectRoot = projectRoot+  , lcEntryFile = Just entryFile+  , lcEntryPoint = Just "main"+  , lcEntryArgs = []+  , lcExtraGhcArgs = []+  , lcInternalInterpreter = Nothing+  }++-- | Launch the debugger with a 'LaunchConfig'.+launchWith :: LaunchConfig -> ResponseCont Value a -> TestDAP a+launchWith LaunchConfig{..} = launch $ object $+  [ "projectRoot" .= lcProjectRoot+  , "request" .= ("launch" :: String)+  ] +++  [ "entryFile" .= (lcProjectRoot </> ef) | Just ef <- [lcEntryFile] ] +++  [ "entryPoint" .= ep | Just ep <- [lcEntryPoint] ] +++  [ "entryArgs" .= lcEntryArgs ] +++  [ "extraGhcArgs" .= lcExtraGhcArgs ] +++  [ "internalInterpreter" .= b | Just b <- [lcInternalInterpreter] ]++-- | Set breakpoints in a particular source file of a project at the given+-- lines.+setLineBreakpoints :: FilePath -- ^ project root+                   -> FilePath -- ^ entry file (relative to project root)+                   -> [Int]+                   -> ResponseCont Value a -> TestDAP a+setLineBreakpoints projectRoot entryFile lines_ =+  setBreakpointsIn projectRoot entryFile+    [ defaultSourceBreakpoint { sourceBreakpointLine = l } | l <- lines_ ]++-- | Set breakpoints (with arbitrary 'SourceBreakpoint's) in a particular+-- source file of a project.+setBreakpointsIn :: FilePath -- ^ project root+                 -> FilePath -- ^ source file (relative to project root)+                 -> [SourceBreakpoint]+                 -> ResponseCont Value a -> TestDAP a+setBreakpointsIn projectRoot entryFile bps =+  setBreakpointsRequest DAP.SetBreakpointsArguments+    { DAP.setBreakpointsArgumentsSource = DAP.defaultSource+        { DAP.sourceName = Just (T.pack (takeFileName entryFile))+        , DAP.sourcePath = Just (T.pack (projectRoot </> entryFile))+        }+    , DAP.setBreakpointsArgumentsBreakpoints = Just bps+    , DAP.setBreakpointsArgumentsLines = Just [sourceBreakpointLine bp | bp <- bps]+    , DAP.setBreakpointsArgumentsSourceModified = Just False+    }++-- | Launch, configure breakpoint, hit breakpoint.+hitBreakpointWith :: LaunchConfig -> Int -> TestDAP ()+hitBreakpointWith cfg@LaunchConfig{..} line = do+  entryFile <- maybe (fail "hitBreakpointWith: missing entryFile") pure lcEntryFile+  hitBreakpointIn cfg entryFile line++-- | Launch, configure a breakpoint in the given source file (relative to+-- the project root) at the given line, then wait for it to be hit.+hitBreakpointIn :: LaunchConfig -> FilePath -> Int -> TestDAP ()+hitBreakpointIn cfg@LaunchConfig{..} bpFile line = do+  _ <- sync $ launchWith cfg+  waitFiltering_ EventTy "initialized"+  _ <- sync $ setLineBreakpoints lcProjectRoot bpFile [line]+  _ <- sync configurationDone+  _ <- assertStoppedLocation DAP.StoppedEventReasonBreakpoint line+  return ()++--------------------------------------------------------------------------------+-- ** Variable inspection+--------------------------------------------------------------------------------+data VarsView = VarsView+  { varsViewDesc :: String+  , varsViewVars :: M.Map T.Text [Variable] }++mkVarsView :: String -> [Variable] -> VarsView+mkVarsView ctxDesc vs = VarsView+  { varsViewDesc = ctxDesc+  , varsViewVars = M.fromListWith (++) [(variableName v, [v]) | v <- vs] }++-- | Get variable by name+(%) :: VarsView -> String -> Variable+(%) vv n = case vv %% n of+  [v] -> v+  what -> error $ "Unexpected *many* variables by name " ++ show n ++ ": " ++ show what++-- | Get variables by name (there may be more than one with the same name; e.g. consider punning)+(%%) :: VarsView -> String -> [Variable]+(%%) VarsView{..} n+  | Just vs <- M.lookup (T.pack n) varsViewVars = vs+  | otherwise = error $+      "Variable " ++ show n ++ " not found in " ++ varsViewDesc ++ ": " ++ show (M.keys varsViewVars)+--------------------------------------------------------------------------------+-- | Fetch all variables from the scope with the given name in the top-most+-- frame of the first thread.+fetchScopeVars :: T.Text -> TestDAP VarsView+fetchScopeVars scopeName_ = do+  Response{responseBody=Just ThreadsResponse{threads=t:_}} <- sync threadsRequest+  Response{responseBody=Just StackTraceResponse{stackFrames=fr:_}} <- sync $ stackTraceRequest $+    StackTraceArguments+      { DAP.stackTraceArgumentsThreadId = threadId t+      , DAP.stackTraceArgumentsStartFrame = Nothing+      , DAP.stackTraceArgumentsLevels = Nothing+      , DAP.stackTraceArgumentsFormat = Nothing+      }+  Response{responseBody=Just ScopesResponse{scopes=scs}} <- sync $ scopesRequest $+    ScopesArguments { DAP.scopesArgumentsFrameId = stackFrameId fr }+  case List.find ((== scopeName_) . scopeName) scs of+    Nothing -> liftIO $ assertFailure $+      "fetchScopeVars: scope " ++ show scopeName_+        ++ " not found (" ++ show (map scopeName scs) ++ ")"+    Just sc -> do+      vs <- fetchChildren (scopeVariablesReference sc)+      pure $ mkVarsView ("scope " ++ show scopeName_) vs++fetchLocalVars :: TestDAP VarsView+fetchLocalVars = fetchScopeVars "Locals"++fetchModuleVars :: TestDAP VarsView+fetchModuleVars = fetchScopeVars "Module"++-- | Get the children of a variable by its variablesReference.+fetchChildren :: Int -> TestDAP [Variable]+fetchChildren ref = do+  Response{responseBody=Just (VariablesResponse vs)} <- sync $ variablesRequest $+    VariablesArguments+      { DAP.variablesArgumentsVariablesReference = ref+      , DAP.variablesArgumentsFilter = Nothing+      , DAP.variablesArgumentsStart = Nothing+      , DAP.variablesArgumentsCount = Nothing+      , DAP.variablesArgumentsFormat = Nothing+      }+  return vs++-- | Force a lazy variable by sending a 'variables' request for its reference+-- and returning the first child.+forceLazy :: HasCallStack => Variable -> TestDAP Variable+forceLazy v = do+  liftIO $ do+    assertEqual ("Variable " ++ show (variableName v) ++ " should be lazy")+      (Just True) (variablePresentationHintLazy =<< variablePresentationHint v)+    assertEqual ("Variable " ++ show (variableName v) ++ " should be \"_\" because it is lazy") "_" (variableValue v)+    assertBool ("Variable " ++ show (variableName v) ++ " should be expandable (because it is a lazy var)") $+      variableVariablesReference v /= 0 -- if it is expandable we get a reference to use to expand here++  -- Force the lazy variable by using its reference+  vs <- fetchChildren (variableVariablesReference v)+  case vs of+    (v':_) -> pure v'+    [] -> liftIO $ assertFailure $ "forceLazy: no children for forced variable " ++ show (variableName v)++-- | Expand a structured variable.+expandVar :: HasCallStack => Variable -> TestDAP VarsView+expandVar v = do+  liftIO $+    assertBool ("Variable " ++ show (variableName v) ++ " should be expandable (it should have structure)") $+      variableVariablesReference v /= 0+  vs <- fetchChildren (variableVariablesReference v)+  pure $ mkVarsView ("children of " ++ T.unpack (variableName v)) vs++-- | Assert that a variable has a given String value.+assertIsString :: HasCallStack => Variable -> T.Text -> TestDAP ()+assertIsString v expected = liftIO $ do+  assertEqual ("Variable " ++ show (variableName v) ++ " should be a String")+    (Just "String") (variableType v)+  assertEqual ("Variable " ++ show (variableName v) ++ " should be " ++ show expected)+    expected (variableValue v)+  assertEqual ("Variable " ++ show (variableName v) ++ " should not be expandable (because it is a String)")+    0 (variableVariablesReference v)++-- | Assert the value of some variable.+-- e.g. @var \@==? "\"hello\""@+(@==?) :: HasCallStack => Variable -> T.Text -> TestDAP ()+(@==?) v expected = liftIO $ assertEqual (T.unpack (variableValue v) ++ " @==? " ++ T.unpack expected) expected (variableValue v)++--------------------------------------------------------------------------------+-- ** Exception info & other requests+--------------------------------------------------------------------------------++exceptionInfo :: Int -> TestDAP ExceptionInfoResponse+exceptionInfo tid = do+  Response{responseBody=Just r} <- sync $ exceptionInfoRequest $+    ExceptionInfoArguments { DAP.exceptionInfoArgumentsThreadId = tid }+  return r++setBreakOnException :: TestDAP ()+setBreakOnException = do+  _ <- sync $ setExceptionBreakpointsRequest @_ @Value+    SetExceptionBreakpointsArguments+      { DAP.setExceptionBreakpointsArgumentsFilters = ["break-on-exception"]+      , DAP.setExceptionBreakpointsArgumentsFilterOptions = Nothing+      , DAP.setExceptionBreakpointsArgumentsExceptionOptions = Nothing+      }+  pure ()++continueThread :: Int -> TestDAP ()+continueThread tid = do+  _ <- sync $ continueRequest @_ @Value+    ContinueArguments+      { DAP.continueArgumentsThreadId = tid+      , DAP.continueArgumentsSingleThread = False+      }+  pure ()++evaluate :: T.Text -> TestDAP EvaluateResponse+evaluate expr = do+  Response{responseBody=Just r} <- sync $ evaluateRequest $+    EvaluateArguments+      { DAP.evaluateArgumentsExpression = expr+      , DAP.evaluateArgumentsFrameId = Nothing+      , DAP.evaluateArgumentsContext = Nothing+      , DAP.evaluateArgumentsFormat = Nothing+      }+  return r++stepOut :: Int -> TestDAP ()+stepOut tid = do+  _ <- sync $ stepOutRequest @_ @Value+    StepOutArguments+      { DAP.stepOutArgumentsThreadId = tid+      , DAP.stepOutArgumentsSingleThread = False+      , DAP.stepOutArgumentsGranularity = Nothing+      }+  pure ()++-- | Wait for an "exited" event and assert the exit code.+waitForExitCode :: Int -> TestDAP ()+waitForExitCode expected = do+  Event{eventBody = Just ExitedEvent{exitedEventExitCode}} <- waitFiltering EventTy "exited"+  liftIO $ assertEqual ("exit code should be " ++ show expected) expected exitedEventExitCode++disconnect :: TestDAP ()+disconnect = do+  Response{responseSuccess} <- sync $ disconnectRequest @_ @Value $ Just+    DisconnectArguments+      { DAP.disconnectArgumentsRestart = False+      , DAP.disconnectArgumentsTerminateDebuggee = True+      , DAP.disconnectArgumentsSuspendDebuggee = False+      }+  liftIO $ assertBool "disconnect response should indicate success" responseSuccess+  return ()++--------------------------------------------------------------------------------+-- ** Convenience methods (based on vscode-debugadapter-node/testSupport)+--------------------------------------------------------------------------------++launch :: Value {-^ Launch args -} -> ResponseCont Value a -> TestDAP a+launch args = runContT $+  ContT initializeRequest+    >>= liftIO . wait+    >> ContT (launchRequest args)++configurationSequence :: ResponseCont Value a -> TestDAP a+configurationSequence k = do+  waitFiltering_ EventTy "initialized"+  configurationDone k++-- | Assert that a "stopped" event with the given reason is received, then+-- fetch the stack trace and assert the top frame is at the expected line.+assertStoppedLocation :: HasCallStack => DAP.StoppedEventReason -> Int -> TestDAP ()+assertStoppedLocation reason expectedLine = do+  Event{eventBody = Just StoppedEvent{stoppedEventReason, stoppedEventThreadId}} <- waitFiltering EventTy "stopped"+  liftIO $ assertBool "Stopped reason matches expected reason" (stoppedEventReason == reason)+  frames <- maybe (pure []) stackTrace stoppedEventThreadId+  case frames of+    (frame:_) -> liftIO $ assertEqual "stopped location: line mismatch" expectedLine (stackFrameLine frame)+    []        -> liftIO $ assertFailure "assertStoppedLocation: no stack frames"++-- | Assert that all *pending*(not yet taken from channel) accumulated output+-- events (until any other event is found) contain a certain string+assertOutput :: HasCallStack => T.Text -> TestDAP ()+assertOutput expected = do+  events <- waitAccumulating EventTy "output"+  let outputs = map (outputEventOutput . fromMaybe (error "assertOutput:fromMaybe") . eventBody) events+  liftIO $+    assertBool+      ("assertOutput: expecting " ++ show expected ++ " but got " ++ show outputs)+      (any (T.isInfixOf expected) outputs)++assertFullOutput :: HasCallStack => T.Text -> TestDAP ()+assertFullOutput expected = assertFullOutputWith (expected <> " \\in full_output") (T.isInfixOf expected)++assertNotFullOutput :: HasCallStack => T.Text -> TestDAP ()+assertNotFullOutput expected = assertFullOutputWith (expected <> " \\notin full_output") (not . T.isInfixOf expected)++-- | Assert that the full output up until now matches any given string with the given function+assertFullOutputWith :: HasCallStack => T.Text -> (T.Text -> Bool) -> TestDAP ()+assertFullOutputWith assertStr test = do+  TestDAPClientContext{..} <- ask+  fullOut <- liftIO $ readTVarIO clientFullOutput+  liftIO $ assertBool+    ("assertFullOutputWith: asserting '" ++ show assertStr ++ "' but got " ++ show fullOut)+    (any test fullOut)++--------------------------------------------------------------------------------+-- * Waiting for messages+--------------------------------------------------------------------------------++data MsgType = EventTy | ResponseTy | ReverseRequestTy+  deriving Show++msgChan :: MsgType -> TestDAPClientContext -> TChan Value+msgChan ty TestDAPClientContext{..} = case ty of+  EventTy          -> clientEvents+  ResponseTy       -> clientResponses+  ReverseRequestTy -> clientReverseRequests++msgMatch :: MsgType -> String -> MessageMatch+msgMatch ty s = case ty of+  EventTy         -> eventMatch s+  ResponseTy      -> responseMatch s+  ReverseRequestTy -> reverseRequestMatch s++waitFiltering_ :: MsgType -> String -> TestDAP ()+waitFiltering_ ty s = void $ waitFiltering @Value ty s++-- | Drop messages of the given type until a message with the given+-- eventType/command is found. The matching message is returned.+-- FIXME: Timeouts on waiting, to avoid hanging forever in the testsuite!!+waitFiltering :: forall a. FromJSON a => MsgType -> String -> TestDAP a+waitFiltering ty s = do+  ch <- asks (msgChan ty)+  let mm = msgMatch ty s+  let loop = do+        v <- atomically $ readTChan ch -- block waiting for input+        if messageMatchMatches mm v+          then case fromJSON @a v of+            Error e -> error $ "waitFiltering: Failed to parse message MATCHING " ++ s ++ ":" ++ show ty ++ " with error: " ++ e ++ "\nFull message was: " ++ show v+            Success x -> return x+          else loop+  liftIO loop++-- | Accumulate messages of the given type until a message with a+-- eventType/command different from the given one is found. ---shouldReceive-  :: Handle-  -- ^ Handle to receive bytes from-  -> [Pair]-  -- ^ Subset of JSON values that should be present in the payload-  -> IO ()-shouldReceive h expected = do-  case object expected of-    Object ex ->-      readPayload h >>= \case-        Left e -> fail e-        Right actual-          | toHashMapText ex `H.isSubmapOf` toHashMapText actual -> pure ()-          | otherwise -> encodePretty ex @=? encodePretty actual-    _ -> fail "Invalid JSON"+-- The non-matching message is not consumed, nor returned, and will be kept in+-- the messages buffer.+waitAccumulating :: forall a. FromJSON a => MsgType -> String -> TestDAP [a]+waitAccumulating ty s = do+  ch <- asks (msgChan ty)+  let mm = msgMatch ty s+  let loop acc = do+        r <- atomically $ do+          v <- readTChan ch+          if messageMatchMatches mm v+            then case fromJSON @a v of+              Error e -> error $ "waitAccumulating: Failed to parse MATCHING message body with error: " ++ e ++ "\nFull message was: " ++ show v+              Success x -> pure (Just x)+            else Nothing <$ unGetTChan ch v+        case r of+          Nothing -> return (reverse acc)+          Just v  -> loop (v:acc)+  liftIO $ loop []++--------------------------------------------------------------------------------+-- * Protocol requests (based on vscode-debugadapter-node/testSupport)+--------------------------------------------------------------------------------++initializeRequest :: ResponseCont Value a -> TestDAP a+initializeRequest k = do+  TestDAPClientContext{clientSupportsRunInTerminal} <- ask+  customRequest "initialize"+    (Just $ object $+      [ "adapterID" .= ("haskell-debugger" :: String)+      , "clientID" .= ("mock-client" :: String)+      , "clientName" .= ("Mock Client" :: String)+      , "linesStartAt1" .= True+      , "columnsStartAt1" .= True+      , "locale" .= ("en" :: String)+      , "pathFormat" .= ("path" :: String)+      , "supportsRunInTerminalRequest" .= clientSupportsRunInTerminal+      ]) k++configurationDoneRequest :: Maybe Value -> ResponseCont Value a -> TestDAP a+configurationDoneRequest = customRequest "configurationDone"++launchRequest, attachRequest, restartRequest, setBreakpointsRequest,+  setFunctionBreakpointsRequest, setExceptionBreakpointsRequest,+  setInstructionBreakpointsRequest, dataBreakpointInfoRequest,+  setDataBreakpointsRequest, continueRequest, nextRequest, stepInRequest,+  stepOutRequest, stepBackRequest, reverseContinueRequest, restartFrameRequest,+  gotoRequest, pauseRequest, stackTraceRequest, scopesRequest, variablesRequest,+  setVariableRequest, sourceRequest, modulesRequest, evaluateRequest,+  disassembleRequest, stepInTargetsRequest, gotoTargetsRequest, completionsRequest,+  exceptionInfoRequest, readMemoryRequest, writeMemoryRequest :: (ToJSON a, FromJSON b) => a -> ResponseCont b r -> TestDAP r++launchRequest                    = requestWithArgs "launch"+attachRequest                    = requestWithArgs "attach"+restartRequest                   = requestWithArgs "restart"+setBreakpointsRequest            = requestWithArgs "setBreakpoints"+setFunctionBreakpointsRequest    = requestWithArgs "setFunctionBreakpoints"+setExceptionBreakpointsRequest   = requestWithArgs "setExceptionBreakpoints"+setInstructionBreakpointsRequest = requestWithArgs "setInstructionBreakpoints"+dataBreakpointInfoRequest        = requestWithArgs "dataBreakpointInfo"+setDataBreakpointsRequest        = requestWithArgs "setDataBreakpoints"+continueRequest                  = requestWithArgs "continue"+nextRequest                      = requestWithArgs "next"+stepInRequest                    = requestWithArgs "stepIn"+stepOutRequest                   = requestWithArgs "stepOut"+stepBackRequest                  = requestWithArgs "stepBack"+reverseContinueRequest           = requestWithArgs "reverseContinue"+restartFrameRequest              = requestWithArgs "restartFrame"+gotoRequest                      = requestWithArgs "goto"+pauseRequest                     = requestWithArgs "pause"+stackTraceRequest                = requestWithArgs "stackTrace"+scopesRequest                    = requestWithArgs "scopes"+variablesRequest                 = requestWithArgs "variables"+setVariableRequest               = requestWithArgs "setVariable"+sourceRequest                    = requestWithArgs "source"+modulesRequest                   = requestWithArgs "modules"+evaluateRequest                  = requestWithArgs "evaluate"+disassembleRequest               = requestWithArgs "disassemble"+stepInTargetsRequest             = requestWithArgs "stepInTargets"+gotoTargetsRequest               = requestWithArgs "gotoTargets"+completionsRequest               = requestWithArgs "completions"+exceptionInfoRequest             = requestWithArgs "exceptionInfo"+readMemoryRequest                = requestWithArgs "readMemory"+writeMemoryRequest               = requestWithArgs "writeMemory"++terminateRequest, disconnectRequest :: (ToJSON a, FromJSON b) => Maybe a -> ResponseCont b r -> TestDAP r+terminateRequest  = customRequest "terminate"+-- example:+--  object+--    [ "restart" .= False+--    , "terminateDebuggee" .= True+--    , "suspendDebuggee" .= False+--    ]+-- then...+-- wait "disconnected"+-- waitEventFiltering $ eventMatch "terminated"+disconnectRequest = customRequest "disconnect"++threadsRequest :: FromJSON b => ResponseCont b r -> TestDAP r+threadsRequest = customRequest "threads" (Nothing :: Maybe ())+--------------------------------------------------------------------------------+requestWithArgs :: (ToJSON a, FromJSON b) => String -> a -> ResponseCont b r -> TestDAP r+requestWithArgs command args = customRequest command (Just args)++-- example: respondWithBody revReqNum [ "shellProcessId" .= ... ]+respondWithBody :: Int -> String -> Value -> TestDAP ()+respondWithBody seqNum command body =+  reply seqNum $+    [ "type" .= ("response" :: String)+    , "command" .= command+    , "success" .= True+    , "body" .= body+    ]+--------------------------------------------------------------------------------+customRequest :: (ToJSON a, FromJSON b) => String -> Maybe a -> ResponseCont b r -> TestDAP r+customRequest command args = do+  send $+    [ "type" .= ("request" :: String)+    , "command" .= command+    ] ++ maybe [] (\v -> ["arguments" .= v]) args