diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ghc-debugger + +## 0.1.0.0 -- YYYY-mm-dd + +* 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,120 @@ +# 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/ghc-debugger/actions/workflows/debugger.yaml/badge.svg) ![Hackage badge](https://img.shields.io/hackage/v/ghc-debugger.svg) + +# Installation + +> [!WARNING] +> `ghc-debug-adapter` 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 `ghc-debug-adapter` +and the VSCode extension `haskell-debugger-extension`. + +Since `ghc-debug-adapter` 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 `ghc-debug-adapter` configured. + +To build, install, and run `ghc-debug-adapter` 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 exe:ghc-debug-adapter --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 + +`ghc-debug-adapter` is inspired by the original +[`haskell-debug-adapter`](https://github.com/phoityne/haskell-debug-adapter/) by @phoityne. + +`ghc-debug-adapter` 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 `ghc-debug-adapter` 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 `ghc-debug-adapter` 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) +- [ ] 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) diff --git a/ghc-debug-adapter/Development/Debug/Adapter.hs b/ghc-debug-adapter/Development/Debug/Adapter.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/Development/Debug/Adapter.hs @@ -0,0 +1,55 @@ +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 + , breakpointMap :: Map.Map GHC.BreakpointId BreakpointSet + , 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/ghc-debug-adapter/Development/Debug/Adapter/Breakpoints.hs b/ghc-debug-adapter/Development/Debug/Adapter/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/Development/Debug/Adapter/Breakpoints.hs @@ -0,0 +1,153 @@ +{-# 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 ghc-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 + bid <- registerNewBreakpoint iid + source <- fileToSource ss.file + 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 + } ] + +-- | Adds new BreakpointId for a givent StgPoint +registerNewBreakpoint :: GHC.BreakpointId -> DebugAdaptor BreakpointId +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/ghc-debug-adapter/Development/Debug/Adapter/Evaluation.hs b/ghc-debug-adapter/Development/Debug/Adapter/Evaluation.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/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/ghc-debug-adapter/Development/Debug/Adapter/Exit.hs b/ghc-debug-adapter/Development/Debug/Adapter/Exit.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/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 ghc-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 ghc-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 () +exitWithMsg msg = do + Output.important (T.pack msg) + exitCleanly + +exitCleanly :: DebugAdaptor () +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/ghc-debug-adapter/Development/Debug/Adapter/Flags.hs b/ghc-debug-adapter/Development/Debug/Adapter/Flags.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/Development/Debug/Adapter/Flags.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP, RecordWildCards, LambdaCase #-} +module Development.Debug.Adapter.Flags where + +import Data.Maybe +import Data.Function +import System.FilePath +import System.Directory +import Control.Monad.Except +import Control.Monad.IO.Class + +import qualified Data.List as L + +import qualified HIE.Bios as HIE +import qualified HIE.Bios.Types as HIE +import qualified HIE.Bios.Environment as HIE + +-- | Flags inferred by @hie-bios@ to invoke GHC +data HieBiosFlags = HieBiosFlags + { ghcInvocation :: [String] + , libdir :: FilePath + , units :: [String] + } + +-- | Make 'HieBiosFlags' from the given target file +hieBiosFlags :: FilePath {-^ Project root -} -> FilePath {-^ Entry file relative to root -} -> IO (Either String HieBiosFlags) +hieBiosFlags root relTarget = runExceptT $ do + + let target = root relTarget + + explicitCradle <- HIE.findCradle target & liftIO + cradle <- maybe (HIE.loadImplicitCradle mempty target) + (HIE.loadCradle mempty) explicitCradle & liftIO + + 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.LoadFile cradle +#else + HIE.getCompilerOptions target [] cradle +#endif + HIE.ComponentOptions {HIE.componentOptions = flags} <- 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 + + return HieBiosFlags + { ghcInvocation = [ relTarget | not $ any (`L.isSuffixOf` target) flags ] ++ -- TODO is this correct? else, the debugger won't work on single files. + flags ++ ghcDebuggerFlags + , libdir = libdir + , units = mapMaybe (\case ("-unit", u) -> Just u; _ -> Nothing) $ zip flags (drop 1 flags) + } + where + 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 + +-- | Flags specific to ghc-debugger to append to all GHC invocations. +ghcDebuggerFlags :: [String] +ghcDebuggerFlags = + [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt + ] diff --git a/ghc-debug-adapter/Development/Debug/Adapter/Handles.hs b/ghc-debug-adapter/Development/Debug/Adapter/Handles.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/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/ghc-debug-adapter/Development/Debug/Adapter/Init.hs b/ghc-debug-adapter/Development/Debug/Adapter/Init.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/Development/Debug/Adapter/Init.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE CPP, LambdaCase, OverloadedStrings, RecordWildCards, DerivingStrategies, DeriveGeneric, DeriveAnyClass #-} + +-- | TODO: This module should be called Launch. +module Development.Debug.Adapter.Init where + +import qualified Data.List as L +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 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 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 :: LaunchArgs -> DebugAdaptor Bool +initDebugger LaunchArgs{__sessionId, projectRoot, entryFile, entryPoint, entryArgs, extraGhcArgs} = do + syncRequests <- liftIO newEmptyMVar + syncResponses <- liftIO newEmptyMVar + + Output.console $ T.pack "Checking GHC version against debugger version..." + -- GHC is found in PATH (by hie-bios as well). + actualVersion <- liftIO $ P.readProcess "ghc" ["--numeric-version"] [] + -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1): + when (not $ show __GLASGOW_HASKELL__ `L.isPrefixOf` (filter (/= '.') actualVersion)) $ do + exitWithMsg $ "Aborting...! The GHC version must be the same which " ++ + "ghc-debug-adapter was compiled against (" ++ + show __GLASGOW_HASKELL__ ++ + "). Instead, got " ++ (init{-drops \n-} actualVersion) ++ "." + + Output.console $ T.pack "Discovering session flags with hie-bios..." + mflags <- liftIO (hieBiosFlags projectRoot entryFile) + case mflags of + Left e -> do exitWithMsg e + return False + 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 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 + -> 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 runConf requests replies withAdaptor = do + + let finalGhcInvocation = ghcInvocation ++ extraGhcArgs + + -- See Notes (CWD) above + setCurrentDirectory workDir + + -- Log ghc-debugger invocation + withAdaptor $ + Output.console $ T.pack $ + "libdir: " <> libdir <> "\n" <> + "units: " <> unwords units <> "\n" <> + "args: " <> unwords finalGhcInvocation + + catches + (do + Debugger.runDebugger writeDebuggerOutput libdir units finalGhcInvocation 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 () diff --git a/ghc-debug-adapter/Development/Debug/Adapter/Interface.hs b/ghc-debug-adapter/Development/Debug/Adapter/Interface.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/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/ghc-debug-adapter/Development/Debug/Adapter/Output.hs b/ghc-debug-adapter/Development/Debug/Adapter/Output.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/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/ghc-debug-adapter/Development/Debug/Adapter/Stepping.hs b/ghc-debug-adapter/Development/Debug/Adapter/Stepping.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/Development/Debug/Adapter/Stepping.hs @@ -0,0 +1,30 @@ +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 = -- undefined -- #6 + commandStepIn -- TODO this is just a stub + diff --git a/ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs b/ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs @@ -0,0 +1,170 @@ +{-# 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 = case varFields of + LabeledFields xs -> Just $ length xs + _ -> Nothing + , variableIndexedVariables = case varFields of + IndexedFields xs -> Just $ length xs + _ -> 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/ghc-debug-adapter/Main.hs b/ghc-debug-adapter/Main.hs new file mode 100644 --- /dev/null +++ b/ghc-debug-adapter/Main.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, CPP, DeriveAnyClass, DeriveGeneric, DerivingVia, LambdaCase, RecordWildCards, ViewPatterns #-} +module Main where + +import System.Environment +import System.Exit +import Data.Maybe +import Text.Read + +import DAP + +import GHC.Debugger.Interface.Messages hiding (Command, Response) + +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.Interface +import Development.Debug.Adapter.Exit +import Development.Debug.Adapter.Handles +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 + ["--port", readMaybe -> Just p] -> return p + _ -> fail "usage: --port " + config <- getConfig port + withInterceptedStdoutForwarding defaultStdoutForwardingAction $ \realStdout -> do + hSetBuffering realStdout LineBuffering + l <- handleLogger realStdout + runDAPServerWithLogger (cmap renderDAPLog l) config talk + +-- | 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 :: Command -> DebugAdaptor () +-------------------------------------------------------------------------------- +talk CommandInitialize = do + -- InitializeRequestArguments{..} <- getArguments + sendInitializeResponse +-------------------------------------------------------------------------------- +talk CommandLaunch = do + success <- initDebugger =<< 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 +-------------------------------------------------------------------------------- +talk CommandAttach = undefined +-------------------------------------------------------------------------------- +talk CommandBreakpointLocations = commandBreakpointLocations +talk CommandSetBreakpoints = commandSetBreakpoints +talk CommandSetFunctionBreakpoints = commandSetFunctionBreakpoints +talk CommandSetExceptionBreakpoints = commandSetExceptionBreakpoints +talk CommandSetDataBreakpoints = undefined +talk CommandSetInstructionBreakpoints = undefined +---------------------------------------------------------------------------- +talk CommandLoadedSources = undefined +---------------------------------------------------------------------------- +talk CommandConfigurationDone = do + sendConfigurationDoneResponse + -- now that it has been configured, start executing until it halts, then send an event + startExecution >>= handleEvalResult False +---------------------------------------------------------------------------- +talk CommandThreads = commandThreads +talk CommandStackTrace = commandStackTrace +talk CommandScopes = commandScopes +talk CommandVariables = commandVariables +---------------------------------------------------------------------------- +talk CommandContinue = commandContinue +---------------------------------------------------------------------------- +talk CommandNext = commandNext +---------------------------------------------------------------------------- +talk CommandStepIn = commandStepIn +talk CommandStepOut = commandStepOut +---------------------------------------------------------------------------- +talk CommandEvaluate = commandEvaluate +---------------------------------------------------------------------------- +talk CommandTerminate = commandTerminate +talk CommandDisconnect = commandDisconnect +---------------------------------------------------------------------------- +talk CommandModules = sendModulesResponse (ModulesResponse [] Nothing) +talk CommandSource = undefined +talk CommandPause = undefined +talk (CustomCommand "mycustomcommand") = undefined +---------------------------------------------------------------------------- +-- talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd) +---------------------------------------------------------------------------- diff --git a/ghc-debugger.cabal b/ghc-debugger.cabal new file mode 100644 --- /dev/null +++ b/ghc-debugger.cabal @@ -0,0 +1,106 @@ +cabal-version: 3.0 +name: ghc-debugger +version: 0.1.0.0 +synopsis: + A step-through machine-interface debugger for GHC Haskell + +description: The GHC debugger package provides a binary + @ghc-debug-adapter@ that implements the Debug Adapter + Protocol (DAP) for debugging Haskell programs. + . + The Debug Adapter is implemented on top of the + @ghc-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 @ghc-debug-adapter@ 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/ghc-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/ghc-debugger +bug-reports: https://github.com/well-typed/ghc-debugger/issues + +source-repository head + type: git + location: https://github.com/well-typed/ghc-debugger + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: GHC.Debugger, + GHC.Debugger.Monad, + GHC.Debugger.Interface.Messages + -- other-modules: + -- other-extensions: + build-depends: base > 4.21 && < 5, + ghc >= 9.13 && < 9.14, ghci >= 9.13 && < 9.14, + 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, + exceptions >= 0.10.9 && < 0.11, + bytestring >= 0.12.1 && < 0.13, + aeson >= 2.2.3 && < 2.3, + + hs-source-dirs: ghc-debugger + default-language: Haskell2010 + +executable ghc-debug-adapter + 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.Output, + Development.Debug.Adapter.Exit, + Development.Debug.Adapter.Handles, + Development.Debug.Adapter + build-depends: + base, ghc, + exceptions, aeson, bytestring, + containers, filepath, + process, mtl, unix, + + ghc-debugger, + + directory >= 1.3.9 && < 1.4, + async >= 2.2.5 && < 2.3, + text >= 2.1 && < 2.3, + dap >= 0.2 && < 1, + hie-bios >= 0.15 && < 0.16, + hs-source-dirs: ghc-debug-adapter + default-language: GHC2021 + ghc-options: -threaded + +test-suite ghc-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, + ghc-debugger diff --git a/ghc-debugger/GHC/Debugger.hs b/ghc-debugger/GHC/Debugger.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger.hs @@ -0,0 +1,709 @@ +{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase, + DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns, + TypeApplications, ScopedTypeVariables, BangPatterns #-} +module GHC.Debugger where + +import Prelude hiding (exp, span) +import System.Exit +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch +import Data.Bits (xor) + +import GHC +import GHC.Types.Unique.FM +import GHC.Types.Name.Reader +#if MIN_VERSION_ghc(9,13,20250417) +import GHC.Types.Name.Occurrence (sizeOccEnv) +#endif +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module.ModDetails +import GHC.Types.FieldLabel +import GHC.Types.TypeEnv +import GHC.Data.Maybe (expectJust) +import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS, mkUnboundName) +import GHC.Data.FastString +import GHC.Utils.Error (logOutput) +import GHC.Driver.DynFlags as GHC +import GHC.Driver.Env as GHC +import GHC.Driver.Monad +import GHC.Driver.Ppr as GHC +import GHC.Runtime.Debugger.Breakpoints as GHC +import GHC.Runtime.Eval.Types as GHC +import GHC.Runtime.Eval +import GHC.Core.DataCon +import GHC.Types.Breakpoint +import GHC.Types.Id as GHC +import GHC.Types.Name.Occurrence (mkVarOcc, mkVarOccFS) +import GHC.Types.Name.Reader as RdrName (mkOrig, globalRdrEnvElts, greName) +import GHC.Types.SrcLoc +import GHC.Tc.Utils.TcType +import GHC.Unit.Module.Env as GHC +import GHC.Utils.Outputable as GHC +import GHC.Utils.Misc (zipEqual) +import qualified GHC.Runtime.Debugger as GHCD +import qualified GHC.Runtime.Heap.Inspect as GHCI +import qualified GHCi.Message as GHCi +import qualified GHC.Unit.Home.Graph as HUG + +import Data.Maybe +import Control.Monad.Reader +import Data.IORef + +import GHC.Debugger.Monad +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 + DoStepLocal -> DidStep <$> doLocalStep + DebugExecution { entryPoint, runArgs } -> DidExec <$> debugExecution entryPoint runArgs + TerminateProcess -> liftIO $ do + -- Terminate! + exitWith ExitSuccess + +-------------------------------------------------------------------------------- +-- * 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 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 (BreakIndex, 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, span) -> do + let bid = BreakpointId { bi_tick_mod = ms_mod modl + , bi_tick_index = bix } + changed <- registerBreakpoint bid bp_status ModuleBreakpointKind + return $ BreakFound + { changed = changed + , sourceSpan = realSrcSpanToSourceSpan span + , breakId = bid + } +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, span) = do + let bid = BreakpointId { bi_tick_mod = modl + , bi_tick_index = bix } + changed <- registerBreakpoint bid bp_status FunctionBreakpointKind + return $ BreakFound + { changed = changed + , sourceSpan = realSrcSpanToSourceSpan span + , breakId = bid + } + case findBreakForBind fun_str 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) + +-------------------------------------------------------------------------------- +-- * 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 + 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 + +-- | 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 exp = do + excr <- (Right <$> GHC.execStmt exp 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} -> + return EvalStopped{breakId = toBreakpointId <$> breakPointId} + +{- +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 + hsc_env <- getSession + 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 +#if MIN_VERSION_ghc(9,13,20250417) + , numVars = Just (sizeOccEnv imported) +#else + , numVars = Nothing +#endif + , 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 -> error "lookupVarByReference failed" + Just (n, term) -> do + let ty = GHCI.termType term + term' <- if isBoringTy ty + then deepseqTerm term -- deepseq boring types like String, because it is more helpful to print them whole than their structure. + else seqTerm term + -- insertVarReference i n term' -- update with evaluated term? + vi <- termToVarInfo n term' + case term {- original term -} of + + -- (VARR)(b) + Suspension{} -> do + -- Original Term was a suspension: + -- It is a "lazy" DAP variable, so our reply can ONLY include + -- this single variable. So we erase the @varFields@ after the fact. + return (Left vi{varFields = NoFields}) + + -- (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 + case varFields vi of + 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 defaultDepth) =<< GHC.getBindings + + ModuleVariables -> Right <$> do + case ibi_tick_mod <$> GHC.resumeBreakpointId r of + Nothing -> return [] + Just curr_modl -> do + things <- typeEnvElts <$> getTopEnv curr_modl + mapM (\tt -> do + nameStr <- display (getName tt) + vi <- tyThingToVarInfo 1 tt + return vi{varName = nameStr}) things + + GlobalVariables -> Right <$> do + case ibi_tick_mod <$> GHC.resumeBreakpointId r of + Nothing -> return [] + Just curr_modl -> do + hsc_env <- getSession + 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 + , varFields = NoFields + } + Just tt -> do + vi <- tyThingToVarInfo 1 tt {- don't look deep for global and mod vars -} + return vi{varName = nameStr} + ) names + + NoVariables -> Right <$> do + return [] + +defaultDepth = 5 -- the depth determines how much of the structure is traversed. + -- using a small value like 5 here is what causes the + -- structure to be improperly rendered inline with many underscores. + -- Note: GHCi uses depth=100 + -- TODO: Investigate why this isn't fast enough to use 100. + -- TODO: We need a new metric to determine how much we force. + -- Depth is not good enough because e.g for a very broad + -- recursive type it will be exponentially many nodes to + -- visit + -- For now, try depth=5 + +-------------------------------------------------------------------------------- +-- * GHC Utilities +-------------------------------------------------------------------------------- + +-- | 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 +#if MIN_VERSION_ghc(9,13,20250417) + Just hmi -> mkTopLevImportedEnv hsc_env hmi +#else + Just hmi -> return emptyGlobalRdrEnv +#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 defaultDepth tt + +-- | 'TyThing' to 'VarInfo'. The 'Bool' argument indicates whether to force the +-- value of the thing (as in @True = :force@, @False = :print@) +tyThingToVarInfo :: Int {-^ Depth -} -> TyThing -> Debugger VarInfo +tyThingToVarInfo depth0 = \case + t@(AConLike c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables <*> pure NoFields + t@(ATyCon c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables <*> pure NoFields + t@(ACoAxiom c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables <*> pure NoFields + AnId i -> do + -- 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. + let depth1 = if isBoringTy (GHC.idType i) then maxBound else depth0 + term <- GHC.obtainTermFromId depth1 False{-don't force-} i + termToVarInfo (GHC.idName i) term + +-- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds +termToVarInfo :: Name -> Term -> Debugger VarInfo +termToVarInfo top_name top_term = do + + -- Make a VarInfo for the top term. + top_vi <- go top_name top_term + + sub_vis <- case top_term of + -- Boring types don't get subfields + _ | isBoringTy (GHCI.termType top_term) -> + return NoFields + + -- Make 'VarInfo's for the first layer of subTerms only. + Term{dc=Right dc, subTerms} -> do + case dataConFieldLabels dc of + -- Not a record type, + -- Use indexed fields + [] -> do + let names = zipWith (\ix _ -> mkIndexVar ix) [1..] (dataConOrigArgTys dc) + IndexedFields <$> mapM (uncurry go) (zipEqual names subTerms) + -- Is a record type, + -- Use field labels + dataConFields -> do + let names = map flSelector dataConFields + LabeledFields <$> mapM (uncurry go) (zipEqual names subTerms) + NewtypeWrap{dc=Right dc, wrapped_term} -> do + case dataConFieldLabels dc of + [] -> do + let name = mkIndexVar 1 + wvi <- go name wrapped_term + return (IndexedFields [wvi]) + [fld] -> do + let name = flSelector fld + wvi <- go name wrapped_term + return (LabeledFields [wvi]) + _ -> error "unexpected number of Newtype fields: larger than 1" + _ -> return NoFields + + return top_vi{varFields = sub_vis} + + where + -- Make a VarInfo for a term, but don't recurse into the fields and return + -- @NoFields@ for 'varFields'. + -- + -- We do this because we don't want to recursively return all sub-fields -- + -- only the first layer of fields for the top term. + go n term = do + let + varFields = NoFields + isThunk + -- to have more information we could match further on @Heap.ClosureType@ + | Suspension{} <- term = True + | otherwise = False + ty = GHCI.termType term + + -- 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 + -- (`varFields`). + 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 n + 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) + && (isBoringTy ty || not (hasDirectSubTerms term)) + then + return NoVariables + else do + ir <- freshInt + insertVarReference ir n term + return (SpecificVariable ir) + + return VarInfo{..} + + hasDirectSubTerms = \case + Suspension{} -> False + Prim{} -> False + NewtypeWrap{} -> True + RefWrap{} -> True + Term{subTerms} -> not $ null subTerms + + mkIndexVar ix = mkUnboundName (mkVarOcc ("_" ++ show @Int ix)) + +-- | 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 + +-- | 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 + -- TODO: + -- [ ] Preserve bindings introduced by evaluate requests + ioref <- asks varReferences + liftIO $ writeIORef ioref mempty + +-- | 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 + } + +-------------------------------------------------------------------------------- +-- * General utilities +-------------------------------------------------------------------------------- + +-- | 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/ghc-debugger/GHC/Debugger/Interface/Messages.hs b/ghc-debugger/GHC/Debugger/Interface/Messages.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Interface/Messages.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE DeriveGeneric, + StandaloneDeriving, + OverloadedStrings, + DuplicateRecordFields, + TypeApplications + #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- JSON GHC.BreakpointId + +-- | Types for sending and receiving messages to/from ghc-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.13 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 + + -- | 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 ghc-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 + + , varFields :: VarFields + -- ^ A 'VarInfo' for each field. These may be named (@Left@) or indexed fields (@Right@). + + -- 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 `ghc-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? + , breakId :: GHC.BreakpointId + -- ^ 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 } + | EvalStopped { breakId :: Maybe GHC.BreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} } + -- | 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 + +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" diff --git a/ghc-debugger/GHC/Debugger/Monad.hs b/ghc-debugger/GHC/Debugger/Monad.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Monad.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, NamedFieldPuns, TupleSections, LambdaCase, OverloadedRecordDot #-} +module GHC.Debugger.Monad where + +import Prelude hiding (mod) +import Data.Function +import System.Exit +import System.IO +import System.FilePath (normalise) +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.Driver.Phases as GHC +import GHC.Driver.Pipeline as GHC +import GHC.Driver.Config.Logger as GHC +import GHC.Driver.Session.Units as GHC +import GHC.Unit.Module.ModSummary as GHC +import GHC.Utils.Outputable as GHC +import GHC.Utils.Monad 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.Driver.Env + +import Data.IORef +import Data.Maybe +import qualified Data.List.NonEmpty as NE +import qualified Data.List as List +import qualified Data.IntMap as IM + +import Control.Monad.Reader + +import GHC.Debugger.Interface.Messages +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 (Name, Term)) + -- ^ 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. + , 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 -- ^ 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) + -> RunDebuggerSettings -- ^ Other debugger run settings + -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation + -> IO a +runDebugger dbg_out libdir units ghcInvocation' 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.backend = GHC.interpreterBackend + , 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 + + GHC.modifyLogger $ + -- Override the logger to output to the given handle + GHC.pushLogHook (const $ debuggerLoggerAction dbg_out) + + logger1 <- GHC.getLogger + let logger2 = GHC.setLogFlags logger1 (GHC.initLogFlags dflags1) + + -- The rest of the arguments are "dynamic" + -- Leftover ones are presumably files + (dflags4, fileish_args, _dynamicFlagWarnings) <- + GHC.parseDynamicFlags logger2 dflags1 (map (GHC.mkGeneralLocated "on ghc-debugger command arg") ghcInvocation) + + let (dflags5, srcs, objs) = GHC.parseTargetFiles dflags4 (map GHC.unLoc fileish_args) + + -- we've finished manipulating the DynFlags, update the session + _ <- GHC.setSessionDynFlags dflags5 + + dflags6 <- GHC.getSessionDynFlags + + -- Should this be done in GHC= + liftIO $ GHC.initUniqSupply (GHC.initialUnique dflags6) (GHC.uniqueIncrement dflags6) + + -- Initialise plugins here because the plugin author might already expect this + -- subsequent call to `getLogger` to be affected by a plugin. + GHC.initializeSessionPlugins + hsc_env <- GHC.getSession + + hs_srcs <- case NE.nonEmpty units of + Just ne_units -> do + GHC.initMulti ne_units (\_ _ _ _ -> {-no options extra check-} pure ()) + Nothing -> do + case srcs of + [] -> return [] + _ -> do + let (hs_srcs, non_hs_srcs) = List.partition GHC.isHaskellishTarget srcs + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (GHC.oneShot hsc_env GHC.NoStop srcs) >> return [] + else do + o_files <- GHC.mapMaybeM (\x -> liftIO $ GHC.compileFile hsc_env GHC.NoStop x) non_hs_srcs + dflags7 <- GHC.getSessionDynFlags + let dflags' = dflags7 { GHC.ldInputs = map (GHC.FileOption "") o_files ++ GHC.ldInputs dflags7 } + _ <- GHC.setSessionDynFlags dflags' + return $ map (uncurry (,Nothing,)) hs_srcs + + targets' <- mapM (\(src, uid, phase) -> GHC.guessTarget src uid phase) hs_srcs + GHC.setTargets targets' + 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.IIDecl . GHC.simpleImportDecl . GHC.ms_mod_name) 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. +registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool +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 + GHC.setupBreakpoint hsc_env bp breakpoint_count + + -- 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 + return changed + +-- | 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 +getActiveBreakpoints :: Maybe FilePath -> Debugger [GHC.BreakpointId] +getActiveBreakpoints mfile = do + m <- asks activeBreakpoints >>= liftIO . readIORef + case mfile of + Just file -> do + mms <- getModuleByPath file + case mms of + Right ms -> + return $ + [ 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 + return $ + [ 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 everytime as the loaded modules may have changed + lms <- getAllLoadedModules + let matches ms = normalise (msHsFilePath ms) `List.isSuffixOf` path + 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/ghc-debugger." + +-------------------------------------------------------------------------------- +-- Variable references +-------------------------------------------------------------------------------- + +-- | Find a variable's associated Term and Name by reference ('Int') +lookupVarByReference :: Int -> Debugger (Maybe (Name, Term)) +lookupVarByReference i = do + ioref <- asks varReferences + rm <- readIORef ioref & liftIO + return $ IM.lookup i rm + +-- | Inserts a mapping from the given variable reference to the variable's +-- associated Term and the Name it is bound to for display +insertVarReference :: Int -> Name -> Term -> Debugger () +insertVarReference i name term = do + ioref <- asks varReferences + rm <- readIORef ioref & liftIO + let + rm' = IM.insert i (name, term) rm + writeIORef ioref rm' & liftIO + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | 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 = 5 + cvObtainTerm hsc_env forceDepth forceThunks ty val + NewtypeWrap{wrapped_term} -> seqTerm 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 IM.empty) + <*> 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 + + 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."