diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + +![CI badge](https://github.com/well-typed/haskell-debugger/actions/workflows/debugger.yaml/badge.svg) ![Hackage badge](https://img.shields.io/hackage/v/haskell-debugger.svg) + +# 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) +``` diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal new file mode 100644 --- /dev/null +++ b/haskell-debugger.cabal @@ -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 diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger.hs @@ -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 + diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -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) diff --git a/haskell-debugger/GHC/Debugger/Evaluation.hs b/haskell-debugger/GHC/Debugger/Evaluation.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Evaluation.hs @@ -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 + diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -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 + + diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -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 _ _ = [] diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Stopped.hs @@ -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. +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. + +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 diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -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' diff --git a/haskell-debugger/GHC/Debugger/Utils.hs b/haskell-debugger/GHC/Debugger/Utils.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Utils.hs @@ -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 #-} + diff --git a/hdb/Development/Debug/Adapter.hs b/hdb/Development/Debug/Adapter.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter.hs @@ -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)} + diff --git a/hdb/Development/Debug/Adapter/Breakpoints.hs b/hdb/Development/Debug/Adapter/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Breakpoints.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Evaluation.hs b/hdb/Development/Debug/Adapter/Evaluation.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Evaluation.hs @@ -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) + } + diff --git a/hdb/Development/Debug/Adapter/Exit.hs b/hdb/Development/Debug/Adapter/Exit.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Exit.hs @@ -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 + + diff --git a/hdb/Development/Debug/Adapter/Flags.hs b/hdb/Development/Debug/Adapter/Flags.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Flags.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Handles.hs b/hdb/Development/Debug/Adapter/Handles.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Handles.hs @@ -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 + diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Interface.hs b/hdb/Development/Debug/Adapter/Interface.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Interface.hs @@ -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 + diff --git a/hdb/Development/Debug/Adapter/Logger.hs b/hdb/Development/Debug/Adapter/Logger.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Logger.hs @@ -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]" diff --git a/hdb/Development/Debug/Adapter/Output.hs b/hdb/Development/Debug/Adapter/Output.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Output.hs @@ -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" + } diff --git a/hdb/Development/Debug/Adapter/Stepping.hs b/hdb/Development/Debug/Adapter/Stepping.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Stepping.hs @@ -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 + diff --git a/hdb/Development/Debug/Adapter/Stopped.hs b/hdb/Development/Debug/Adapter/Stopped.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Stopped.hs @@ -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 + diff --git a/hdb/Main.hs b/hdb/Main.hs new file mode 100644 --- /dev/null +++ b/hdb/Main.hs @@ -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 " + 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) +---------------------------------------------------------------------------- diff --git a/test/haskell/Main.hs b/test/haskell/Main.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."