haskell-debugger (empty) → 0.5.0.0
raw patch · 30 files changed
+4057/−0 lines, 30 filesdep +aesondep +arraydep +async
Dependencies added: aeson, array, async, base, base16-bytestring, binary, bytestring, co-log-core, containers, cryptohash-sha1, dap, directory, exceptions, filepath, ghc, ghci, haskell-debugger, hie-bios, implicit-hie, mtl, prettyprinter, process, text, time, transformers, unix
Files
- CHANGELOG.md +33/−0
- LICENSE +29/−0
- README.md +142/−0
- haskell-debugger.cabal +135/−0
- haskell-debugger/GHC/Debugger.hs +51/−0
- haskell-debugger/GHC/Debugger/Breakpoint.hs +139/−0
- haskell-debugger/GHC/Debugger/Evaluation.hs +175/−0
- haskell-debugger/GHC/Debugger/Interface/Messages.hs +325/−0
- haskell-debugger/GHC/Debugger/Monad.hs +463/−0
- haskell-debugger/GHC/Debugger/Runtime.hs +76/−0
- haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs +60/−0
- haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs +41/−0
- haskell-debugger/GHC/Debugger/Session.hs +335/−0
- haskell-debugger/GHC/Debugger/Stopped.hs +263/−0
- haskell-debugger/GHC/Debugger/Stopped/Variables.hs +138/−0
- haskell-debugger/GHC/Debugger/Utils.hs +35/−0
- hdb/Development/Debug/Adapter.hs +59/−0
- hdb/Development/Debug/Adapter/Breakpoints.hs +170/−0
- hdb/Development/Debug/Adapter/Evaluation.hs +104/−0
- hdb/Development/Debug/Adapter/Exit.hs +107/−0
- hdb/Development/Debug/Adapter/Flags.hs +268/−0
- hdb/Development/Debug/Adapter/Handles.hs +142/−0
- hdb/Development/Debug/Adapter/Init.hs +259/−0
- hdb/Development/Debug/Adapter/Interface.hs +35/−0
- hdb/Development/Debug/Adapter/Logger.hs +67/−0
- hdb/Development/Debug/Adapter/Output.hs +55/−0
- hdb/Development/Debug/Adapter/Stepping.hs +31/−0
- hdb/Development/Debug/Adapter/Stopped.hs +166/−0
- hdb/Main.hs +150/−0
- test/haskell/Main.hs +4/−0
+ CHANGELOG.md view
@@ -0,0 +1,33 @@+# Revision history for haskell-debugger++## 0.5.0.0 -- 2025-08-26++* Compatibility with GHC 9.14+* Add support for stepping out of functions as a tech preview+* Use implicit cradle discovery to better support multiple configurations,+ mirroring HLS (and thus providing a more similar experience)+* Query the GHC runtime version via hie-bios, now honoring e.g. `with-compiler:+ ...` in `cabal.project` to fetch the right GHC version+* Rename package from `ghc-debugger` to `haskell-debugger`, and+ `ghc-debug-adapter` to `hdb`, to be consistent with other tools and+ ecosystems and to avoid ambiguity with `ghc-debug` (program heap analysis library and+ tool)+* Use cache directories for `hdb` to have faster startup times. This will only+ be enabled for compilers supporting the upcoming `.gbc` (compiled bytecode+ artifact) files.++## 0.4.0.0 -- 2025-06-27++* Add support for debugging multiple home units (MHU)++## 0.3.0.0 -- 2025-06-07++* Critical fixes for variables inspection++## 0.2.0.0 -- 2025-05-13++* Significantly improves variable inspection and expansion commands.++## 0.1.0.0 -- 2025-05-08++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,142 @@+# GHC Debugger++Status: **Work In Progress**++We are working on a first class debugger for Haskell.+It is still not ready for general consumption!++We will properly announce through the common channels the debugger when the+first major release is ready.++ ++# Installation++> [!WARNING]+> `hdb` is only supported by the latest nightly GHC version.+> The first release it will be compatible with is GHC 9.14.++To install and use the GHC debugger, you need the executable `hdb`+and the VSCode extension `haskell-debugger-extension`.++Since `hdb` implements the [Debug Adapter Protocol+(DAP)](https://microsoft.github.io/debug-adapter-protocol/), it also supports+debugging with tools such as vim, neovim, or emacs -- as long as a DAP client is+installed and the `launch` arguments for `hdb` configured.++To build, install, and run `hdb` you currently need a nightly+version of GHC in PATH. You can get one using+[GHCup](https://ghcup.readthedocs.io/en/latest/guide/), or [building from source](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparation):+```+ghcup config add-release-channel https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml+ghcup install ghc latest-nightly +PATH=$(dirname $(ghcup whereis ghc latest-nightly)):$PATH cabal install haskell-debugger:hdb --enable-executable-dynamic --allow-newer=ghc-bignum,containers,time,ghc+```++To run the debugger, the same nightly version of GHC needs to be in PATH. Make+sure the DAP client knows this. For instance, to launch VSCode use:+```+PATH=$(dirname $(ghcup whereis ghc latest-nightly)):$PATH code /path/to/proj+```+Currently, to install the debugger extension, download the `.vsix` file from the+GitHub release artifacts and drag and drop it to the extensions side panel. In+the future we will release it on the marketplace.++# Usage++To use the debugger in VSCode, select the debugger tab, select Haskell Debugger,+and create a `launch.json` file by clicking the debugger settings icon (next to+the green run button).++The `launch.json` file contains some settings about the debugger session here.+Namely:++| Setting | Description |+| --- | --- |+| `entryFile` | the relative path from the project root to the file with the entry point for execution |+| `entryPoint` | the name of the function that is called to start execution |+| `entryArgs` | the arguments passed to the `entryPoint`. If the `entryPoint` is `main`, these arguments are passed as environment arguments (as in `getArgs`) rather than direct function arguments. |+| `extraGhcArgs` | additional flags to pass to the ghc invocation that loads the program for debugging. |++Change them accordingly.++To run the debugger, simply hit the green run button.+See the Features section below for what is currently supported.++Note: Listing global variables is only supported in GHC versions newer than May 6, 2025++# Related Work++`hdb` is inspired by the original+[`haskell-debug-adapter`](https://github.com/phoityne/haskell-debug-adapter/) by @phoityne.++`hdb` improves on the original ideas implemented in+`haskell-debug-adapter` but makes them more robust by implementing the debugger+directly via the GHC API (similarly to HLS), rather than by communicating with a+custom `ghci` process.++We have been doing custom work on GHC to support debugging in a predictable,+robust, and more performant way. That is why `hdb` is only+compatible with the latest and greatest GHC. If you want to debug using an older+GHC version (9.12 and older), please check out `haskell-debug-adapter`.++To implement the Debug Adapter Protocol (DAP) server part, we are using the+[`dap`](https://hackage.haskell.org/package/dap-0.2.0.0) library by @dmjio.+`dap` is a framework for building language-agnostic DAP.++The `hdb` is transparently compatible with most projects (simple,+Cabal, Stack, custom `hie.yaml`) because+it uses [`hie-bios`](https://github.com/haskell/hie-bios) to figure out the+right flags to prepare the GHC session with.+++# Features++Many not listed! Here are a few things:++## Stepping++- [x] Continue (resume execution forward)+- [x] Next (step within local function)+- [x] Step into (single step to next immediate tick)+- [x] Step out (execute until end of function and break after the call)++### In Reverse++- [ ] Local step backwards (ie reverse of Next)+- [ ] Single step backwards (ie reverse of Step into)+- [ ] Continue backwards (resume execution backwards until a breakpoint is hit)++## Breakpoints++- [x] Module breakpoints+- [x] Function breakpoints+- [x] Exception breakpoints+- [ ] Data breakpoints+- [ ] Instruction breakpoints++### Conditionals+- [ ] Conditional breakpoints (breakpoint is hit only if condition is satisfied)+- [ ] Hit conditional breakpoints (stop after N number of hits)++# Building from source++To build `hdb`:+```+cabal build -w /path/to/recent/ghc exe:hdb+```++To build the VSCode extension+```+cd vscode-extension+nix-build+```++## Testing++```+cd test/integration-tests+nix-shell+make GHC=/path/to/recent/ghc \+ DEBUGGER=$(cd ../.. && cabal list-bin -w /path/to/recent/ghc exe:hdb)+```
+ haskell-debugger.cabal view
@@ -0,0 +1,135 @@+cabal-version: 3.12+name: haskell-debugger+version: 0.5.0.0+synopsis:+ A step-through machine-interface debugger for GHC Haskell++description: The GHC debugger package provides a standalone executable+ called @hdb@ which can be used to step-through Haskell+ 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+license-file: LICENSE+author: Rodrigo Mesquita+maintainer: rodrigo@well-typed.com+-- copyright:+category: Development+build-type: Simple+extra-doc-files: CHANGELOG.md+ README.md+homepage: https://github.com/well-typed/haskell-debugger+bug-reports: https://github.com/well-typed/haskell-debugger/issues++source-repository head+ type: git+ location: https://github.com/well-typed/haskell-debugger++common warnings+ ghc-options: -Wall++-- custom-setup+-- setup-depends:+-- base >= 4.21 && < 5,+-- Cabal-hooks >= 3.14 && < 3.18,++library+ import: warnings+ exposed-modules: GHC.Debugger,+ GHC.Debugger.Evaluation,+ GHC.Debugger.Breakpoint,+ GHC.Debugger.Stopped,+ GHC.Debugger.Stopped.Variables,+ GHC.Debugger.Utils,+ GHC.Debugger.Runtime,++ GHC.Debugger.Runtime.Term.Key,+ GHC.Debugger.Runtime.Term.Cache,++ GHC.Debugger.Monad,+ GHC.Debugger.Session,+ GHC.Debugger.Interface.Messages+ -- other-modules:+ default-extensions: CPP+ build-depends: base > 4.21 && < 5,+ ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16,+ array >= 0.5.8 && < 0.6,+ containers >= 0.7 && < 0.9,+ mtl >= 2.3 && < 3,+ binary >= 0.8.9 && < 0.11,+ process >= 1.6.25 && < 1.7,+ unix >= 2.8.6 && < 2.9,+ filepath >= 1.5.4 && < 1.6,+ directory >= 1.3.9.0 && < 1.4,+ exceptions >= 0.10.9 && < 0.11,+ bytestring >= 0.12.1 && < 0.13,+ 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.18++ hs-source-dirs: haskell-debugger+ default-language: Haskell2010++executable hdb+ import: warnings+ main-is: Main.hs+ other-modules: Development.Debug.Adapter.Flags,+ Development.Debug.Adapter.Breakpoints,+ Development.Debug.Adapter.Stepping,+ Development.Debug.Adapter.Stopped,+ Development.Debug.Adapter.Evaluation,+ Development.Debug.Adapter.Init,+ Development.Debug.Adapter.Interface,+ Development.Debug.Adapter.Logger,+ Development.Debug.Adapter.Output,+ Development.Debug.Adapter.Exit,+ Development.Debug.Adapter.Handles,+ Development.Debug.Adapter+ build-depends:+ base, ghc,+ exceptions, aeson, bytestring,+ containers, filepath,+ process, mtl, unix,+ prettyprinter >= 1.7.1 && < 2,++ haskell-debugger,+ hie-bios,+ co-log-core >= 0.3.2.5 && < 0.4,+ implicit-hie ^>=0.1.4.0,+ transformers >= 0.6 && < 0.7,++ time >= 1.15 && < 2,+ directory >= 1.3.9 && < 1.4,+ async >= 2.2.5 && < 2.3,+ text >= 2.1 && < 2.3,+ dap >= 0.2 && < 1,+ hs-source-dirs: hdb+ default-language: GHC2021+ default-extensions: CPP+ ghc-options: -threaded++test-suite haskell-debugger-test+ import: warnings+ default-language: Haskell2010+ -- other-modules:+ -- other-extensions:+ type: exitcode-stdio-1.0+ hs-source-dirs: test/haskell/+ main-is: Main.hs+ build-depends:+ base >=4.14,+ haskell-debugger
+ haskell-debugger/GHC/Debugger.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+ DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+ TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger where++import System.Exit+import Control.Monad.IO.Class+import GHC.Types.Name.Occurrence (sizeOccEnv)++import GHC.Debugger.Breakpoint+import GHC.Debugger.Evaluation+import GHC.Debugger.Stopped+import GHC.Debugger.Monad+import GHC.Debugger.Utils+import GHC.Debugger.Interface.Messages++--------------------------------------------------------------------------------+-- * Executing commands+--------------------------------------------------------------------------------++-- | Execute the given debugger command in the current 'Debugger' session+execute :: Command -> Debugger Response+execute = \case+ ClearFunctionBreakpoints -> DidClearBreakpoints <$ clearBreakpoints Nothing+ ClearModBreakpoints fp -> DidClearBreakpoints <$ clearBreakpoints (Just fp)+ SetBreakpoint bp -> DidSetBreakpoint <$> setBreakpoint bp BreakpointEnabled+ DelBreakpoint bp -> DidRemoveBreakpoint <$> setBreakpoint bp BreakpointDisabled+ GetBreakpointsAt ModuleBreak{path, lineNum, columnNum} -> do+ mmodl <- getModuleByPath path+ case mmodl of+ Left e -> do+ displayWarnings [e]+ return $ DidGetBreakpoints Nothing+ Right modl -> do+ mbfnd <- getBreakpointsAt modl lineNum columnNum+ return $+ DidGetBreakpoints (realSrcSpanToSourceSpan . snd <$> mbfnd)+ GetBreakpointsAt _ -> error "unexpected getbreakpoints without ModuleBreak"+ GetStacktrace -> GotStacktrace <$> getStacktrace+ GetScopes -> GotScopes <$> getScopes+ GetVariables kind -> GotVariables <$> getVariables kind+ DoEval exp_s -> DidEval <$> doEval exp_s+ DoContinue -> DidContinue <$> doContinue+ DoSingleStep -> DidStep <$> doSingleStep+ DoStepOut -> DidStep <$> doStepOut+ DoStepLocal -> DidStep <$> doLocalStep+ DebugExecution { entryPoint, runArgs } -> DidExec <$> debugExecution entryPoint runArgs+ TerminateProcess -> liftIO $ do+ -- Terminate!+ exitWith ExitSuccess+
+ haskell-debugger/GHC/Debugger/Breakpoint.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+ DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+ TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Breakpoint where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.IORef+import Data.Bits (xor)++import GHC+import GHC.Types.Name.Occurrence (sizeOccEnv)+import GHC.ByteCode.Breakpoints+import GHC.Utils.Error (logOutput)+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Env+import GHC.Driver.Ppr as GHC+import GHC.Runtime.Debugger.Breakpoints as GHC+import GHC.Unit.Module.Env as GHC+import GHC.Utils.Outputable as GHC++import GHC.Debugger.Monad+import GHC.Debugger.Utils+import GHC.Debugger.Interface.Messages++--------------------------------------------------------------------------------+-- * Breakpoints+--------------------------------------------------------------------------------++-- | Remove all module breakpoints set on the given loaded module by path+--+-- If the argument is @Nothing@, clear all function breakpoints instead.+clearBreakpoints :: Maybe FilePath -> Debugger ()+clearBreakpoints mfile = do+ -- It would be simpler to go to all loaded modules and disable all+ -- breakpoints for that module rather than keeping track,+ -- but much less efficient at scale.+ hsc_env <- getSession+ bids <- getActiveBreakpoints mfile+ forM_ bids $ \bid -> do+ GHC.setupBreakpoint (hscInterp hsc_env) bid (breakpointStatusInt BreakpointDisabled)++ -- Clear out the state+ bpsRef <- asks activeBreakpoints+ liftIO $ writeIORef bpsRef emptyModuleEnv++-- | Find a 'BreakpointId' and its span from a module + line + column.+--+-- Used by 'setBreakpoints' and 'GetBreakpointsAt' requests+getBreakpointsAt :: ModSummary {-^ module -} -> Int {-^ line num -} -> Maybe Int {-^ column num -} -> Debugger (Maybe (Int, RealSrcSpan))+getBreakpointsAt modl lineNum columnNum = do+ -- TODO: Cache moduleLineMap.+ mticks <- makeModuleLineMap (ms_mod modl)+ let mbid = do+ ticks <- mticks+ case columnNum of+ Nothing -> findBreakByLine lineNum ticks+ Just col -> findBreakByCoord (lineNum, col) ticks+ return mbid++-- | Set a breakpoint in this session+setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound+setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do+ mmodl <- getModuleByPath path+ case mmodl of+ Left e -> do+ displayWarnings [e]+ return BreakNotFound+ Right modl -> do+ mbid <- getBreakpointsAt modl lineNum columnNum++ case mbid of+ Nothing -> return BreakNotFound+ Just (bix, spn) -> do+ let bid = BreakpointId { bi_tick_mod = ms_mod modl+ , bi_tick_index = bix }+#if MIN_VERSION_ghc(9,14,2)+ (changed, ibis) <- registerBreakpoint bid bp_status ModuleBreakpointKind+#else+ changed <- registerBreakpoint bid bp_status ModuleBreakpointKind+#endif+ return $ BreakFound+ { changed = changed+ , sourceSpan = realSrcSpanToSourceSpan spn+#if MIN_VERSION_ghc(9,14,2)+ , breakId = ibis+#else+ , breakId = bid+#endif+ }+setBreakpoint FunctionBreak{function} bp_status = do+ logger <- getLogger+ resolveFunctionBreakpoint function >>= \case+ Left e -> error (showPprUnsafe e)+ Right (modl, mod_info, fun_str) -> do+ let modBreaks = GHC.modInfoModBreaks mod_info+ applyBreak (bix, spn) = do+ let bid = BreakpointId { bi_tick_mod = modl+ , bi_tick_index = bix }+#if MIN_VERSION_ghc(9,14,2)+ (changed, ibis) <- registerBreakpoint bid bp_status FunctionBreakpointKind+#else+ changed <- registerBreakpoint bid bp_status FunctionBreakpointKind+#endif+ return $ BreakFound+ { changed = changed+ , sourceSpan = realSrcSpanToSourceSpan spn+#if MIN_VERSION_ghc(9,14,2)+ , breakId = ibis+#else+ , breakId = bid+#endif+ }+ case maybe [] (findBreakForBind fun_str . imodBreaks_modBreaks) modBreaks of+ [] -> do+ liftIO $ logOutput logger (text $ "No breakpoint found by name " ++ function ++ ". Ignoring...")+ return BreakNotFound+ [b] -> applyBreak b+ 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+ let ch_opt | BreakpointDisabled <- bp_status+ = gopt_unset+ | otherwise+ = gopt_set+ opt | OnUncaughtExceptionsBreak <- exception_bp+ = Opt_BreakOnError+ | OnExceptionsBreak <- exception_bp+ = Opt_BreakOnException+ dflags <- GHC.getInteractiveDynFlags+ let+ -- changed if option is ON and bp is OFF (breakpoint disabled), or if+ -- option is OFF and bp is ON (i.e. XOR)+ breakOn = bp_status /= BreakpointDisabled+ didChange = gopt opt dflags `xor` breakOn+ GHC.setInteractiveDynFlags $ dflags `ch_opt` opt+ return (BreakFoundNoLoc didChange)
+ haskell-debugger/GHC/Debugger/Evaluation.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+ DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+ TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Evaluation where++import Control.Monad.IO.Class+import Control.Monad.Catch+import Data.Maybe++import GHC+import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)+import GHC.Data.FastString+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Env as GHC+import GHC.Driver.Monad+import GHC.Runtime.Debugger.Breakpoints as GHC+import GHC.ByteCode.Breakpoints+import GHC.Types.Name.Occurrence (mkVarOccFS)+import GHC.Types.Name.Reader as RdrName (mkOrig)+import GHC.Utils.Outputable as GHC+import qualified GHCi.Message as GHCi+import qualified GHC.Data.Strict as Strict++import GHC.Debugger.Stopped.Variables+import GHC.Debugger.Monad+import GHC.Debugger.Utils+import GHC.Debugger.Interface.Messages++--------------------------------------------------------------------------------+-- * Evaluation+--------------------------------------------------------------------------------++-- | Run a program with debugging enabled+debugExecution :: EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult+debugExecution entry args = do++ -- consider always using :trace like ghci-dap to always have a stacktrace?+ -- better solution could involve profiling stack traces or from IPE info?++ (entryExp, exOpts) <- case entry of++ MainEntry nm -> do+ let prog = fromMaybe "main" nm+ -- the wrapper is equivalent to GHCi's `:main arg1 arg2 arg3`+ wrapper <- mkEvalWrapper prog args -- bit weird that the prog name is the expression but fine+ let execWrap' fhv = GHCi.EvalApp (GHCi.EvalThis wrapper) (GHCi.EvalThis fhv)+ opts = GHC.execOptions {execWrap = execWrap'}+ return (prog, opts)++ FunctionEntry fn ->+ -- TODO: if "args" is unescaped (e.g. "some", "thing"), then "some" and+ -- "thing" will be interpreted as variables. To pass strings it needs to+ -- be "\"some\"" "\"things\"".+ return (fn ++ " " ++ unwords args, GHC.execOptions)++ GHC.execStmt entryExp exOpts >>= handleExecResult++ where+ -- It's not ideal to duplicate these two functions from ghci, but its unclear where they would better live. Perhaps next to compileParsedExprRemote? The issue is run+ mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue+ mkEvalWrapper progname' args' =+ runInternal $ GHC.compileParsedExprRemote+ $ evalWrapper' `GHC.mkHsApp` nlHsString progname'+ `GHC.mkHsApp` nlList (map nlHsString args')+ where+ nlHsString = nlHsLit . mkHsString+ evalWrapper' =+ GHC.nlHsVar $ RdrName.mkOrig gHC_INTERNAL_GHCI_HELPERS (mkVarOccFS (fsLit "evalWrapper"))++ -- run internal here serves to overwrite certain flags while executing the+ -- internal "evalWrapper" computation which is not relevant to the user.+ runInternal :: GhcMonad m => m a -> m a+ runInternal =+ withTempSession mkTempSession+ where+ mkTempSession = hscUpdateFlags (\dflags -> dflags+ { -- Disable dumping of any data during evaluation of GHCi's internal expressions. (#17500)+ dumpFlags = mempty+ }+ -- We depend on -fimplicit-import-qualified to compile expr+ -- with fully qualified names without imports (gHC_INTERNAL_GHCI_HELPERS above).+ `gopt_set` Opt_ImplicitImportQualified+ )+++-- | Resume execution of the stopped debuggee program+doContinue :: Debugger EvalResult+doContinue = do+ leaveSuspendedState+ GHC.resumeExec RunToCompletion Nothing+ >>= handleExecResult++-- | Resume execution but only take a single step.+doSingleStep :: Debugger EvalResult+doSingleStep = do+ leaveSuspendedState+ GHC.resumeExec SingleStep Nothing+ >>= handleExecResult++doStepOut :: Debugger EvalResult+doStepOut = do+ leaveSuspendedState+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing ->+ GHC.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+ >>= handleExecResult++-- | Resume execution but stop at the next tick within the same function.+--+-- To do a local step, we get the SrcSpan of the current suspension state and+-- get its 'enclosingTickSpan' to use as a filter for breakpoints in the call+-- to 'resumeExec'. Execution will only stop at breakpoints whose span matches+-- this enclosing span.+doLocalStep :: Debugger EvalResult+doLocalStep = do+ leaveSuspendedState+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> error "not stopped at a breakpoint?!"+ Just (UnhelpfulSpan _) -> do+ liftIO $ putStrLn "Stopped at an exception. Forcing step into..."+ GHC.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++-- | 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))+ case excr of+ Left err -> pure $ EvalAbortedWith err+ Right ExecBreak{} -> continueToCompletion >>= handleExecResult+ Right r@ExecComplete{} -> handleExecResult r++-- | 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 "" "") -- Evaluation completed without binding any result.+ Right (n:_ns) -> inspectName n >>= \case+ Just VarInfo{varValue, varType} -> return (EvalCompleted varValue varType)+ Nothing -> liftIO $ fail "doEval failed"+ ExecBreak {breakNames = _, breakPointId = Nothing} ->+ -- Stopped at an exception+ -- TODO: force the exception to display string with Backtrace?+ return EvalStopped{breakId = Nothing}+ ExecBreak {breakNames = _, breakPointId} ->+#if MIN_VERSION_ghc(9,14,2)+ return EvalStopped{breakId = breakPointId}+#else+ return EvalStopped{breakId = toBreakpointId <$> breakPointId}+#endif++-- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'.+inspectName :: Name -> Debugger (Maybe VarInfo)+inspectName n = do+ GHC.lookupName n >>= \case+ Nothing -> do+ liftIO . putStrLn =<< display (text "Failed to lookup name: " <+> ppr n)+ pure Nothing+ Just tt -> Just <$> tyThingToVarInfo tt+
+ haskell-debugger/GHC/Debugger/Interface/Messages.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE DeriveGeneric,+ StandaloneDeriving,+ OverloadedStrings,+ DuplicateRecordFields,+ TypeApplications+ #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- JSON GHC.BreakpointId++-- | Types for sending and receiving messages to/from haskell-debugger+module GHC.Debugger.Interface.Messages where++import GHC.Generics+import Data.Aeson+import qualified GHC+import qualified GHC.Utils.Outputable as GHC+import GHC.Unit.Types+import Language.Haskell.Syntax.Module.Name++--------------------------------------------------------------------------------+-- Commands+--------------------------------------------------------------------------------++-- | The commands sent to ghc debugger+data Command++ -- | Set a breakpoint on a given function, or module by line number+ = SetBreakpoint Breakpoint++ -- | Delete a breakpoint on a given function, or module by line number+ | DelBreakpoint Breakpoint++ -- | Find the valid breakpoints locations for the given module Breakpoint+ | GetBreakpointsAt Breakpoint++ -- | Clear all breakpoints in the specified file.+ -- This is useful because DAP's `setBreakpoints` re-sets all breakpoints from zero for a source rather than incrementally.+ | ClearModBreakpoints { file :: FilePath }++ -- | Clear all function breakpoints+ | ClearFunctionBreakpoints++ -- | Get the evaluation stacktrace until the current breakpoint.+ | GetStacktrace++ -- | Get the list of available scopes at the current breakpoint+ | GetScopes++ -- | Get the variables in scope for the current breakpoint.+ --+ -- Note: for GHCs <9.16 this only reports the variables free in the expression+ -- we're stopped at rather than all variables in scope.+ | GetVariables VariableReference++ -- | Evaluate an expression at the current breakpoint.+ | DoEval String++ -- | Continue executing from the current breakpoint+ | DoContinue++ -- | Step local, which executes until next breakpoint in the same function.+ | DoStepLocal++ -- | Single step always to the next breakpoint. Used for "step-in".+ | DoSingleStep++ -- | Step out to the breakpoint immediately following a return.+ | DoStepOut++ -- | Execute a prog with debugging enabled. Breaks on the existing breakpoints.+ --+ -- Constructed with an entry point function name and the arguments to pass it.+ --+ -- When the @'EntryPoint'@ is @'Main'@, @'runArgs'@ are set as process+ -- invocation arguments (as in @argv@) rather than passed directly as a+ -- Haskell function arguments.+ | DebugExecution { entryPoint :: EntryPoint, 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, Generic)++-- | A breakpoint can be set/removed on functions by name, or in modules by+-- line number. And, globally, for all exceptions, or just uncaught exceptions.+data Breakpoint+ = ModuleBreak { path :: FilePath, lineNum :: Int, columnNum :: Maybe Int }+ | FunctionBreak { function :: String }+ | OnExceptionsBreak+ | OnUncaughtExceptionsBreak+ deriving (Show, Generic)++-- | Information about a scope+data ScopeInfo = ScopeInfo+ { kind :: ScopeVariablesReference+ , sourceSpan :: SourceSpan+ , numVars :: Maybe Int+ , expensive :: Bool }+ deriving (Show, Generic)++data VarFields = LabeledFields [VarInfo]+ | IndexedFields [VarInfo]+ | NoFields+ deriving (Show, Generic, Eq)++-- | Information about a variable+data VarInfo = VarInfo+ { varName :: String+ , varType :: String+ , varValue :: String+ , isThunk :: Bool+ , varRef :: VariableReference+ -- ^ A reference back to this variable++ -- TODO:+ -- memory reference using ghc-debug.+ }+ deriving (Show, Generic, Eq)++-- | What kind of breakpoint are we referring to, module or function breakpoints?+-- Used e.g. in the 'ClearBreakpoints' request+data BreakpointKind+ -- | Module breakpoints+ = ModuleBreakpointKind+ -- | Function breakpoints+ | FunctionBreakpointKind+ deriving (Show, Generic, Eq)++-- | Referring to existing scopes+data ScopeVariablesReference+ = LocalVariablesScope+ | ModuleVariablesScope+ | GlobalVariablesScope+ deriving (Show, Generic, Eq, Ord)++-- | The type of variables referenced, or a particular variable referenced for its fields or value (when inspecting a thunk)+data VariableReference+ -- | A void reference to nothing at all. Used e.g. for ty cons and data cons+ = NoVariables++ -- | Variables in the local context (includes arguments, previous bindings)+ | LocalVariables++ -- | Variables in the module where we're stopped+ | ModuleVariables++ -- | Variables in the global context+ | GlobalVariables++ -- | A reference to a specific variable.+ -- Used to force its result or get its structured children+ | SpecificVariable Int++ deriving (Show, Generic, Eq, Ord)++instance Bounded VariableReference where+ minBound = NoVariables+ maxBound = SpecificVariable maxBound++instance Enum VariableReference where+ toEnum 0 = NoVariables+ toEnum 1 = LocalVariables+ toEnum 2 = ModuleVariables+ toEnum 3 = GlobalVariables+ toEnum n = SpecificVariable (n - 4)++ fromEnum NoVariables = 0+ fromEnum LocalVariables = 1+ fromEnum ModuleVariables = 2+ fromEnum GlobalVariables = 3+ fromEnum (SpecificVariable n) = 4 + n++-- | A source span type for the interface. Like 'RealSrcSpan'.+data SourceSpan = SourceSpan+ { file :: !FilePath+ -- ^ Path to file where this span is located+ , startLine :: {-# UNPACK #-} !Int+ -- ^ RealSrcSpan start line+ , endLine :: {-# UNPACK #-} !Int+ -- ^ RealSrcSpan end line+ , startCol :: {-# UNPACK #-} !Int+ -- ^ RealSrcSpan start col+ , endCol :: {-# UNPACK #-} !Int+ -- ^ RealSrcSpan end col+ }+ deriving (Show, Generic)++--------------------------------------------------------------------------------+-- Responses+--------------------------------------------------------------------------------++-- | The responses sent by `haskell-debugger` to the client+data Response+ = DidEval EvalResult+ | DidSetBreakpoint BreakFound+ | DidRemoveBreakpoint BreakFound+ | DidGetBreakpoints (Maybe SourceSpan)+ | DidClearBreakpoints+ | DidContinue EvalResult+ | DidStep EvalResult+ | DidExec EvalResult+ | GotStacktrace [StackFrame]+ | GotScopes [ScopeInfo]+ | GotVariables (Either VarInfo [VarInfo])+ | Aborted String+ | Initialised++data BreakFound+ = BreakFound+ { changed :: !Bool+ -- ^ Did the status of the found breakpoint change?+#if MIN_VERSION_ghc(9,14,2)+ , breakId :: [GHC.InternalBreakpointId]+#else+ , breakId :: GHC.BreakpointId+#endif+ -- ^ Internal breakpoint identifier (module + ix) (TODO: Don't expose GHC)+ , sourceSpan :: SourceSpan+ -- ^ Source span for interface+ }+ -- | Breakpoint found but without location info.+ -- This happens when setting breakpoints on exceptions.+ | BreakFoundNoLoc+ { changed :: Bool }+ -- | No breakpoints found+ | BreakNotFound+ -- | Found many breakpoints.+ -- Caused by setting breakpoint on a name with multiple matches or many equations.+ | ManyBreaksFound [BreakFound]+ deriving (Show, Generic)++data EvalResult+ = EvalCompleted { resultVal :: String, resultType :: String }+ | EvalException { resultVal :: String, resultType :: String }+#if MIN_VERSION_ghc(9,14,2)+ | EvalStopped { breakId :: Maybe GHC.InternalBreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} }+#else+ | EvalStopped { breakId :: Maybe GHC.BreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} }+#endif+ -- | Evaluation failed for some reason other than completed/completed-with-exception/stopped.+ | EvalAbortedWith String+ deriving (Show, Generic)++data StackFrame+ = StackFrame+ { name :: String+ -- ^ Title of stack frame+ , sourceSpan :: SourceSpan+ -- ^ Source span for this stack frame+ }+ deriving (Show, Generic)++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++deriving instance Show Command+deriving instance Generic Command++deriving instance Show Response+deriving instance Generic Response++instance ToJSON Command where toEncoding = genericToEncoding defaultOptions+instance ToJSON Breakpoint where toEncoding = genericToEncoding defaultOptions+instance ToJSON BreakpointKind where toEncoding = genericToEncoding defaultOptions+instance ToJSON ScopeVariablesReference where toEncoding = genericToEncoding defaultOptions+instance ToJSON VariableReference where toEncoding = genericToEncoding defaultOptions+instance ToJSON Response where toEncoding = genericToEncoding defaultOptions+instance ToJSON EvalResult where toEncoding = genericToEncoding defaultOptions+instance ToJSON BreakFound where toEncoding = genericToEncoding defaultOptions+instance ToJSON SourceSpan where toEncoding = genericToEncoding defaultOptions+instance ToJSON EntryPoint where toEncoding = genericToEncoding defaultOptions+instance ToJSON StackFrame where toEncoding = genericToEncoding defaultOptions+instance ToJSON ScopeInfo where toEncoding = genericToEncoding defaultOptions+instance ToJSON VarInfo where toEncoding = genericToEncoding defaultOptions+instance ToJSON VarFields where toEncoding = genericToEncoding defaultOptions++instance FromJSON Command+instance FromJSON Breakpoint+instance FromJSON BreakpointKind+instance FromJSON ScopeVariablesReference+instance FromJSON VariableReference+instance FromJSON Response+instance FromJSON EvalResult+instance FromJSON BreakFound+instance FromJSON SourceSpan+instance FromJSON EntryPoint+instance FromJSON StackFrame+instance FromJSON ScopeInfo+instance FromJSON VarInfo+instance FromJSON VarFields++#if MIN_VERSION_ghc(9,14,2)++instance Show GHC.InternalBreakpointId where+ show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix++instance ToJSON GHC.InternalBreakpointId where+ toJSON (GHC.InternalBreakpointId (Module unit mn) ix) =+ object [ "module_name" .= moduleNameString mn+ , "module_unit" .= unitString unit+ , "ix" .= ix+ ]+instance FromJSON GHC.InternalBreakpointId where+ parseJSON = withObject "InternalBreakpointId" $ \v -> GHC.InternalBreakpointId+ <$> (Module <$> (stringToUnit <$> v .: "module_unit") <*> (mkModuleName <$> v .: "module_name"))+ <*> v .: "ix"+#else++instance Show GHC.BreakpointId where+ show (GHC.BreakpointId m ix) = "BreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix++instance ToJSON GHC.BreakpointId where+ toJSON (GHC.BreakpointId (Module unit mn) ix) =+ object [ "module_name" .= moduleNameString mn+ , "module_unit" .= unitString unit+ , "ix" .= ix+ ]+instance FromJSON GHC.BreakpointId where+ parseJSON = withObject "BreakpointId" $ \v -> GHC.BreakpointId+ <$> (Module <$> (stringToUnit <$> v .: "module_unit") <*> (mkModuleName <$> v .: "module_name"))+ <*> v .: "ix"++#endif
+ haskell-debugger/GHC/Debugger/Monad.hs view
@@ -0,0 +1,463 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++module GHC.Debugger.Monad where++import Prelude hiding (mod)+import Data.Function+import System.Exit+import System.IO+import System.FilePath (normalise)+import System.Directory (makeAbsolute)+import Control.Monad+import Control.Monad.IO.Class+import Control.Exception (assert)++import Control.Monad.Catch++import GHC+import qualified GHCi.BreakArray as BA+import GHC.Driver.DynFlags as GHC+import GHC.Unit.Module.ModSummary as GHC+import GHC.Utils.Outputable as GHC+import GHC.Utils.Logger as GHC+import GHC.Types.Unique.Supply as GHC+import GHC.Runtime.Loader as GHC+import GHC.Runtime.Interpreter as GHCi+import GHC.Runtime.Heap.Inspect+import GHC.Unit.Module.Env as GHC+import GHC.Runtime.Debugger.Breakpoints+import GHC.Driver.Env++import Data.IORef+import Data.Maybe+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.IntMap as IM++import Control.Monad.Reader++import GHC.Debugger.Interface.Messages+import GHC.Debugger.Runtime.Term.Key+import GHC.Debugger.Runtime.Term.Cache+import GHC.Debugger.Session+import System.Posix.Signals++-- | A debugger action.+newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a }+ deriving ( Functor, Applicative, Monad, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , GHC.HasDynFlags, MonadReader DebuggerState )++-- | State required to run the debugger.+--+-- - Keep track of active breakpoints to easily unset them all.+data DebuggerState = DebuggerState+ { activeBreakpoints :: IORef (ModuleEnv (IM.IntMap (BreakpointStatus, BreakpointKind)))+ -- ^ Maps a 'BreakpointId' in Trie representation to the+ -- 'BreakpointStatus' it was activated with.++ , varReferences :: IORef (IM.IntMap TermKey, TermKeyMap Int)+ -- ^ When we're stopped at a breakpoint, this maps variable reference to+ -- Terms to allow further inspection and forcing by reference.+ --+ -- This map is only valid while stopped in this context. After stepping+ -- or resuming evaluation in any available way, this map becomes invalid+ -- and should therefore be cleaned.+ --+ -- The TermKeyMap map is a reverse lookup map to find which references+ -- already exist for given names++ , termCache :: IORef TermCache+ -- ^ TermCache++ , genUniq :: IORef Int+ -- ^ Generates unique ints+ }++-- | Enabling/Disabling a breakpoint+data BreakpointStatus+ -- | Breakpoint is disabled+ --+ -- Note: this must be the first constructor s.t.+ -- @BreakpointDisabled < {BreakpointEnabled, BreakpointAfterCount}@+ = BreakpointDisabled+ -- | Breakpoint is enabled+ | BreakpointEnabled+ -- | Breakpoint is disabled the first N times and enabled afterwards+ | BreakpointAfterCount Int+ deriving (Eq, Ord)++--------------------------------------------------------------------------------+-- Operations+--------------------------------------------------------------------------------++-- | Additional settings configuring the debugger+data RunDebuggerSettings = RunDebuggerSettings+ { supportsANSIStyling :: Bool+ , supportsANSIHyperlinks :: Bool+ }++-- | Run a 'Debugger' action on a session constructed from a given GHC invocation.+runDebugger :: Handle -- ^ The handle to which GHC's output is logged. The debuggee output is not affected by this parameter.+ -> FilePath -- ^ Cradle root directory+ -> FilePath -- ^ Component root directory+ -> FilePath -- ^ The libdir (given with -B as an arg)+ -> [String] -- ^ The list of units included in the invocation+ -> [String] -- ^ The full ghc invocation (as constructed by hie-bios flags)+ -> FilePath -- ^ Path to the main function+ -> RunDebuggerSettings -- ^ Other debugger run settings+ -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation+ -> IO a+runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Debugger action) = do+ let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation'+ GHC.runGhc (Just libdir) $ do+ -- Workaround #4162+ _ <- liftIO $ installHandler sigINT Default Nothing+ dflags0 <- GHC.getSessionDynFlags+ let dflags1 = dflags0+ { GHC.ghcMode = GHC.CompManager+ , GHC.ghcLink = GHC.LinkInMemory+ , GHC.verbosity = 1+ , GHC.canUseColor = conf.supportsANSIStyling+ , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks+ }+ -- Default GHCi settings+ `GHC.gopt_set` GHC.Opt_ImplicitImportQualified+ `GHC.gopt_set` GHC.Opt_IgnoreOptimChanges+ `GHC.gopt_set` GHC.Opt_IgnoreHpcChanges+ `GHC.gopt_set` GHC.Opt_UseBytecodeRatherThanObjects+ `GHC.gopt_set` GHC.Opt_InsertBreakpoints+ & setBytecodeBackend+ & enableByteCodeGeneration++ GHC.modifyLogger $+ -- Override the logger to output to the given handle+ GHC.pushLogHook (const $ debuggerLoggerAction dbg_out)++ -- TODO: this is weird, we set the session dynflags now to initialise+ -- the hsc_interp.+ -- This is incredibly dubious+ _ <- GHC.setSessionDynFlags dflags1++ -- Initialise plugins here because the plugin author might already expect this+ -- subsequent call to `getLogger` to be affected by a plugin.+ GHC.initializeSessionPlugins++ flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags1 rootDir+ setupHomeUnitGraph (NonEmpty.toList flagsAndTargets)++ dflags6 <- GHC.getSessionDynFlags++ -- Should this be done in GHC=+ liftIO $ GHC.initUniqSupply (GHC.initialUnique dflags6) (GHC.uniqueIncrement dflags6)++ ok_flag <- GHC.load GHC.LoadAllTargets+ when (GHC.failed ok_flag) (liftIO $ exitWith (ExitFailure 1))++ -- TODO: Shouldn't initLoaderState be called somewhere?++ -- Set interactive context to import all loaded modules+ -- TODO: Think about Note [GHCi and local Preludes] and what is done in `getImplicitPreludeImports`+ let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude"+ mss <- getAllLoadedModules+ GHC.setContext $ preludeImp : map (GHC.IIModule . GHC.ms_mod) mss++ runReaderT action =<< initialDebuggerState+++-- | The logger action used to log GHC output+debuggerLoggerAction :: Handle -> LogAction+debuggerLoggerAction h a b c d = do+ hSetEncoding h utf8 -- GHC output uses utf8+ defaultLogActionWithHandles h h a b c d++-- | Registers or deletes a breakpoint in the GHC session and from the list of+-- active breakpoints that is kept in 'DebuggerState', depending on the+-- 'BreakpointStatus' being set.+--+-- Returns @True@ when the breakpoint status is changed.+#if MIN_VERSION_ghc(9,14,2)+registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger (Bool, [GHC.InternalBreakpointId])+#else+registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool+#endif+registerBreakpoint bp@GHC.BreakpointId+ { GHC.bi_tick_mod = mod+ , GHC.bi_tick_index = bid } status kind = do++ -- Set breakpoint in GHC session+ let breakpoint_count = breakpointStatusInt status+ hsc_env <- GHC.getSession+#if MIN_VERSION_ghc(9,14,2)+ internal_break_ids <- getInternalBreaksOf bp+ forM_ internal_break_ids $ \ibi -> do+ GHC.setupBreakpoint (hscInterp hsc_env) ibi breakpoint_count+#else+ GHC.setupBreakpoint (hscInterp hsc_env) bp breakpoint_count+#endif++ -- Register breakpoint in Debugger state+ brksRef <- asks activeBreakpoints+ oldBrks <- liftIO $ readIORef brksRef+ let+ (newBrks, changed) = case status of+ -- Disabling the breakpoint; using the `Maybe` monad:+ -- * If we reach the return stmt then the breakpoint is active and we delete it.+ -- * Any other case, return False and change Nothing+ BreakpointDisabled -> fromMaybe (oldBrks, False) $ do+ im <- lookupModuleEnv oldBrks mod+ _status <- IM.lookup bid im+ let im' = IM.delete bid im+ brks = extendModuleEnv oldBrks mod im'+ return (brks, True)++ -- We're enabling the breakpoint:+ _ -> case lookupModuleEnv oldBrks mod of+ Nothing ->+ let im = IM.singleton bid (status, kind)+ brks = extendModuleEnv oldBrks mod im+ in (brks, True)+ Just im -> case IM.lookup bid im of+ Nothing ->+ -- Not yet in IntMap, extend with new Breakpoint+ let im' = IM.insert bid (status, kind) im+ brks = extendModuleEnv oldBrks mod im'+ in (brks, True)+ Just (status', _kind) ->+ -- Found in IntMap+ if status' == status then+ (oldBrks, False)+ else+ let im' = IM.insert bid (status, kind) im+ brks = extendModuleEnv oldBrks mod im'+ in (brks, True)++ -- no races since the debugger execution is run in a single thread+ liftIO $ writeIORef brksRef newBrks+#if MIN_VERSION_ghc(9,14,2)+ return (changed, internal_break_ids)+#else+ return changed+#endif+++-- | Get a list with all currently active breakpoints on the given module (by path)+--+-- If the path argument is @Nothing@, get all active function breakpoints instead+#if MIN_VERSION_ghc(9,14,2)+getActiveBreakpoints :: Maybe FilePath -> Debugger [GHC.InternalBreakpointId]+#else+getActiveBreakpoints :: Maybe FilePath -> Debugger [GHC.BreakpointId]+#endif+getActiveBreakpoints mfile = do+ m <- asks activeBreakpoints >>= liftIO . readIORef+ case mfile of+ Just file -> do+ mms <- getModuleByPath file+ case mms of+ Right ms ->+#if MIN_VERSION_ghc(9,14,2)+ concat <$> mapM getInternalBreaksOf+#else+ return+#endif+ [ GHC.BreakpointId mod bix+ | (mod, im) <- moduleEnvToList m+ , mod == ms_mod ms+ , bix <- IM.keys im+ -- assert: status is always > disabled+ ]+ Left e -> do+ displayWarnings [e]+ return []+ Nothing -> do+#if MIN_VERSION_ghc(9,14,2)+ concat <$> mapM getInternalBreaksOf+#else+ return+#endif+ [ GHC.BreakpointId mod bix+ | (mod, im) <- moduleEnvToList m+ , (bix, (status, kind)) <- IM.assocs im++ -- Keep only function breakpoints in this case+ , FunctionBreakpointKind == kind++ , assert (status > BreakpointDisabled) True+ ]++-- | List all loaded modules 'ModSummary's+getAllLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getAllLoadedModules =+ (GHC.mgModSummaries <$> GHC.getModuleGraph) >>=+ filterM (\ms -> GHC.isLoadedModule (GHC.ms_unitid ms) (GHC.ms_mod_name ms))++-- | Get a 'ModSummary' of a loaded module given its 'FilePath'+getModuleByPath :: FilePath -> Debugger (Either String ModSummary)+getModuleByPath path = do+ -- do this every time as the loaded modules may have changed+ lms <- getAllLoadedModules+ absPath <- liftIO $ makeAbsolute path+ let matches ms = normalise (msHsFilePath ms) == normalise absPath+ return $ case filter matches lms of+ [x] -> Right x+ [] -> Left $ "No module matched " ++ path ++ ".\nLoaded modules:\n" ++ show (map msHsFilePath lms) ++ "\n. Perhaps you've set a breakpoint on a module that isn't loaded into the session?"+ xs -> Left $ "Too many modules (" ++ showPprUnsafe xs ++ ") matched " ++ path ++ ". Please report a bug at https://github.com/well-typed/haskell-debugger."++--------------------------------------------------------------------------------+-- Variable references+--------------------------------------------------------------------------------++-- | Find a variable's associated Term and Name by reference ('Int')+lookupVarByReference :: Int -> Debugger (Maybe TermKey)+lookupVarByReference i = do+ ioref <- asks varReferences+ (rm, _) <- readIORef ioref & liftIO+ return $ IM.lookup i rm++-- | Finds or creates an integer var reference for the given 'TermKey'.+-- TODO: Arguably, this mapping should be part of the debug-adapter, and+-- haskell-debugger should deal in 'TermKey' terms only.+getVarReference :: TermKey -> Debugger Int+getVarReference key = do+ ioref <- asks varReferences+ (rm, tkm) <- readIORef ioref & liftIO+ (i, tkm') <- case lookupTermKeyMap key tkm of+ Nothing -> do+ new_i <- freshInt+ return (new_i, insertTermKeyMap key new_i tkm)+ Just existing_i ->+ return (existing_i, tkm)+ let rm' = IM.insert i key rm+ writeIORef ioref (rm', tkm') & liftIO+ return i++-- | Whenever we run a request that continues execution from the current+-- suspended state, such as Next,Step,Continue, this function should be called+-- to delete the variable references that become invalid as we leave the+-- suspended state.+--+-- In particular, @'varReferences'@ is reset.+--+-- See also section "Lifetime of Objects References" in the DAP specification.+leaveSuspendedState :: Debugger ()+leaveSuspendedState = do+ ioref <- asks varReferences+ liftIO $ writeIORef ioref mempty++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++defaultDepth :: Int+defaultDepth = 2 -- the depth determines how much of the runtime structure is traversed.+ -- @obtainTerm@ and friends handle fetching arbitrarily nested data structures+ -- so we only depth enough to get to the next level of subterms.++-- | Evaluate a suspended Term to WHNF.+--+-- Used in @'getVariables'@ to reply to a variable introspection request.+seqTerm :: Term -> Debugger Term+seqTerm term = do+ hsc_env <- GHC.getSession+ let+ interp = hscInterp hsc_env+ unit_env = hsc_unit_env hsc_env+ case term of+ Suspension{val, ty} -> liftIO $ do+ r <- GHCi.seqHValue interp unit_env val+ () <- fromEvalResult r+ let+ forceThunks = False {- whether to force the thunk subterms -}+ forceDepth = defaultDepth+ cvObtainTerm hsc_env forceDepth forceThunks ty val+ NewtypeWrap{wrapped_term} -> do+ wrapped_term' <- seqTerm wrapped_term+ return term{wrapped_term=wrapped_term'}+ _ -> return term++-- | Evaluate a Term to NF+deepseqTerm :: Term -> Debugger Term+deepseqTerm t = case t of+ Suspension{} -> do t' <- seqTerm t+ deepseqTerm t'+ Term{subTerms} -> do subTerms' <- mapM deepseqTerm subTerms+ return t{subTerms = subTerms'}+ NewtypeWrap{wrapped_term}+ -> do wrapped_term' <- deepseqTerm wrapped_term+ return t{wrapped_term = wrapped_term'}+ _ -> do seqTerm t+++-- | 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+ case execr of+ GHC.ExecBreak{} -> continueToCompletion+ GHC.ExecComplete{} -> return execr++-- | Turn a 'BreakpointStatus' into its 'Int' representation for 'BreakArray'+breakpointStatusInt :: BreakpointStatus -> Int+breakpointStatusInt = \case+ BreakpointEnabled -> BA.breakOn -- 0+ BreakpointDisabled -> BA.breakOff -- -1+ BreakpointAfterCount n -> n -- n++-- | Generate a new unique 'Int'+freshInt :: Debugger Int+freshInt = do+ ioref <- asks genUniq+ i <- readIORef ioref & liftIO+ let !i' = i+1+ writeIORef ioref i' & liftIO+ return i++-- | Initialize a 'DebuggerState'+initialDebuggerState :: GHC.Ghc DebuggerState+initialDebuggerState = DebuggerState <$> liftIO (newIORef emptyModuleEnv)+ <*> liftIO (newIORef mempty)+ <*> liftIO (newIORef mempty)+ <*> liftIO (newIORef 0)++-- | Lift a 'Ghc' action into a 'Debugger' one.+liftGhc :: GHC.Ghc a -> Debugger a+liftGhc = Debugger . ReaderT . const++--------------------------------------------------------------------------------++type Warning = String++displayWarnings :: [Warning] -> Debugger ()+displayWarnings = liftIO . putStrLn . unlines++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++instance GHC.HasLogger Debugger where+ getLogger = liftGhc GHC.getLogger++instance GHC.GhcMonad Debugger where+ getSession = liftGhc GHC.getSession+ setSession s = liftGhc $ GHC.setSession s++--------------------------------------------------------------------------------++#if MIN_VERSION_ghc(9,14,2)+-- | Find all the internal breakpoints that use the given source-level breakpoint id+getInternalBreaksOf :: BreakpointId -> Debugger [InternalBreakpointId]+getInternalBreaksOf bi = do+ bs <- mkBreakpointOccurrences+ return $+ fromMaybe [] {- still not found after refresh -} $+ lookupBreakpointOccurrences bs bi+#endif
+ haskell-debugger/GHC/Debugger/Runtime.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE GADTs, LambdaCase, NamedFieldPuns #-}+module GHC.Debugger.Runtime where++import Data.IORef+import Control.Monad.Reader+import qualified Data.List as L++import GHC+import GHC.Types.FieldLabel+import GHC.Tc.Utils.TcType+import GHC.Runtime.Eval++import GHC.Debugger.Runtime.Term.Key+import GHC.Debugger.Runtime.Term.Cache+import GHC.Debugger.Monad++-- | Obtain the runtime 'Term' from a 'TermKey'.+--+-- The 'TermKey' will be looked up in the 'TermCache' to avoid recomputing the+-- 'Term' if possible. On a cache miss the Term will be reconstructed from+-- scratch and stored in the cache.+obtainTerm :: TermKey -> Debugger Term+obtainTerm key = do+ tc_ref <- asks termCache+ tc <- liftIO $ readIORef tc_ref+ case lookupTermCache key tc of+ -- cache miss: reconstruct, then store.+ Nothing ->+ let+ -- For boring types we want to get the value as it is (by traversing it to+ -- the end), rather than stopping short and returning a suspension (e.g.+ -- for the string tail), because boring types are printed whole rather than+ -- being represented by an expandable structure.+ depth i = if isBoringTy (GHC.idType i) then maxBound else defaultDepth++ -- Recursively get terms until we hit the desired key.+ getTerm = \case+ FromId i -> GHC.obtainTermFromId (depth i) False{-don't force-} i+ FromPath k pf -> do+ term <- getTerm k >>= \case+ -- When the key points to a Suspension, the real thing should+ -- already be forced. It's just that the shallow depth meant we+ -- returned a Suspension nonetheless while recursing in `getTerm`.+ t@Suspension{} -> do+ t' <- seqTerm t+ -- update term cache with intermediate values?+ -- insertTermCache k t'+ return t'+ t -> return t+ return $ case term of+ Term{dc=Right dc, subTerms} -> case pf of+ PositionalIndex ix -> subTerms !! (ix-1)+ LabeledField fl ->+ case L.findIndex (== fl) (map flSelector $ dataConFieldLabels dc) of+ Just ix -> subTerms !! ix+ Nothing -> error "Couldn't find labeled field in dataConFieldLabels"+ NewtypeWrap{wrapped_term} ->+ wrapped_term -- regardless of PathFragment+ _ -> error "Unexpected term for the given TermKey"+ in do+ term <- getTerm key+ liftIO $ writeIORef tc_ref (insertTermCache key term tc)+ return term++ -- cache hit+ Just hit -> return hit++-- | A boring type is one for which we don't care about the structure and would+-- rather see "whole" when being inspected. Strings and literals are a good+-- example, because it's more useful to see the string value than it is to see+-- a linked list of characters where each has to be forced individually.+isBoringTy :: Type -> Bool+isBoringTy t = isDoubleTy t || isFloatTy t || isIntTy t || isWordTy t || isStringTy t+ || isIntegerTy t || isNaturalTy t || isCharTy t++
+ haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE GADTs #-}+module GHC.Debugger.Runtime.Term.Cache where++import GHC.Runtime.Eval+import GHC.Types.Var.Env++import GHC.Debugger.Runtime.Term.Key++import Data.Map (Map)+import qualified Data.Map as M++--------------------------------------------------------------------------------+-- * Term Cache+--------------------------------------------------------------------------------++-- | A term cache maps Names to Terms.+--+-- We use the term cache to avoid redundant computation forcing (unique) names+-- we've already forced before.+--+-- A kind of trie map from 'TermKey's. The Map entry for no-path-fragments is+-- the 'Term' of the original 'Id'.+type TermCache = TermKeyMap Term++-- | Lookup a 'TermKey' in a 'TermCache'.+-- Returns @Nothing@ for a cache miss and @Just@ otherwise.+lookupTermCache :: TermKey -> TermCache -> Maybe Term+lookupTermCache = lookupTermKeyMap++-- | Inserts a 'Term' for the given 'TermKey' in the 'TermCache'.+--+-- Overwrites existing values.+insertTermCache :: TermKey -> Term -> TermCache -> TermCache+insertTermCache = insertTermKeyMap++--------------------------------------------------------------------------------+-- * TermKeyMap+--------------------------------------------------------------------------------++-- | Mapping from 'TermKey' to @a@. Backs 'TermCache', but is more general.+type TermKeyMap a = IdEnv (Map [PathFragment] a)++-- | Lookup a 'TermKey' in a 'TermKeyMap'.+lookupTermKeyMap :: TermKey -> TermKeyMap a -> Maybe a+lookupTermKeyMap key tc = do+ let (i, path) = unconsTermKey key+ path_map <- lookupVarEnv tc i+ M.lookup path path_map++-- | Inserts a 'Term' for the given 'TermKey' in the 'TermKeyMap'.+--+-- Overwrites existing values.+insertTermKeyMap :: TermKey -> a -> TermKeyMap a -> TermKeyMap a+insertTermKeyMap key term tc =+ let+ (i, path) = unconsTermKey key+ new_map = case lookupVarEnv tc i of+ Nothing -> M.singleton path term+ Just existing_map -> M.insert path term existing_map+ in extendVarEnv tc i new_map
+ haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GADTs, ViewPatterns #-}+module GHC.Debugger.Runtime.Term.Key where++import Prelude hiding ((<>))++import GHC+import GHC.Utils.Outputable++-- | A 'TermKey' serves to fetch a Term in a Debugger session.+-- Note: A 'TermKey' is only valid in the stopped context it was created in.+data TermKey where+ -- | Obtain a term from an Id.+ FromId :: Id -> TermKey++ -- | Append a PathFragment to the current Term Key. Used to construct keys+ -- for indexed and labeled fields.+ FromPath :: TermKey -> PathFragment -> TermKey++-- | A term may be identified by an 'Id' (such as a local variable) plus a list+-- of 'PathFragment's to an arbitrarily nested field.+data PathFragment+ -- | A positional index is an index from 1 to inf+ = PositionalIndex Int+ -- | A labeled field indexes a datacon fields by name+ | LabeledField Name+ deriving (Eq, Ord)++instance Outputable TermKey where+ ppr (FromId i) = ppr i+ ppr (FromPath _ last_p) = ppr last_p++instance Outputable PathFragment where+ ppr (PositionalIndex i) = text "_" <> ppr i+ ppr (LabeledField n) = ppr n++-- | >>> unconsTermKey (FromPath (FromPath (FromId hi) (Pos 1)) (Pos 2))+-- (hi, [1, 2])+unconsTermKey :: TermKey -> (Id, [PathFragment])+unconsTermKey = go [] where+ go acc (FromId i) = (i, reverse acc)+ go acc (FromPath k p) = go (p:acc) k
+ haskell-debugger/GHC/Debugger/Session.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE DerivingStrategies, CPP, RecordWildCards #-}++-- | Initialise the GHC session for one or more home units.+--+-- This code is inspired of HLS's session initialisation.+-- It would be great to extract common functions in the future.+module GHC.Debugger.Session (+ parseHomeUnitArguments,+ setupHomeUnitGraph,+ TargetDetails(..),+ Target(..),+ toGhcTarget,+ CacheDirs(..),+ getCacheDirs,+ -- * DynFlags modifications+ setWorkingDirectory,+ setCacheDirs,+ setBytecodeBackend,+ enableByteCodeGeneration,+ )+ where++import Control.Monad+import Control.Monad.IO.Class+import qualified Crypto.Hash.SHA1 as H+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as B+import Data.Function+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.List as L+import qualified Data.Containers.ListUtils as L+import GHC.ResponseFile (expandResponse)+import HIE.Bios.Environment as HIE+import System.FilePath+import qualified System.Directory as Directory+import qualified System.Environment as Env++import qualified GHC+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Monad+import qualified GHC.Driver.Session as GHC+import GHC.Utils.Monad as GHC+import GHC.Unit.Home.Graph+import GHC.Unit.Home.PackageTable+import GHC.Unit.Env+import GHC.Unit.Types+import qualified GHC.Unit.State as State+import GHC.Driver.Env+import GHC.Types.SrcLoc+import Language.Haskell.Syntax.Module.Name++-- | Throws if package flags are unsatisfiable+parseHomeUnitArguments :: GhcMonad m+ => FilePath -- ^ Main entry point function+ -> FilePath -- ^ Component root. Important for multi-package cabal projects.+ -> [String]+ -> [String] -- ghcInvocation+ -> DynFlags+ -> FilePath -- ^ root dir, see Note [Root Directory]+ -> m (NonEmpty.NonEmpty (DynFlags, [GHC.Target]))+parseHomeUnitArguments cfp compRoot units theOpts dflags rootDir = do+ ((theOpts',_errs,_warns),_units) <- GHC.processCmdLineP [] [] (map noLoc theOpts)+ case NonEmpty.nonEmpty units of+ Just us -> initMulti us+ Nothing -> do+ (df, targets) <- initOne (map unLoc theOpts')+ -- A special target for the file which caused this wonderful+ -- component to be created. In case the cradle doesn't list all the targets for+ -- the component, in which case things will be horribly broken anyway.+ --+ -- When we have a singleComponent that is caused to be loaded due to a+ -- file, we assume the file is part of that component. This is useful+ -- for bare GHC sessions, such as many of the ones used in the testsuite+ --+ -- We don't do this when we have multiple components, because each+ -- component better list all targets or there will be anarchy.+ -- It is difficult to know which component to add our file to in+ -- that case.+ -- Multi unit arguments are likely to come from cabal, which+ -- does list all targets.+ --+ -- If we don't end up with a target for the current file in the end, then+ -- we will report it as an error for that file+ let abs_fp = rootDir </> cfp+ let special_target = mkSimpleTarget df abs_fp+ pure $ (df, special_target : targets) NonEmpty.:| []+ where+ initMulti unitArgFiles =+ forM unitArgFiles $ \f -> do+ args <- liftIO $ expandResponse [f]+ initOne args+ initOne this_opts = do+ (dflags', targets') <- addCmdOpts this_opts dflags+ let targets = HIE.makeTargetsAbsolute root targets'+ root = case workingDirectory dflags' of+ Nothing -> compRoot+ Just wdir -> compRoot </> wdir+ cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts+ let dflags'' =+ setWorkingDirectory root $+ setCacheDirs cacheDirs $+ enableByteCodeGeneration $+ setBytecodeBackend $+ makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory+ dflags'+ return (dflags'', targets)++setupHomeUnitGraph :: GhcMonad m => [(DynFlags, [GHC.Target])] -> m ()+setupHomeUnitGraph flagsAndTargets = do+ hsc_env <- GHC.getSession+ (hsc_env', targetDetails) <- liftIO $ setupMultiHomeUnitGhcSession [".hs", ".lhs"] hsc_env flagsAndTargets+ GHC.setSession hsc_env'+ GHC.setTargets (fmap toGhcTarget targetDetails)++-- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's.+createUnitEnvFromFlags :: NonEmpty.NonEmpty DynFlags -> IO HomeUnitGraph+createUnitEnvFromFlags 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++ pure $ unitEnv_new (Map.fromList (NonEmpty.toList unitEnvList))++-- | Given a set of 'DynFlags', set up the 'UnitEnv' and 'HomeUnitEnv' for this+-- 'HscEnv'.+-- We assume the 'HscEnv' is "empty", e.g. wasn't already used to compile+-- anything.+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 NonEmpty.:| unitDflags)+ let home_units = unitEnv_keys initial_home_graph+ home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+ dflags = homeUnitEnv_dflags homeUnitEnv+ old_hpt = homeUnitEnv_hpt homeUnitEnv++ (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags cached_unit_dbs 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 dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (homeUnitId_ dflags0) 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 = homeUnitId_ dflags0+ , 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+++-- | Setup the given 'HscEnv' to hold a 'UnitEnv'+-- with all the given components.+-- We return the modified 'HscEnv' and all the 'TargetDetails' for+-- the given 'GHC.Target's.+setupMultiHomeUnitGhcSession+ :: [String] -- ^ File extensions to consider. This is mostly a remnant of HLS.+ -> HscEnv -- ^ An empty HscEnv that we can use the setup the session.+ -> [(DynFlags, [GHC.Target])] -- ^ New components to be loaded. Expected to be non-empty.+ -> IO (HscEnv, [TargetDetails])+setupMultiHomeUnitGhcSession exts hsc_env cis = do+ let dfs = map fst cis++ hscEnv' <- initHomeUnitEnv dfs hsc_env+ -- TODO: this should be reported+ -- _ <- maybeToList $ GHC.checkHomeUnitsClosed (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')+ ts <- forM cis $ \(df, targets) -> do+ -- evaluate $ liftRnf rwhnf targets++ let mk t = fromTargetId (importPaths df) exts (homeUnitId_ df) (GHC.targetId t)+ ctargets <- concatMapM mk targets++ return (L.nubOrdOn targetTarget ctargets)+ pure (hscEnv', concat ts)++data TargetDetails = TargetDetails+ { targetTarget :: Target+ -- ^ Simplified version of 'TargetId', storing enough information+ --+ , targetLocations :: [FilePath]+ -- ^ The physical location of 'targetTarget'.+ -- Contains '-boot' file locations.+ -- At this moment in time, these are unused, but could be used to create+ -- convenient lookup table from 'FilePath' to 'TargetDetails'.+ , targetUnitId :: UnitId+ -- ^ UnitId of 'targetTarget'.+ }+ deriving (Eq, Ord)++-- | A simplified view on a 'TargetId'.+--+-- Implements 'Ord' and 'Show' which can be convenient.+data Target = TargetModule ModuleName | TargetFile FilePath+ deriving ( Eq, Ord, Show )++-- | Turn a 'TargetDetails' into a 'GHC.Target'.+toGhcTarget :: TargetDetails -> GHC.Target+toGhcTarget (TargetDetails tid _ uid) = case tid of+ TargetModule modl -> GHC.Target (GHC.TargetModule modl) True uid Nothing+ TargetFile fp -> GHC.Target (GHC.TargetFile fp Nothing) True uid Nothing++fromTargetId :: [FilePath] -- ^ import paths+ -> [String] -- ^ extensions to consider+ -> UnitId+ -> GHC.TargetId+ -> IO [TargetDetails]+-- For a target module we consider all the import paths+fromTargetId is exts unitId (GHC.TargetModule modName) = do+ let fps = [i </> moduleNameSlashes modName -<.> ext <> boot+ | ext <- exts+ , i <- is+ , boot <- ["", "-boot"]+ ]+ return [TargetDetails (TargetModule modName) fps unitId]+-- For a 'TargetFile' we consider all the possible module names+fromTargetId _ _ unitId (GHC.TargetFile f _) = do+ let other+ | "-boot" `L.isSuffixOf` f = dropEnd 5 f+ | otherwise = (f ++ "-boot")+ return [TargetDetails (TargetFile f) [f, other] unitId]++-- ----------------------------------------------------------------------------+-- GHC Utils that should likely be exposed by GHC+-- ----------------------------------------------------------------------------++mkSimpleTarget :: DynFlags -> FilePath -> GHC.Target+mkSimpleTarget df fp = GHC.Target (GHC.TargetFile fp Nothing) True (homeUnitId_ df) Nothing++hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv+hscSetUnitEnv ue env = env { hsc_unit_env = ue }++-- ----------------------------------------------------------------------------+-- Session cache directory+-- ----------------------------------------------------------------------------++data CacheDirs = CacheDirs+ { hiCacheDir :: FilePath+ , byteCodeCacheDir :: FilePath+ , hieCacheDir :: FilePath+ , objCacheDir :: FilePath+ }++getCacheDirs :: String -> [String] -> IO CacheDirs+getCacheDirs prefix opts = do+ mCacheDir <- Env.lookupEnv "HDB_CACHE_DIR"+ rootDir <- case mCacheDir of+ Just dir -> pure dir+ Nothing ->+ Directory.getXdgDirectory Directory.XdgCache "hdb"+ let sessionCacheDir = rootDir </> prefix ++ "-" ++ opts_hash+ Directory.createDirectoryIfMissing True sessionCacheDir+ pure CacheDirs+ { hiCacheDir = sessionCacheDir+ , byteCodeCacheDir = sessionCacheDir+ , hieCacheDir = sessionCacheDir+ , objCacheDir = sessionCacheDir+ }+ where+ -- Create a unique folder per set of different GHC options, assuming that each different set of+ -- GHC options will create incompatible interface files.+ opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)++-- ----------------------------------------------------------------------------+-- Modification of DynFlags+-- ----------------------------------------------------------------------------++setWorkingDirectory :: FilePath -> DynFlags -> DynFlags+setWorkingDirectory p d = d { workingDirectory = Just p }++setCacheDirs :: CacheDirs -> DynFlags -> DynFlags+setCacheDirs CacheDirs{..} flags = flags+ { hiDir = Just hiCacheDir+ , hieDir = Just hieCacheDir+ , objectDir = Just objCacheDir+#if MIN_VERSION_ghc(9,14,2)+ , bytecodeDir = Just byteCodeCacheDir+#endif+ }++-- | If the compiler supports `.gbc` files (>= 9.14.2), then persist these+-- artefacts to disk.+enableByteCodeGeneration :: DynFlags -> DynFlags+enableByteCodeGeneration dflags =+#if MIN_VERSION_ghc(9,14,2)+ dflags+ & flip gopt_unset Opt_ByteCodeAndObjectCode+ & flip gopt_set Opt_ByteCode+ & flip gopt_set Opt_WriteByteCode+ & flip gopt_set Opt_WriteInterface+#else+ dflags+#endif++setBytecodeBackend :: DynFlags -> DynFlags+setBytecodeBackend dflags = dflags+ {+#if MIN_VERSION_ghc(9,14,2)+ backend = GHC.bytecodeBackend+#else+ backend = GHC.interpreterBackend+#endif+ }++-- ----------------------------------------------------------------------------+-- Utils that we need, but don't want to incur an additional dependency for.+-- ----------------------------------------------------------------------------++-- | Drop a number of elements from the end of the list.+--+-- > dropEnd 3 "hello" == "he"+-- > dropEnd 5 "bye" == ""+-- > dropEnd (-1) "bye" == "bye"+-- > \i xs -> dropEnd i xs `isPrefixOf` xs+-- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i)+-- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..]+dropEnd :: Int -> [a] -> [a]+dropEnd i xs+ | i <= 0 = xs+ | otherwise = f xs (drop i xs)+ where f (a:as) (_:bs) = a : f as bs+ f _ _ = []
+ haskell-debugger/GHC/Debugger/Stopped.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+ DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+ TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Stopped where++import Control.Monad.Reader++import GHC+import GHC.Types.Unique.FM+import GHC.Types.Name.Occurrence (sizeOccEnv)+import GHC.ByteCode.Breakpoints+import GHC.Types.Name.Reader+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.ModDetails+import GHC.Types.TypeEnv+import GHC.Data.Maybe (expectJust)+import GHC.Driver.Env as GHC+import GHC.Runtime.Debugger.Breakpoints as GHC+import GHC.Runtime.Eval+import GHC.Types.SrcLoc+import qualified GHC.Unit.Home.Graph as HUG++import GHC.Debugger.Stopped.Variables+import GHC.Debugger.Runtime+import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Utils++{-+Note [Don't crash if not stopped]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Requests such as `stacktrace`, `scopes`, or `variables` may end up+coming after the execution of a program has terminated. For instance,+consider this interleaving:++1. SENT Stopped event <-- we're stopped+2. RECEIVED StackTrace req <-- client issues after stopped event+3. RECEIVED Next req <-- user clicks step-next+4. <program execution resumes and fails>+5. SENT Terminate event <-- execution failed and we report it to exit cleanly+6. RECEIVED Scopes req <-- happens as a sequence of 2 that wasn't canceled+7. <used to crash! because we're no longer at a breakpoint>++Now, we simply returned empty responses when these requests come in+while we're no longer at a breakpoint. The client will soon come to a halt+because of the termination event we sent.+-}++--------------------------------------------------------------------------------+-- * Stack trace+--------------------------------------------------------------------------------++-- | Get the stack frames at the point we're stopped at+getStacktrace :: Debugger [StackFrame]+getStacktrace = GHC.getResumeContext >>= \case+ [] ->+ -- See Note [Don't crash if not stopped]+ return []+ r:_+ | Just ss <- srcSpanToRealSrcSpan (GHC.resumeSpan r)+ -> return+ [ StackFrame+ { name = GHC.resumeDecl r+ , sourceSpan = realSrcSpanToSourceSpan ss+ }+ ]+ | otherwise ->+ -- No resume span; which should mean we're stopped on an exception.+ -- No info for now.+ return []++--------------------------------------------------------------------------------+-- * Scopes+--------------------------------------------------------------------------------++-- | Get the stack frames at the point we're stopped at+getScopes :: Debugger [ScopeInfo]+getScopes = GHC.getCurrentBreakSpan >>= \case+ Nothing ->+ -- See Note [Don't crash if not stopped]+ return []+ Just span'+ | Just rss <- srcSpanToRealSrcSpan span'+ , let sourceSpan = realSrcSpanToSourceSpan rss+ -> do+ -- It is /very important/ to report a number of variables (numVars) for+ -- larger scopes. If we just say "Nothing", then all variables of all+ -- scopes will be fetched at every stopped event.+ curr_modl <- expectJust <$> getCurrentBreakModule+ in_mod <- getTopEnv curr_modl+ imported <- getTopImported curr_modl+ return+ [ ScopeInfo { kind = LocalVariablesScope+ , expensive = False+ , numVars = Nothing+ , sourceSpan+ }+ , ScopeInfo { kind = ModuleVariablesScope+ , expensive = True+ , numVars = Just (sizeUFM in_mod)+ , sourceSpan+ }+ , ScopeInfo { kind = GlobalVariablesScope+ , expensive = True+ , numVars = Just (sizeOccEnv imported)+ , sourceSpan+ }+ ]+ | otherwise ->+ -- No resume span; which should mean we're stopped on an exception+ -- TODO: Use exception context to create source span, or at least+ -- return the source span null to have Scopes at least.+ return []++--------------------------------------------------------------------------------+-- * Variables+--------------------------------------------------------------------------------+-- Note [Variables Requests]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- We can receive a Variables request for three different reasons+--+-- 1. To get the variables in a certain scope+-- 2. To inspect the value of a lazy variable+-- 3. To expand the structure of a variable+--+-- The replies are, respectively:+--+-- (VARR)+-- (a) All the variables in the request scope+-- (b) ONLY the variable requested+-- (c) The fields of the variable requested but NOT the original variable++-- | Get variables using a variable/variables reference+--+-- If the Variable Request ends up being case (VARR)(b), then we signal the+-- request forced the variable and return @Left varInfo@. Otherwise, @Right vis@.+--+-- See Note [Variables Requests]+getVariables :: VariableReference -> Debugger (Either VarInfo [VarInfo])+getVariables vk = do+ hsc_env <- getSession+ GHC.getResumeContext >>= \case+ [] ->+ -- See Note [Don't crash if not stopped]+ return (Right [])+ r:_ -> case vk of++ -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`)+ -- (VARR)(b,c)+ SpecificVariable i -> do+ lookupVarByReference i >>= \case+ Nothing -> do+ -- lookupVarByReference failed.+ -- This may happen if, in a race, we change scope while asking for+ -- variables of the previous scope.+ -- Somewhat similar to the race in Note [Don't crash if not stopped]+ return (Right [])+ Just key -> do+ term <- obtainTerm key++ case term of++ -- (VARR)(b)+ Suspension{} -> do++ -- Original Term was a suspension:+ -- It is a "lazy" DAP variable: our reply can ONLY include+ -- this single variable.++ term' <- forceTerm key term++ vi <- termToVarInfo key term'++ return (Left vi)++ -- (VARR)(c)+ _ -> Right <$> do++ -- Original Term was already something other than a Suspension;+ -- Meaning the @SpecificVariable@ request means to inspect the structure.+ -- Return ONLY the fields++ termVarFields key term >>= \case+ NoFields -> return []+ LabeledFields xs -> return xs+ IndexedFields xs -> return xs+++ -- (VARR)(a) from here onwards++ LocalVariables -> fmap Right $+ -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)+ mapM tyThingToVarInfo =<< GHC.getBindings++ ModuleVariables -> Right <$> do+ case GHC.resumeBreakpointId r of+ Nothing -> return []+ Just ibi -> do+#if MIN_VERSION_ghc(9,14,2)+ curr_modl <- liftIO $ bi_tick_mod . getBreakSourceId ibi <$>+ readIModBreaks (hsc_HUG hsc_env) ibi+#else+ let curr_modl = ibi_tick_mod ibi+#endif+ things <- typeEnvElts <$> getTopEnv curr_modl+ mapM (\tt -> do+ nameStr <- display (getName tt)+ vi <- tyThingToVarInfo tt+ return vi{varName = nameStr}) things++ GlobalVariables -> Right <$> do+ case GHC.resumeBreakpointId r of+ Nothing -> return []+ Just ibi -> do+#if MIN_VERSION_ghc(9,14,2)+ curr_modl <- liftIO $ bi_tick_mod . getBreakSourceId ibi <$>+ readIModBreaks (hsc_HUG hsc_env) ibi+#else+ let curr_modl = ibi_tick_mod ibi+#endif+ names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl+ mapM (\n-> do+ nameStr <- display n+ liftIO (GHC.lookupType hsc_env n) >>= \case+ Nothing ->+ return VarInfo+ { varName = nameStr+ , varType = ""+ , varValue = ""+ , isThunk = False+ , varRef = NoVariables+ }+ Just tt -> do+ vi <- tyThingToVarInfo tt+ return vi{varName = nameStr}+ ) names++ NoVariables -> Right <$> do+ return []++--------------------------------------------------------------------------------+-- Inspect+--------------------------------------------------------------------------------++-- | All top-level things from a module, including unexported ones.+getTopEnv :: Module -> Debugger TypeEnv+getTopEnv modl = do+ hsc_env <- getSession+ liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case+ Nothing -> return emptyTypeEnv+ Just HomeModInfo+ { hm_details = ModDetails+ { md_types = things+ }+ } -> return things++-- | All bindings imported at a given module+getTopImported :: Module -> Debugger GlobalRdrEnv+getTopImported modl = do+ hsc_env <- getSession+ liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case+ Nothing -> return emptyGlobalRdrEnv+ Just hmi -> mkTopLevImportedEnv hsc_env hmi
+ haskell-debugger/GHC/Debugger/Stopped/Variables.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+ DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+ TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Stopped.Variables where++import Data.IORef+import Control.Monad.Reader++import GHC+import GHC.Types.FieldLabel+import GHC.Runtime.Eval+import GHC.Core.DataCon+import qualified GHC.Runtime.Debugger as GHCD+import qualified GHC.Runtime.Heap.Inspect as GHCI++import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Runtime+import GHC.Debugger.Runtime.Term.Key+import GHC.Debugger.Runtime.Term.Cache+import GHC.Debugger.Utils++-- | '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 = \case+ t@(AConLike c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables+ t@(ATyCon c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables+ t@(ACoAxiom c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables+ AnId i -> do+ let key = FromId i+ term <- obtainTerm key+ termToVarInfo key term++-- | Construct the VarInfos of the fields ('VarFields') of the given 'TermKey'/'Term'+termVarFields :: TermKey -> Term -> Debugger VarFields+termVarFields top_key top_term =++ -- Make 'VarInfo's for the first layer of subTerms only.+ case top_term of+ -- Boring types don't get subfields+ _ | isBoringTy (GHCI.termType top_term) ->+ return NoFields++ Term{dc=Right dc, subTerms=_{- don't use directly! go through @obtainTerm@ -}} -> do+ case dataConFieldLabels dc of+ -- Not a record type,+ -- Use indexed fields+ [] -> do+ let keys = zipWith (\ix _ -> FromPath top_key (PositionalIndex ix)) [1..] (dataConOrigArgTys dc)+ IndexedFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys+ -- Is a record data con,+ -- Use field labels+ dataConFields -> do+ let keys = map (FromPath top_key . LabeledField . flSelector) dataConFields+ LabeledFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo 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+ return (IndexedFields [wvi])+ [fld] -> do+ let key = FromPath top_key (LabeledField (flSelector fld))+ wvi <- obtainTerm key >>= termToVarInfo key+ return (LabeledFields [wvi])+ _ -> error "unexpected number of Newtype fields: larger than 1"+ _ -> return NoFields+++-- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds+termToVarInfo :: TermKey -> Term -> Debugger VarInfo+termToVarInfo key term0 = do+ -- Make a VarInfo for a term+ let+ isThunk+ | Suspension{} <- term0 = True+ | otherwise = False+ ty = GHCI.termType term0++ term <- if not isThunk && isBoringTy ty+ then forceTerm key term0 -- make sure that if it's an evaluated boring term then it is /fully/ evaluated.+ else pure term0++ let+ -- We scrape the subterms to display as the var's value. The structure is+ -- displayed in the editor itself by expanding the variable sub-fields+ termHead t+ -- But show strings and lits in full+ | isBoringTy ty = t+ | otherwise = case t of+ Term{} -> t{subTerms = []}+ NewtypeWrap{wrapped_term} -> t{wrapped_term = termHead wrapped_term}+ _ -> t+ varName <- display key+ varType <- display ty+ varValue <- display =<< GHCD.showTerm (termHead term)+ -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term)++ -- The VarReference allows user to expand variable structure and inspect its value.+ -- Here, we do not want to allow expanding a term that is fully evaluated.+ -- We only want to return @SpecificVariable@ (which allows expansion) for+ -- values with sub-fields or thunks.+ varRef <- do+ if GHCI.isFullyEvaluatedTerm term ||+ -- Even if it is already evaluated, we do want to display a+ -- structure as long if it is not a "boring type" (one that does not+ -- provide useful information from being expanded)+ -- (e.g. consider how awkward it is to expand Char# 10 and I# 20)+ (not isThunk && (isBoringTy ty || not (hasDirectSubTerms term)))+ then do+ return NoVariables+ else do+ ir <- getVarReference key+ return (SpecificVariable ir)++ return VarInfo{..}+ where+ hasDirectSubTerms = \case+ Suspension{} -> False+ Prim{} -> False+ NewtypeWrap{} -> True+ RefWrap{} -> True+ Term{subTerms} -> not $ null subTerms++-- | Forces a term to WHNF in the general case, or to NF in the case of 'isBoringTy'.+-- The term is updated at the given key.+forceTerm :: TermKey -> Term -> Debugger Term+forceTerm key term = do+ let ty = GHCI.termType term+ term' <- if isBoringTy ty+ -- deepseq boring types like String, because it is more helpful+ -- to print them whole than their structure.+ then deepseqTerm term+ else seqTerm term+ -- update cache with the forced term right away instead of invalidating it.+ asks termCache >>= \r -> liftIO $ modifyIORef' r (insertTermCache key term')+ return term'
+ haskell-debugger/GHC/Debugger/Utils.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+ DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+ TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Utils where++import GHC+import GHC.Data.FastString+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Ppr as GHC+import GHC.Utils.Outputable as GHC++import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages++--------------------------------------------------------------------------------+-- * GHC Utilities+--------------------------------------------------------------------------------++-- | Convert a GHC's src span into an interface one+realSrcSpanToSourceSpan :: RealSrcSpan -> SourceSpan+realSrcSpanToSourceSpan ss = SourceSpan+ { file = unpackFS $ srcSpanFile ss+ , startLine = srcSpanStartLine ss+ , startCol = srcSpanStartCol ss+ , endLine = srcSpanEndLine ss+ , endCol = srcSpanEndCol ss+ }++-- | Display an Outputable value as a String+display :: Outputable a => a -> Debugger String+display x = do+ dflags <- getDynFlags+ return $ showSDoc dflags (ppr x)+{-# INLINE display #-}+
+ hdb/Development/Debug/Adapter.hs view
@@ -0,0 +1,59 @@+module Development.Debug.Adapter where++import Control.Concurrent.MVar+import qualified Data.IntSet as IS+import qualified Data.Map as Map+import qualified Data.Text as T+import System.FilePath++import DAP+import qualified GHC+import qualified GHC.Debugger.Interface.Messages as D (Command, Response)++type DebugAdaptor = Adaptor DebugAdaptorState Request+type DebugAdaptorCont = Adaptor DebugAdaptorState ()+type DebugAdaptorX r = Adaptor DebugAdaptorState r ()++-- | Debugger state:+--+-- * Keep a mapping from DAP breakpoint ids to internal breakpoint ids+-- * Keep the MVar through which synchronous communication with the debugger is done.+-- - 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+ , syncResponses :: MVar D.Response+ , nextFreshBreakpointId :: !BreakpointId+#if MIN_VERSION_ghc(9,14,2)+ , breakpointMap :: Map.Map GHC.InternalBreakpointId BreakpointSet+#else+ , breakpointMap :: Map.Map GHC.BreakpointId BreakpointSet+#endif+ , entryPoint :: String+ , entryArgs :: [String]+ , projectRoot :: FilePath+ }++type BreakpointId = Int+type BreakpointSet = IS.IntSet++instance MonadFail DebugAdaptor where+ fail a = error a+ -- TODO: PROPER ERROR HANDLING with termination, possibly delete this instance++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++-- | Transform the given file into a DAP 'Source'. The file may be modified:+--+-- * if the given filepath is absolute, it's returned unchanged+-- * if it is relative to the project root, it's returned absolute (with the project root prepended)+fileToSource :: FilePath -> DebugAdaptor Source+fileToSource file = do+ root <- projectRoot <$> getDebugSession+ fullPath <- if isAbsolute file+ then return file+ else return (root </> file)+ return defaultSource{sourcePath = Just (T.pack fullPath)}+
+ hdb/Development/Debug/Adapter/Breakpoints.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, RecordWildCards, PatternSynonyms #-}+module Development.Debug.Adapter.Breakpoints where++import qualified Data.Text as T+import qualified Data.Map as Map+import qualified Data.IntSet as IS+import Control.Monad+import Data.Maybe++import qualified GHC++import DAP++import GHC.Debugger.Interface.Messages hiding (Command, Response)++import Development.Debug.Adapter+import Development.Debug.Adapter.Interface++-- | BreakpointLocations command+commandBreakpointLocations :: DebugAdaptor ()+commandBreakpointLocations = do+ BreakpointLocationsArguments{..} <- getArguments+ file <- fileFromSourcePath breakpointLocationsArgumentsSource++ DidGetBreakpoints mspan <-+ sendSync (GetBreakpointsAt (ModuleBreak file breakpointLocationsArgumentsLine breakpointLocationsArgumentsColumn))++ let locs = case mspan of+ Nothing -> []+ Just SourceSpan {..} ->+ [ BreakpointLocation+ { breakpointLocationLine = startLine+ , breakpointLocationColumn = Just startCol+ , breakpointLocationEndLine = Just endLine+ , breakpointLocationEndColumn = Just endCol+ }+ ]++ sendBreakpointLocationsResponse locs++-- | Execute adaptor command set module breakpoints+commandSetBreakpoints :: DebugAdaptor ()+commandSetBreakpoints = do+ SetBreakpointsArguments {..} <- getArguments+ file <- fileFromSourcePath setBreakpointsArgumentsSource+ let breaks_wanted = fromMaybe [] setBreakpointsArgumentsBreakpoints++ -- Clear existing module breakpoints+ DidClearBreakpoints <- sendSync (ClearModBreakpoints file)++ -- Set requested ones+ breaks <- forM breaks_wanted $ \bp -> do+ DidSetBreakpoint bf <-+ sendSync (SetBreakpoint (ModuleBreak file (DAP.sourceBreakpointLine bp) (DAP.sourceBreakpointColumn bp)))+ registerBreakFound bf++ sendSetBreakpointsResponse (concat breaks)++-- | Execute adaptor command set function breakpoints+commandSetFunctionBreakpoints :: DebugAdaptor ()+commandSetFunctionBreakpoints = do+ SetFunctionBreakpointsArguments{..} <- getArguments+ let+ breaks_wanted = mapMaybe functionBreakpointName setFunctionBreakpointsArgumentsBreakpoints++ -- Clear existing function breakpoints+ DidClearBreakpoints <- sendSync ClearFunctionBreakpoints++ -- Set requested ones+ breaks <- forM breaks_wanted $ \bp -> do+ DidSetBreakpoint bf <-+ sendSync (SetBreakpoint (FunctionBreak (T.unpack bp)))+ registerBreakFound bf++ sendSetFunctionBreakpointsResponse (concat breaks)++-- | Execute adaptor command set exception breakpoints+commandSetExceptionBreakpoints :: DebugAdaptor ()+commandSetExceptionBreakpoints = do+ SetExceptionBreakpointsArguments{..} <- getArguments++ -- Clear old exception breakpoints+ DidRemoveBreakpoint _ <- sendSync (DelBreakpoint OnExceptionsBreak)+ DidRemoveBreakpoint _ <- sendSync (DelBreakpoint OnUncaughtExceptionsBreak)++ let breakOnExceptions = BREAK_ON_EXCEPTION `elem` setExceptionBreakpointsArgumentsFilters+ let breakOnError = BREAK_ON_ERROR `elem` setExceptionBreakpointsArgumentsFilters++ when breakOnExceptions $ do+ DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak)+ pure ()++ when breakOnError $ do+ DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak)+ pure ()++ sendSetExceptionBreakpointsResponse+ [ defaultBreakpoint | True <- [breakOnError, breakOnExceptions] ]++--------------------------------------------------------------------------------+-- * Aux+--------------------------------------------------------------------------------++pattern BREAK_ON_EXCEPTION, BREAK_ON_ERROR :: T.Text+pattern BREAK_ON_EXCEPTION = "break-on-exception"+pattern BREAK_ON_ERROR = "break-on-error"++-- | Turn a haskell-debugger 'BreakFound' into a DAP 'Breakpoint'.+--+-- Additionally, gets a fresh Id for the breakpoint and registers it on the breakpoint map+registerBreakFound :: BreakFound -> DebugAdaptor [DAP.Breakpoint]+registerBreakFound b =+ case b of+ ManyBreaksFound bs -> concat <$> mapM registerBreakFound bs+ BreakNotFound -> pure [ DAP.defaultBreakpoint { DAP.breakpointVerified = False } ]+ BreakFoundNoLoc _ch -> pure [ DAP.defaultBreakpoint { DAP.breakpointVerified = True } ]+ BreakFound _ch iid ss -> do+ source <- fileToSource ss.file+#if MIN_VERSION_ghc(9,14,2)+ bids <- mapM registerNewBreakpoint iid+ pure $ map (\bid -> DAP.defaultBreakpoint+ { DAP.breakpointVerified = True+ , DAP.breakpointSource = Just source+ , DAP.breakpointLine = Just ss.startLine+ , DAP.breakpointEndLine = Just ss.endLine+ , DAP.breakpointColumn = Just ss.startCol+ , DAP.breakpointEndColumn = Just ss.endCol+ , DAP.breakpointId = Just bid+ }) bids+#else+ bid <- registerNewBreakpoint iid+ pure [ DAP.defaultBreakpoint+ { DAP.breakpointVerified = True+ , DAP.breakpointSource = Just source+ , DAP.breakpointLine = Just ss.startLine+ , DAP.breakpointEndLine = Just ss.endLine+ , DAP.breakpointColumn = Just ss.startCol+ , DAP.breakpointEndColumn = Just ss.endCol+ , DAP.breakpointId = Just bid+ } ]+#endif++-- | Adds new BreakpointId for a givent StgPoint+#if MIN_VERSION_ghc(9,14,2)+registerNewBreakpoint :: GHC.InternalBreakpointId -> DebugAdaptor BreakpointId+#else+registerNewBreakpoint :: GHC.BreakpointId -> DebugAdaptor BreakpointId+#endif+registerNewBreakpoint breakpoint = do+ bkpId <- getFreshBreakpointId+ updateDebugSession $ \das@DAS{..} -> das {breakpointMap = Map.insertWith mappend breakpoint (IS.singleton bkpId) breakpointMap}+ pure bkpId++-- | Generate fresh breakpoint Id.+getFreshBreakpointId :: DebugAdaptor BreakpointId+getFreshBreakpointId = do+ bkpId <- nextFreshBreakpointId <$> getDebugSession+ updateDebugSession $ \s -> s { nextFreshBreakpointId = nextFreshBreakpointId s + 1 }+ pure bkpId++-- | Get the file from a DAP Source+--+-- TODO: Handles sourceReferences too+fileFromSourcePath :: Source -> DebugAdaptor FilePath+fileFromSourcePath source = do+ let+ file = T.unpack $+ fromMaybe (error "sourceReference unsupported") $+ sourcePath source+ return file
+ hdb/Development/Debug/Adapter/Evaluation.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE RecordWildCards, OverloadedRecordDot, DuplicateRecordFields #-}+module Development.Debug.Adapter.Evaluation where++import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.IntSet as IS++import DAP++import GHC.Debugger.Interface.Messages+import Development.Debug.Adapter+import Development.Debug.Adapter.Interface+import qualified Development.Debug.Adapter.Output as Output++--------------------------------------------------------------------------------+-- * Executing debuggee+--------------------------------------------------------------------------------++-- | Start executing from entry point+--+-- TODO:+-- [ ] Consider using Output events for debuggee evaluation.+startExecution :: DebugAdaptor EvalResult+startExecution = do+ DAS{entryPoint, entryArgs} <- getDebugSession+ let entry+ | entryPoint == "main" = MainEntry Nothing+ | otherwise = FunctionEntry entryPoint+ DidExec er <- sendSync DebugExecution{entryPoint = entry, runArgs = entryArgs}+ return er++--------------------------------------------------------------------------------+-- * Eval+--------------------------------------------------------------------------------++-- | Command for evaluation (includes evaluation-on-hover)+commandEvaluate :: DebugAdaptor ()+commandEvaluate = do+ EvaluateArguments {..} <- getArguments+ DidEval er <- sendSync (DoEval (T.unpack evaluateArgumentsExpression))+ case er of+ EvalStopped{} -> error "impossible, execution is resumed automatically for 'DoEval'"+ EvalAbortedWith e -> do+ -- Evaluation failed, we report it but don't terminate.+ sendEvaluateResponse EvaluateResponse+ { evaluateResponseResult = T.pack e+ , evaluateResponseType = T.pack ""+ , evaluateResponsePresentationHint = Nothing+ , evaluateResponseVariablesReference = 0+ , evaluateResponseNamedVariables = Nothing+ , evaluateResponseIndexedVariables = Nothing+ , evaluateResponseMemoryReference = Nothing+ }+ _ -> do+ sendEvaluateResponse EvaluateResponse+ { evaluateResponseResult = T.pack $ resultVal er+ , evaluateResponseType = T.pack $ resultType er+ , evaluateResponsePresentationHint = Nothing+ , evaluateResponseVariablesReference = 0+ , evaluateResponseNamedVariables = Nothing+ , evaluateResponseIndexedVariables = Nothing+ , evaluateResponseMemoryReference = Nothing+ }++--------------------------------------------------------------------------------+-- * Utils+--------------------------------------------------------------------------------++-- | Handle an EvalResult by sending a stopped or exited event.+--+-- In particular, the result of evaluation is ignored by this function.+-- The 'EvaluateRequest' handler inspects the EvalResult itself and reports on the result.+handleEvalResult :: Bool {-^ Whether we are "stepping" -} -> EvalResult -> DebugAdaptor ()+handleEvalResult stepping er = case er of+ EvalAbortedWith e -> do+ Output.console (T.pack e)+ sendTerminatedEvent defaultTerminatedEvent+ sendExitedEvent (ExitedEvent 43)+ EvalCompleted{} -> do+ sendTerminatedEvent defaultTerminatedEvent+ sendExitedEvent (ExitedEvent 0)+ EvalException{} -> do+ sendTerminatedEvent defaultTerminatedEvent+ sendExitedEvent (ExitedEvent 42)+ EvalStopped {breakId = Nothing} ->+ sendStoppedEvent+ defaultStoppedEvent {+ stoppedEventAllThreadsStopped = True+ , stoppedEventReason = StoppedEventReasonException+ , stoppedEventHitBreakpointIds = []+ }+ EvalStopped {breakId = Just bid} -> do+ DAS{breakpointMap} <- getDebugSession+ sendStoppedEvent+ defaultStoppedEvent {+ stoppedEventAllThreadsStopped = True+ -- could be more precise here by saying "function breakpoint" rather than always "breakpoint"+ , stoppedEventReason+ = if stepping then StoppedEventReasonStep+ else StoppedEventReasonBreakpoint+ , stoppedEventHitBreakpointIds+ = maybe [] IS.toList (M.lookup bid breakpointMap)+ }+
+ hdb/Development/Debug/Adapter/Exit.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE LambdaCase #-}++-- | Module concerning with reporting failures and exiting cleanly the+-- debugging process. An overview of covered exit modes:+--+-- == 1. The top-level DebugAdaptor process+-- * Command Terminate+-- * Command Disconnect+-- * DebugAdaptor crashes while executing (handled by DAP library?)+-- * One of the threads launched by registerNewDebugSession crash+--+-- == 2. The haskell-debugger process+-- * GHC debugger crashes while initializing (e.g. while compiling or when discovering flags)+-- * GHC debugger crashes while executing a request+--+-- == 3. The debuggee loaded in haskell-debugger and runs+-- * The debuggee terminates successfully+-- * The debuggee terminates with an exception+-- * The debuggee crashes in another way+--+-- Notes:+-- * @'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.IO.Class+import Control.Exception+import Control.Exception.Context+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++-- | Command terminate (1a)+--+-- 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+ sendTerminateResponse+ exitCleanly++-- | Command disconnect (1b)+--+-- Terminate the debuggee (and any child processes) forcefully.+commandDisconnect :: DebugAdaptor ()+commandDisconnect = do+ destroyDebugSession+ sendDisconnectResponse+ exitCleanly++--- 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)+ do -- flush buffer and 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++exitCleanly :: DebugAdaptor a+exitCleanly = 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 $ 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++
+ hdb/Development/Debug/Adapter/Flags.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Development.Debug.Adapter.Flags where++import Control.Applicative ((<|>))+import Control.Exception (handleJust)+import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Data.Bifunctor+import Data.Function+import Data.Functor ((<&>))+import Data.Maybe+import Data.Version+import Data.Void+import System.Directory hiding (findFile)+import System.FilePath+import System.IO.Error+import Text.ParserCombinators.ReadP (readP_to_S)++import qualified HIE.Bios as HIE+import qualified HIE.Bios.Config as Config+import qualified HIE.Bios.Cradle as HIE+import qualified HIE.Bios.Environment as HIE+import qualified HIE.Bios.Types as HIE+import qualified Hie.Cabal.Parser as Implicit+import qualified Hie.Locate as Implicit+import qualified Hie.Yaml as Implicit++import Development.Debug.Adapter.Logger++-- | Flags inferred by @hie-bios@ to invoke GHC+data HieBiosFlags = HieBiosFlags+ { ghcInvocation :: [String]+ , libdir :: FilePath+ , units :: [String]+ , rootDir :: FilePath+ -- ^ Root dir as reported by the 'Cradle'+ , componentDir :: FilePath+ -- ^ Root dir of the loaded 'ComponentOptions'.+ -- Important for multi-package cabal projects, as packages are not in the+ -- root of the cradle, but in some sub-directory.+ }++hieBiosCradle :: LogAction IO (WithSeverity HIE.Log) {-^ Logger -}+ -> FilePath {-^ Project root -}+ -> FilePath {-^ Entry file relative to root -}+ -> IO (Either String (HIE.Cradle Void))+hieBiosCradle logger root relTarget = runExceptT $ do+ let target = root </> relTarget+ explicitCradle <- HIE.findCradle target & liftIO+ cradle <- maybe (loadImplicitCradle logger target)+ (HIE.loadCradle logger) explicitCradle & liftIO+ pure cradle++hieBiosRuntimeGhcVersion :: LogAction IO (WithSeverity HIE.Log)+ -> HIE.Cradle Void+ -> IO (Either String Version)+hieBiosRuntimeGhcVersion _logger cradle = runExceptT $ do+ out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version"+ case versionMaybe out of+ Nothing -> throwError $ "Failed to parse GHC version: " <> out+ Just ver -> pure ver++-- | Make 'HieBiosFlags' from the given target file+hieBiosFlags :: LogAction IO (WithSeverity HIE.Log) {-^ Logger -}+ -> HIE.Cradle Void {-^ Project cradle the entry file belongs to -}+ -> FilePath {-^ Project root -}+ -> FilePath {-^ Entry file relative to root -}+ -> IO (Either String HieBiosFlags)+hieBiosFlags _logger cradle root relTarget = runExceptT $ do+ let target = root </> relTarget+ libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir"++ -- To determine the flags we MUST set the current directory to the root+ -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does)+ -- (HIE.getCompilerOptions depends on CWD being the proper root dir)+ let compilerOpts = liftIO $ withCurrentDirectory root $+#if MIN_VERSION_hie_bios(0,14,0)+ HIE.getCompilerOptions target (HIE.LoadWithContext [target]) cradle+#else+ HIE.getCompilerOptions target [] cradle+#endif+ componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"+#if __GLASGOW_HASKELL__ >= 913+ -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading+ -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch.+ -- ["-fwrite-if-simplified-core"] +++#endif++ let (units', flags') = extractUnits (HIE.componentOptions componentOpts)+ return HieBiosFlags+ { ghcInvocation = flags' ++ ghcDebuggerFlags+ , libdir = libdir+ , units = units'+ , rootDir = HIE.cradleRootDir cradle+ , componentDir = HIE.componentRoot componentOpts+ }++unwrapCradleResult :: MonadError String m => [Char] -> HIE.CradleLoadResult a -> m a+unwrapCradleResult m = \case+ HIE.CradleNone -> throwError $ "HIE.CradleNone\n" ++ m+ HIE.CradleFail err -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m+ HIE.CradleSuccess x -> return x++extractUnits :: [String] -> ([String], [String])+extractUnits = go [] []+ where+ -- TODO: we should likely use the 'processCmdLineP' instead+ go units rest ("-unit" : x : xs) = go (x : units) rest xs+ go units rest (x : xs) = go units (x : rest) xs+ go units rest [] = (reverse units, reverse rest)++-- | Flags specific to haskell-debugger to append to all GHC invocations.+ghcDebuggerFlags :: [String]+ghcDebuggerFlags =+ [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt+ ]+++-- ----------------------------------------------------------------------------+-- Utilities+-- ----------------------------------------------------------------------------++versionMaybe :: String -> Maybe Version+versionMaybe xs = case reverse $ readP_to_S parseVersion xs of+ [] -> Nothing+ (x:_) -> Just (fst x)++-- ----------------------------------------------------------------------------+-- Implicit cradle discovery logic mirroring the one used by HLS.+-- The code itself is copy-pasted from HLS.+-- Obviously, we want to reuse the logic without having to depend on HLS.+-- We should factor out a common sub-component from HLS and use it here as well.+-- ----------------------------------------------------------------------------++loadImplicitCradle :: Show a => LogAction IO (WithSeverity HIE.Log) -> FilePath -> IO (HIE.Cradle a)+loadImplicitCradle l wfile = do+ is_dir <- doesDirectoryExist wfile+ let wdir | is_dir = wfile+ | otherwise = takeDirectory wfile+ cfg <- runMaybeT (implicitConfig wdir)+ case cfg of+ Just bc -> HIE.getCradle l absurd bc+ Nothing -> return $ HIE.defaultCradle l wdir++-- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies+implicitConfig :: FilePath -> MaybeT IO (Config.CradleConfig a, FilePath)+implicitConfig = (fmap . first) (Config.CradleConfig noDeps) . inferCradleTree+ where+ noDeps :: [FilePath]+ noDeps = []+++inferCradleTree :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)+inferCradleTree start_dir =+ maybeItsBios+ -- If we have both a config file (cabal.project/stack.yaml) and a work dir+ -- (dist-newstyle/.stack-work), prefer that+ <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir))+ <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir)+ -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal+ <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle)+ -- If we have a stack.yaml, use stack+ <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle)+ -- If we have a cabal file, use cabal+ <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle)++ where+ maybeItsBios = (\wdir -> (Config.Bios (Config.Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir++ cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir)++-- | Generate a stack cradle given a filepath.+--+-- Since we assume there was proof that this file belongs to a stack cradle+-- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files.+-- We do not look for package.yaml, as we assume the corresponding .cabal has+-- been generated already.+--+-- We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then+-- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to+-- component names.+stackCradle :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)+stackCradle fp = do+ pkgs <- Implicit.stackYamlPkgs fp+ pkgsWithComps <- liftIO $ catMaybes <$> mapM (Implicit.nestedPkg fp) pkgs+ let yaml = fp </> "stack.yaml"+ pure $ (,fp) $ case pkgsWithComps of+ [] -> Config.Stack (Config.StackType Nothing (Just yaml))+ ps -> Config.StackMulti mempty $ do+ Implicit.Package n cs <- ps+ c <- cs+ let (prefix, comp) = Implicit.stackComponent n c+ pure (prefix, Config.StackType (Just comp) (Just yaml))++-- | By default, we generate a simple cabal cradle which is equivalent to the+-- following hie.yaml:+--+-- @+-- cradle:+-- cabal:+-- @+--+-- Note, this only works reliable for reasonably modern cabal versions >= 3.2.+simpleCabalCradle :: FilePath -> (Config.CradleTree a, FilePath)+simpleCabalCradle fp = (Config.Cabal $ Config.CabalType Nothing Nothing, fp)++cabalExecutable :: MaybeT IO FilePath+cabalExecutable = MaybeT $ findExecutable "cabal"++stackExecutable :: MaybeT IO FilePath+stackExecutable = MaybeT $ findExecutable "stack"++biosWorkDir :: FilePath -> MaybeT IO FilePath+biosWorkDir = findFileUpwards (".hie-bios" ==)++cabalWorkDir :: FilePath -> MaybeT IO ()+cabalWorkDir wdir = do+ check <- liftIO $ doesDirectoryExist (wdir </> "dist-newstyle")+ unless check $ fail "No dist-newstyle"++stackWorkDir :: FilePath -> MaybeT IO ()+stackWorkDir wdir = do+ check <- liftIO $ doesDirectoryExist (wdir </> ".stack-work")+ unless check $ fail "No .stack-work"++cabalConfigDir :: FilePath -> MaybeT IO FilePath+cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local")++cabalFileDir :: FilePath -> MaybeT IO FilePath+cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal")++stackConfigDir :: FilePath -> MaybeT IO FilePath+stackConfigDir = findFileUpwards isStack+ where+ isStack name = name == "stack.yaml"++-- | Searches upwards for the first directory containing a file to match+-- the predicate.+findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath+findFileUpwards p dir = do+ cnts <-+ liftIO+ $ handleJust+ -- Catch permission errors+ (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)+ pure+ (findFile p dir)++ case cnts of+ [] | dir' == dir -> fail "No cabal files"+ | otherwise -> findFileUpwards p dir'+ _ : _ -> return dir+ where dir' = takeDirectory dir++-- | Sees if any file in the directory matches the predicate+findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findFile p dir = do+ b <- doesDirectoryExist dir+ if b then getFiles >>= filterM doesPredFileExist else return []+ where+ getFiles = filter p <$> getDirectoryContents dir+ doesPredFileExist file = doesFileExist $ dir </> file
+ hdb/Development/Debug/Adapter/Handles.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, CPP, DeriveAnyClass, DeriveGeneric, DerivingVia, LambdaCase, RecordWildCards #-}+module Development.Debug.Adapter.Handles+ ( handleLogger+ , withInterceptedStdout+ , withInterceptedStderr+ , withInterceptedStdoutForwarding+ , withInterceptedStderrForwarding+ ) where++import DAP+++import System.IO ()+import DAP.Log+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Control.Concurrent.MVar+import GHC.IO.Handle.FD+import GHC.IO.Handle+import System.Process+import Control.Exception+import Control.Monad+import Control.Concurrent.Async++{- Note [Debugger Handles]+~~~~~~~~~~~~~~~~~~~~~~~~~~++The debugger executes arbritary user programs which will output to stdout and stderr.+This output needs to be sent to the debug client. Any output we wish to put in a+log or elsewhere needs to be directed to another handle.+++-}++handleLogger :: Handle -> IO (LogAction IO T.Text)+handleLogger out_handle = do+ handleLock <- newMVar ()+ return $ LogAction $ \msg -> do+ withLock handleLock $ do+ T.hPutStrLn out_handle msg++-- | Redirect stdout globally, run the continuation with a bypass handle for real stdout.+withInterceptedStdout :: (Handle -- ^ realStdout, write to this handle sends output to stdout+ -> Handle -- ^ interceptedStdout, stdout captured from attempting to write to stdout handle.+ -> IO ()) -> IO ()+withInterceptedStdout k = do+ withPipe $ \readOutHandle writeOutHandle -> do+ hSetBuffering readOutHandle NoBuffering+ hSetBuffering writeOutHandle LineBuffering+ withStdoutBypass writeOutHandle $ \realStdout -> do+ k realStdout readOutHandle++-- | Redirect stderr globally, run the continuation with a bypass handle for real stderr.+withInterceptedStderr :: (Handle -- ^ realStderr, write to this handle sends output to stderr+ -> Handle -- ^ interceptedStderr, stdout captured from attempting to write to stderr handle.+ -> IO ()) -> IO ()+withInterceptedStderr k = do+ withPipe $ \readErrHandle writeErrHandle -> do+ hSetBuffering readErrHandle NoBuffering+ hSetBuffering writeErrHandle LineBuffering+ withStderrBypass writeErrHandle $ \realStderr -> do+ k realStderr readErrHandle++-- | Intercept stderr, and spawn a thread which forwards the input+-- onwards using the supplied IO action.+withInterceptedStderrForwarding :: (T.Text -> IO ())+ -- ^ All stderr input that is intercepted is forwarded to this thread+ -> (Handle -> IO ())+ -- ^ The continuation receives the REAL STDERR+ -> IO ()+withInterceptedStderrForwarding write_stderr k = do+ withInterceptedStderr $ \realStderr interceptedStderr -> do+ withAsync (forwardingThread write_stderr interceptedStderr) $ \_ -> do+ k realStderr++-- | Intercept stdout, and spawn a thread which forwards the input+-- onwards using the supplied IO action.+withInterceptedStdoutForwarding :: (T.Text -> IO ())+ -- ^ All stdout input that is intercepted is forwarded to this thread+ -> (Handle -> IO ())+ -- ^ The continuation receives the REAL STDOUT+ -> IO ()+withInterceptedStdoutForwarding write_stdout k = do+ withInterceptedStdout $ \realStdout interceptedStdout -> do+ withAsync (forwardingThread write_stdout interceptedStdout) $ \_ ->+ k realStdout++--------------------------------------------------------------------------------+-- Auxiliary+--------------------------------------------------------------------------------++-- | Temporarily bypass the intercepted stdout/stderr to write directly to the original stdout/stderr.+-- This is useful for debugging or for sending output that should not be intercepted.+withStdoutBypass, withStderrBypass+ :: Handle+ -> (Handle -> IO r)+ -> IO r+withStdoutBypass interceptH = withHandleBypass stdout interceptH+withStderrBypass interceptH = withHandleBypass stderr interceptH++-- | Capture all output written to a given handle and redirect it to the other+-- one; the continuation can use the "real" copy of the first handle to write+-- to it while bypassing the redirection.+--+-- This is useful for debugging or for sending output that should not be intercepted.+withHandleBypass :: Handle+ -- ^ Text written to this handle...+ -> Handle+ -- ^ ...will be redirected to this handle+ -> (Handle -> IO r)+ -- ^ Continuation receives as an argument a "real" copy of the handle that is now being redirected.+ -- If you write to this Handle, it will write to the original one and *bypass* the redirection (ie it will not be redirected)+ -> IO r+withHandleBypass originalHandle interceptWriteHandle action =+ bracket setup clean action+ where+ setup = do+ realHandle <- hDuplicate originalHandle+ hFlush originalHandle+ hDuplicateTo interceptWriteHandle originalHandle+ hSetBuffering originalHandle LineBuffering+ return realHandle++ clean realHandle = do+ hFlush originalHandle+ hDuplicateTo realHandle originalHandle+ hClose realHandle++-- | Thread to read from the intercepted stdout pipe and forward onwards+forwardingThread :: (T.Text -> IO ()) -> Handle -> IO ()+forwardingThread write_action fromPipe = forever $ do+ line <- T.hGetLine fromPipe+ write_action line+++withPipe :: (Handle -> Handle -> IO r) -> IO r+withPipe action = bracket createPipe closeBoth (uncurry action)+ where+ closeBoth (readH, writeH) = do+ hClose readH+ hClose writeH+
+ hdb/Development/Debug/Adapter/Init.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | TODO: This module should be called Launch.+module Development.Debug.Adapter.Init where++import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified System.Process as P+import Data.Function+import Data.Functor+import Data.Version (Version(..), showVersion, makeVersion)+import Control.Monad.IO.Class+import System.IO+import GHC.IO.Encoding+import Control.Monad.Catch+import Control.Exception (SomeAsyncException, throwIO)+import Control.Concurrent+import Control.Monad+import Data.Aeson as Aeson+import GHC.Generics+import System.Directory++import Development.Debug.Adapter+import Development.Debug.Adapter.Exit+import Development.Debug.Adapter.Flags+import Development.Debug.Adapter.Logger+import qualified Development.Debug.Adapter.Output as Output++import qualified GHC.Debugger as Debugger+import qualified GHC.Debugger.Monad as Debugger+import qualified GHC.Debugger.Interface.Messages as D (Command, Response)+import GHC.Debugger.Interface.Messages hiding (Command, Response)++import DAP+import Development.Debug.Adapter.Handles++--------------------------------------------------------------------------------+-- * Client+--------------------------------------------------------------------------------++-- | Client arguments are custom for launch+data LaunchArgs+ = LaunchArgs+ { __sessionId :: Maybe String+ -- ^ SessionID, set by VSCode client+ , projectRoot :: FilePath+ -- ^ Absolute path to the project root+ , entryFile :: FilePath+ -- ^ The file with the entry point e.g. @app/Main.hs@+ , entryPoint :: String+ -- ^ Either @main@ or a function name+ , entryArgs :: [String]+ -- ^ The arguments to either set as environment arguments when @entryPoint = "main"@+ -- or function arguments otherwise.+ , extraGhcArgs :: [String]+ -- ^ Additional arguments to pass to the GHC invocation inferred by hie-bios for this project+ } deriving stock (Show, Eq, Generic)+ deriving anyclass FromJSON++--------------------------------------------------------------------------------+-- * Launch Debugger+--------------------------------------------------------------------------------++-- | Initialize debugger+--+-- Returns @True@ if successful.+initDebugger :: LogAction IO (WithSeverity T.Text) -> LaunchArgs -> DebugAdaptor Bool+initDebugger l LaunchArgs{__sessionId, projectRoot, entryFile, entryPoint, entryArgs, extraGhcArgs} = do+ syncRequests <- liftIO newEmptyMVar+ syncResponses <- liftIO newEmptyMVar+ let hieBiosLogger = cmapWithSev renderPretty l+ cradle <- liftIO (hieBiosCradle hieBiosLogger projectRoot entryFile) >>=+ \ case+ Left e ->+ exitWithMsg e++ Right c -> pure c++ Output.console $ T.pack "Checking GHC version against debugger version..."+ -- GHC is found in PATH (by hie-bios as well).+ actualVersion <- liftIO (hieBiosRuntimeGhcVersion hieBiosLogger cradle) >>=+ \ case+ Left e ->+ exitWithMsg e+ Right c -> pure c+ -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1):+ when (compileTimeGhcWithoutPatchVersion /= forgetPatchVersion actualVersion) $ do+ exitWithMsg $ "Aborting...! The GHC version must be the same which " +++ "ghc-debug-adapter was compiled against (" +++ showVersion compileTimeGhcWithoutPatchVersion+++ "). Instead, got " ++ (showVersion actualVersion) ++ "."++ Output.console $ T.pack "Discovering session flags with hie-bios..."+ mflags <- liftIO (hieBiosFlags hieBiosLogger cradle projectRoot entryFile)+ case mflags of+ Left e -> exitWithMsg e+ Right flags -> do++ let nextFreshBreakpointId = 0+ breakpointMap = mempty+ defaultRunConf = Debugger.RunDebuggerSettings+ { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap+ , supportsANSIHyperlinks = False -- VSCode does not support this+ }+++ -- Create pipes to read/write the debugger (not debuggee's) output.+ -- The write end is given to `runDebugger` and the read end is continuously+ -- read from until we read an EOF.+ (readDebuggerOutput, writeDebuggerOutput) <- liftIO P.createPipe+ liftIO $ do+ hSetBuffering readDebuggerOutput NoBuffering+ hSetBuffering writeDebuggerOutput NoBuffering+ -- GHC output uses utf8+ hSetEncoding readDebuggerOutput utf8+ hSetEncoding writeDebuggerOutput utf8+ setLocaleEncoding utf8++ finished_init <- liftIO $ newEmptyMVar++ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{..}+ [ debuggerThread finished_init writeDebuggerOutput projectRoot flags extraGhcArgs entryFile defaultRunConf syncRequests syncResponses+ , handleDebuggerOutput readDebuggerOutput+ , stdoutCaptureThread+ , stderrCaptureThread+ ]++ -- Do not return until the initialization is finished+ liftIO (takeMVar finished_init) >>= \case+ Right () -> return True+ 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.+ exitCleanupWithMsg readDebuggerOutput e+ return False++-- | This thread captures stdout from the debugger and sends it to the client.+-- NOTE, redirecting the stdout handle is a process-global operation. So this thread+-- will capture ANY stdout the debugger emits. Therefore you should never directly+-- write to stdout, but always write to the appropiate handle.+stdoutCaptureThread :: (DebugAdaptorCont () -> IO ()) -> IO ()+stdoutCaptureThread withAdaptor = do+ withInterceptedStdout $ \_ interceptedStdout -> do+ forever $ do+ line <- liftIO $ T.hGetLine interceptedStdout+ withAdaptor $ Output.stdout line++-- | Like 'stdoutCaptureThread' but for stderr+stderrCaptureThread :: (DebugAdaptorCont () -> IO ()) -> IO ()+stderrCaptureThread withAdaptor = do+ withInterceptedStderr $ \_ interceptedStderr -> do+ forever $ do+ line <- liftIO $ T.hGetLine interceptedStderr+ withAdaptor $ Output.stderr line++-- | The main debugger thread launches a GHC.Debugger session.+--+-- Then, forever:+-- 1. Reads commands from the given 'D.Command' 'MVar'+-- 2. Executes the command with `execute`+-- 3. Writes responses to the given 'D.Response' 'MVar'+--+-- 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 :: MVar (Either String ()) -- ^ To signal when initialization is complete.+ -> Handle -- ^ The write end of a handle for debug compiler output+ -> FilePath -- ^ Working directory for GHC session+ -> HieBiosFlags -- ^ GHC Invocation flags+ -> [String] -- ^ Extra ghc args+ -> FilePath+ -> Debugger.RunDebuggerSettings -- ^ Settings for running the debugger+ -> MVar D.Command -- ^ Read commands+ -> MVar D.Response -- ^ Write reponses+ -> (DebugAdaptorCont () -> IO ())+ -- ^ Allows unlifting DebugAdaptor actions to IO. See 'registerNewDebugSession'.+ -> IO ()+debuggerThread finished_init writeDebuggerOutput workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do++ let finalGhcInvocation = ghcInvocation ++ extraGhcArgs++ -- See Notes (CWD) above+ setCurrentDirectory workDir++ -- Log haskell-debugger invocation+ withAdaptor $+ Output.console $ T.pack $+ "libdir: " <> libdir <> "\n" <>+ "units: " <> unwords units <> "\n" <>+ "args: " <> unwords finalGhcInvocation++ catches+ (do+ Debugger.runDebugger writeDebuggerOutput rootDir componentDir libdir units finalGhcInvocation mainFp runConf $ do+ liftIO $ signalInitialized (Right ())++ forever $ 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 m)++-- | Reads from the read end of the handle to which the GHC debugger writes compiler messages.+-- Writes the compiler messages to the client console+handleDebuggerOutput :: Handle+ -> (DebugAdaptorCont () -> IO ())+ -> IO ()+handleDebuggerOutput readDebuggerOutput withAdaptor = do++ -- Mask exceptions to avoid being killed between reading a line and outputting it.+ (forever $ mask_ $ do+ line <- T.hGetLine readDebuggerOutput+ withAdaptor $ Output.neutral line+ ) `catch` -- handles read EOF+ \(_e::SomeException) ->+ -- Cleanly exit when readDebuggerOutput is closed or thread is killed.+ return ()++compileTimeGhcWithoutPatchVersion :: Version+compileTimeGhcWithoutPatchVersion =+ let+ versionNumber = __GLASGOW_HASKELL__ :: Int+ (major, minor) = divMod versionNumber 100+ in+ makeVersion [major, minor]++forgetPatchVersion :: Version -> Version+forgetPatchVersion v = case versionBranch v of+ (major:minor:_patches) -> makeVersion [major, minor]+ _ -> v
+ hdb/Development/Debug/Adapter/Interface.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE LambdaCase, RecordWildCards #-}+module Development.Debug.Adapter.Interface where++import qualified Data.Text as T+import Control.Concurrent.MVar+import Control.Monad.IO.Class++import DAP++import GHC.Debugger.Interface.Messages as D+import Development.Debug.Adapter+import qualified Development.Debug.Adapter.Output as Output++-- | Synchronously send a command to the debugger and await a response+sendSync :: D.Command -> DebugAdaptor Response+sendSync cmd = do+ DAS{..} <- getDebugSession+ liftIO $ putMVar syncRequests cmd+ liftIO (takeMVar syncResponses) >>= handleAbort++-- | Sends a command to the debugger, then runs the given action, and only after running the action it waits for the result of the debugger+sendInterleaved :: D.Command -> DebugAdaptor () -> DebugAdaptor Response+sendInterleaved cmd action = do+ DAS{..} <- getDebugSession+ liftIO $ putMVar syncRequests cmd+ () <- action+ liftIO (takeMVar syncResponses) >>= handleAbort++handleAbort :: Response -> DebugAdaptor Response+handleAbort (Aborted e) = do+ Output.console (T.pack e)+ sendTerminatedEvent defaultTerminatedEvent+ return (Aborted e) -- will TerminatedEvent terminate this session before this happens?+handleAbort r = return r+
+ hdb/Development/Debug/Adapter/Logger.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Simple Logger API using co-log style loggers+module Development.Debug.Adapter.Logger (+ LogAction (..),+ Severity (..),+ WithSeverity (..),+ cmap,+ cmapIO,+ cmapWithSev,++ -- * Pretty printing of logs+ renderPrettyWithSeverity,+ renderWithSeverity,+ renderPretty,+ renderSeverity,+ renderWithTimestamp,+) where++import Control.Monad.IO.Class+import Control.Monad ((>=>))+import Colog.Core (LogAction (..), Severity (..), WithSeverity (..))+import Colog.Core.Action (cmap)+import Data.Text (Text)+import qualified Data.Text as T+import Prettyprinter+import Prettyprinter.Render.Text (renderStrict)+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)++cmapWithSev :: (a -> b) -> LogAction m (WithSeverity b) -> LogAction m (WithSeverity a)+cmapWithSev f = cmap (fmap f)++cmapIO :: MonadIO m => (a -> IO b) -> LogAction m b -> LogAction m a+cmapIO f LogAction{ unLogAction } =+ LogAction+ { unLogAction = (liftIO . f) >=> unLogAction }++renderPrettyWithSeverity :: Pretty a => WithSeverity a -> Text+renderPrettyWithSeverity =+ renderWithSeverity renderPretty++renderWithSeverity :: (a -> Text) -> WithSeverity a -> Text+renderWithSeverity f msgWithSev =+ renderSeverity (getSeverity msgWithSev) <> " " <> f (getMsg msgWithSev)++renderPretty :: Pretty a => a -> Text+renderPretty a =+ let+ docToText = renderStrict . layoutPretty defaultLayoutOptions+ in+ docToText (pretty a)++renderWithTimestamp :: Text -> IO Text+renderWithTimestamp msg = do+ t <- getCurrentTime+ let timeStamp = utcTimeToText t+ pure $ "[" <> timeStamp <> "]" <> msg+ where+ utcTimeToText utcTime = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime++renderSeverity :: Severity -> Text+renderSeverity = \ case+ Debug -> "[DEBUG]"+ Info -> "[INFO]"+ Warning -> "[WARNING]"+ Error -> "[ERROR]"
+ hdb/Development/Debug/Adapter/Output.hs view
@@ -0,0 +1,55 @@+-- | Meant to be imported qualified:+--+-- @+-- import qualified Development.Debugger.Output as Output+--+-- Output.console "Category used for informational output from debugger, not debuggee"+-- Output.stdout "Standard out of debuggee"+-- Output.stderr "Standard err of debuggee"+-- ...+-- @+--+-- TODO:+-- [ ] ANSI Styling of output console messages?+--+module Development.Debug.Adapter.Output+ ( neutral, console, important, stdout, stderr )+ where++import Data.Text (Text)+import qualified Data.Text as T+import DAP (sendOutputEvent, defaultOutputEvent, OutputEvent(..), OutputEventCategory(..))+import Development.Debug.Adapter++-- | Default 'OutputEvent' without an explicit category.+neutral :: Text -> DebugAdaptorX r+neutral = send Nothing++-- | Show the output in the client's default message UI, e.g. a 'debug+-- console'. This category should only be used for informational output from+-- the debugger (as opposed to the debuggee).+console :: Text -> DebugAdaptorX r+console = send $ Just OutputEventCategoryConsole++-- | 'important': A hint for the client to show the output in the client's UI+-- for important and highly visible information, e.g. as a popup notification.+-- This category should only be used for important messages from the debugger+-- (as opposed to the debuggee).+important :: Text -> DebugAdaptorX r+important = send $ Just OutputEventCategoryImportant++-- | Show the output as normal program output from the debuggee.+stdout :: Text -> DebugAdaptorX r+stdout = send $ Just OutputEventCategoryStdout++-- | Show the output as error program output from the debuggee.+stderr :: Text -> DebugAdaptorX r+stderr = send $ Just OutputEventCategoryStderr++-- | Generic send output event given the category+send :: Maybe OutputEventCategory -> Text -> DebugAdaptorX r+send cat txt = do+ sendOutputEvent defaultOutputEvent+ { outputEventCategory = cat+ , outputEventOutput = txt <> T.pack "\n"+ }
+ hdb/Development/Debug/Adapter/Stepping.hs view
@@ -0,0 +1,31 @@+module Development.Debug.Adapter.Stepping where++import DAP++import GHC.Debugger.Interface.Messages hiding (Command, Response)++import Development.Debug.Adapter+import Development.Debug.Adapter.Interface+import Development.Debug.Adapter.Evaluation++commandContinue :: DebugAdaptor ()+commandContinue = do+ DidContinue er <- sendInterleaved DoContinue $+ sendContinueResponse (ContinueResponse True)+ handleEvalResult False er++commandNext :: DebugAdaptor ()+commandNext = do+ DidStep er <- sendInterleaved DoStepLocal sendNextResponse+ handleEvalResult True er++commandStepIn :: DebugAdaptor ()+commandStepIn = do+ DidStep er <- sendInterleaved DoSingleStep sendStepInResponse+ handleEvalResult True er++commandStepOut :: DebugAdaptor ()+commandStepOut = do+ DidStep er <- sendInterleaved DoStepOut sendStepOutResponse+ handleEvalResult True er+
+ hdb/Development/Debug/Adapter/Stopped.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE RecordWildCards, OverloadedRecordDot, OverloadedStrings, LambdaCase #-}++-- | Getting information about where we're stopped at (current suspended state).+--+-- Includes the commands to execute the following requests on the debuggee state:+-- +-- @+-- Threads+-- StackTrace+-- Scopes+-- Variables+-- ...+-- Variables+-- @+module Development.Debug.Adapter.Stopped where++import qualified Data.Text as T++import DAP++import GHC.Debugger.Interface.Messages+import Development.Debug.Adapter+import Development.Debug.Adapter.Interface++--------------------------------------------------------------------------------+-- * StackTrace+--------------------------------------------------------------------------------++-- | Command to get thread information at current stopped point+commandThreads :: DebugAdaptor ()+commandThreads = do -- TODO+ sendThreadsResponse [+ Thread+ { threadId = 0+ , threadName = T.pack "dummy thread"+ }+ ]++--------------------------------------------------------------------------------+-- * StackTrace+--------------------------------------------------------------------------------++-- | Command to fetch stack trace at current stop point+commandStackTrace :: DebugAdaptor ()+commandStackTrace = do+ StackTraceArguments{..} <- getArguments+ GotStacktrace fs <- sendSync GetStacktrace+ case fs of+ [] ->+ -- No frames; should be stopped on exception+ sendStackTraceResponse StackTraceResponse { stackFrames = [], totalFrames = Nothing }+ [f] -> do+ source <- fileToSource f.sourceSpan.file+ let+ topStackFrame = defaultStackFrame+ { stackFrameId = 0+ , stackFrameName = T.pack f.name+ , stackFrameLine = f.sourceSpan.startLine+ , stackFrameColumn = f.sourceSpan.startCol+ , stackFrameEndLine = Just f.sourceSpan.endLine+ , stackFrameEndColumn = Just f.sourceSpan.endCol+ , stackFrameSource = Just source+ }+ sendStackTraceResponse StackTraceResponse+ { stackFrames = [topStackFrame]+ , totalFrames = Just 1+ }+ _ -> error $ "Unexpected multiple frames since implementation doesn't support it yet: " ++ show fs+++--------------------------------------------------------------------------------+-- * Scopes+--------------------------------------------------------------------------------++-- | Command to get scopes for current stopped point+commandScopes :: DebugAdaptor ()+commandScopes = do+ ScopesArguments{scopesArgumentsFrameId=0} <- getArguments+ GotScopes scopes <- sendSync GetScopes+ sendScopesResponse . ScopesResponse =<<+ mapM scopeInfoToScope scopes++-- | 'ScopeInfo' to 'Scope'+scopeInfoToScope :: ScopeInfo -> DebugAdaptor Scope+scopeInfoToScope ScopeInfo{..} = do+ source <- fileToSource sourceSpan.file+ return defaultScope+ { scopeName = case kind of+ LocalVariablesScope -> "Locals"+ ModuleVariablesScope -> "Module"+ GlobalVariablesScope -> "Globals"+ , scopePresentationHint = Just $ case kind of+ LocalVariablesScope -> ScopePresentationHintLocals+ ModuleVariablesScope -> ScopePresentationHint "module"+ GlobalVariablesScope -> ScopePresentationHint "globals"+ , scopeNamedVariables = numVars+ , scopeSource = Just source+ , scopeLine = Just sourceSpan.startLine+ , scopeColumn = Just sourceSpan.startCol+ , scopeEndLine = Just sourceSpan.endLine+ , scopeEndColumn = Just sourceSpan.endCol+ , scopeVariablesReference = fromEnum (scopeToVarRef kind)+ }++--------------------------------------------------------------------------------+-- * Variables+--------------------------------------------------------------------------------++-- | Command to get variables by reference number+commandVariables :: DebugAdaptor ()+commandVariables = do+ VariablesArguments{..} <- getArguments+ let vk = toEnum variablesArgumentsVariablesReference+ GotVariables vars <- sendSync (GetVariables vk)+ sendVariablesResponse $ VariablesResponse $+ map varInfoToVariables (either (:[]) id vars)+ case vars of+ -- If the reply indicates this was an "inspect lazy variable" request+ -- (because the requested variable was forced instead of returning an+ -- expansion), invalidate the parent variables.+ --+ -- The client side seems to handle rendering only the bits which changed+ -- out very well, while preserving the variable tree expansion.+ -- In any case, we might have to pessimistically redo all variable+ -- responses because any value may be changed by an updated thunk, not only+ -- the parent variables.+ Left _+ -> sendInvalidatedEvent defaultInvalidatedEvent+ { invalidatedEventAreas = [InvalidatedAreasVariables]+ , invalidatedEventStackFrameId = Just 0 -- we only support one stack frame for now (TODO).+ }+ _ -> return ()++-- | 'VarInfo' to 'Variable's.+--+-- Note that if 'VarInfo' is a nested structure, only the top-most VarInfo is+-- returned (with the according namedVariables and indexedVariables sizes).+--+-- The @'varFields'@ are ignored. If they are meant to be returned, they should+-- be matched against and returned explicitly (see @'getVariables'@).+varInfoToVariables :: VarInfo -> Variable+varInfoToVariables VarInfo{..} =+ defaultVariable+ { variableName = T.pack varName+ , variableValue = T.pack varValue+ , variableType = Just $ T.pack varType+ , variableEvaluateName = Just $ T.pack varName+ , variableVariablesReference = fromEnum varRef+ , variableNamedVariables = Nothing+ , variableIndexedVariables = Nothing+ , variablePresentationHint = Just defaultVariablePresentationHint+ { variablePresentationHintLazy = Just isThunk+ }+ }++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++-- | From 'ScopeVariablesReference' to a 'VariableReference' that can be used in @"variable"@ requests+scopeToVarRef :: ScopeVariablesReference -> VariableReference+scopeToVarRef = \case+ LocalVariablesScope -> LocalVariables+ ModuleVariablesScope -> ModuleVariables+ GlobalVariablesScope -> GlobalVariables+
+ hdb/Main.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, CPP, DeriveAnyClass, DeriveGeneric, DerivingVia, LambdaCase, RecordWildCards, ViewPatterns #-}+module Main where++import System.Environment+import Data.Maybe+import Text.Read++import DAP++import Development.Debug.Adapter.Init+import Development.Debug.Adapter.Breakpoints+import Development.Debug.Adapter.Stepping+import Development.Debug.Adapter.Stopped+import Development.Debug.Adapter.Evaluation+import Development.Debug.Adapter.Exit+import Development.Debug.Adapter.Handles+import Development.Debug.Adapter.Logger+import Development.Debug.Adapter++import System.IO (hSetBuffering, BufferMode(LineBuffering))+import DAP.Log+import qualified Data.Text as T+import qualified Data.Text.IO as T+import GHC.IO.Handle.FD++defaultStdoutForwardingAction :: T.Text -> IO ()+defaultStdoutForwardingAction line = do+ T.hPutStrLn stderr ("[INTERCEPTED STDOUT] " <> line)++main :: IO ()+main = do+ port <- getArgs >>= \case+ ["--server", "--port", readMaybe -> Just p] -> return p+ _ -> fail "usage: --server --port <port>"+ config <- getConfig port+ withInterceptedStdoutForwarding defaultStdoutForwardingAction $ \realStdout -> do+ hSetBuffering realStdout LineBuffering+ l <- handleLogger realStdout+ let+ timeStampLogger = cmapIO renderWithTimestamp l+ loggerWithSev = cmap (renderWithSeverity id) timeStampLogger+ runDAPServerWithLogger (cmap renderDAPLog timeStampLogger) config (talk loggerWithSev)++-- | Fetch config from environment, fallback to sane defaults+getConfig :: Int -> IO ServerConfig+getConfig port = do+ let+ hostDefault = "0.0.0.0"+ portDefault = port+ capabilities = defaultCapabilities+ { -- Exception breakpoints!+ exceptionBreakpointFilters = [ defaultExceptionBreakpointsFilter+ { exceptionBreakpointsFilterLabel = "All exceptions"+ , exceptionBreakpointsFilterFilter = BREAK_ON_EXCEPTION+ }+ , defaultExceptionBreakpointsFilter+ { exceptionBreakpointsFilterLabel = "Uncaught exceptions"+ , exceptionBreakpointsFilterFilter = BREAK_ON_ERROR+ }+ ]+ -- Function breakpoints!+ , supportsFunctionBreakpoints = True++ , supportsEvaluateForHovers = False++ -- display which breakpoints are valid when user intends to set+ -- breakpoint on given line.+ , supportsBreakpointLocationsRequest = True+ , supportsConfigurationDoneRequest = True+ , supportsHitConditionalBreakpoints = False+ , supportsModulesRequest = False+ , additionalModuleColumns = [ defaultColumnDescriptor+ { columnDescriptorAttributeName = "Extra"+ , columnDescriptorLabel = "Label"+ }+ ]+ , supportsValueFormattingOptions = True+ , supportTerminateDebuggee = True+ , supportsLoadedSourcesRequest = False+ , supportsExceptionOptions = True+ , supportsExceptionFilterOptions = False+ }+ ServerConfig+ <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST"+ <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT"+ <*> pure capabilities+ <*> pure True++--------------------------------------------------------------------------------+-- * Talk+--------------------------------------------------------------------------------++-- | Main function where requests are received and Events + Responses are returned.+-- The core logic of communicating between the client <-> adaptor <-> debugger+-- is implemented in this function.+talk :: LogAction IO (WithSeverity T.Text) -> Command -> DebugAdaptor ()+--------------------------------------------------------------------------------+talk l = \ case+ CommandInitialize -> do+ -- InitializeRequestArguments{..} <- getArguments+ sendInitializeResponse+--------------------------------------------------------------------------------+ CommandLaunch -> do+ success <- initDebugger l =<< getArguments+ if success then do+ sendLaunchResponse -- ack+ sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session+ else+ sendError ErrorMessageCancelled Nothing+--------------------------------------------------------------------------------+ CommandAttach -> undefined+--------------------------------------------------------------------------------+ CommandBreakpointLocations -> commandBreakpointLocations+ CommandSetBreakpoints -> commandSetBreakpoints+ CommandSetFunctionBreakpoints -> commandSetFunctionBreakpoints+ CommandSetExceptionBreakpoints -> commandSetExceptionBreakpoints+ CommandSetDataBreakpoints -> undefined+ CommandSetInstructionBreakpoints -> undefined+----------------------------------------------------------------------------+ CommandLoadedSources -> undefined+----------------------------------------------------------------------------+ CommandConfigurationDone -> do+ sendConfigurationDoneResponse+ -- now that it has been configured, start executing until it halts, then send an event+ startExecution >>= handleEvalResult False+----------------------------------------------------------------------------+ CommandThreads -> commandThreads+ CommandStackTrace -> commandStackTrace+ CommandScopes -> commandScopes+ CommandVariables -> commandVariables+----------------------------------------------------------------------------+ CommandContinue -> commandContinue+----------------------------------------------------------------------------+ CommandNext -> commandNext+----------------------------------------------------------------------------+ CommandStepIn -> commandStepIn+ CommandStepOut -> commandStepOut+----------------------------------------------------------------------------+ CommandEvaluate -> commandEvaluate+----------------------------------------------------------------------------+ CommandTerminate -> commandTerminate+ CommandDisconnect -> commandDisconnect+----------------------------------------------------------------------------+ CommandModules -> sendModulesResponse (ModulesResponse [] Nothing)+ CommandSource -> undefined+ CommandPause -> undefined+ (CustomCommand "mycustomcommand") -> undefined+----------------------------------------------------------------------------+-- talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd)+----------------------------------------------------------------------------
+ test/haskell/Main.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."