ghc-debugger (empty) → 0.1.0.0

raw patch · 20 files changed

+2979/−0 lines, 20 filesdep +aesondep +arraydep +async

Dependencies added: aeson, array, async, base, binary, bytestring, containers, dap, directory, exceptions, filepath, ghc, ghc-debugger, ghci, hie-bios, mtl, process, text, unix

Files

• CHANGELOG.md +5/−0
• LICENSE +29/−0
• README.md +120/−0
• ghc-debug-adapter/Development/Debug/Adapter.hs +55/−0
• ghc-debug-adapter/Development/Debug/Adapter/Breakpoints.hs +153/−0
• ghc-debug-adapter/Development/Debug/Adapter/Evaluation.hs +104/−0
• ghc-debug-adapter/Development/Debug/Adapter/Exit.hs +107/−0
• ghc-debug-adapter/Development/Debug/Adapter/Flags.hs +69/−0
• ghc-debug-adapter/Development/Debug/Adapter/Handles.hs +142/−0
• ghc-debug-adapter/Development/Debug/Adapter/Init.hs +229/−0
• ghc-debug-adapter/Development/Debug/Adapter/Interface.hs +35/−0
• ghc-debug-adapter/Development/Debug/Adapter/Output.hs +55/−0
• ghc-debug-adapter/Development/Debug/Adapter/Stepping.hs +30/−0
• ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs +170/−0
• ghc-debug-adapter/Main.hs +150/−0
• ghc-debugger.cabal +106/−0
• ghc-debugger/GHC/Debugger.hs +709/−0
• ghc-debugger/GHC/Debugger/Interface/Messages.hs +298/−0
• ghc-debugger/GHC/Debugger/Monad.hs +409/−0
• test/haskell/Main.hs +4/−0

@@ -0,0 +1,5 @@+# Revision history for ghc-debugger++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

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

@@ -0,0 +1,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)

@@ -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)}+

@@ -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

@@ -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)+      }+

@@ -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++

@@ -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+  ]

@@ -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+

@@ -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 ()

@@ -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+

@@ -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"+    }

@@ -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+

@@ -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+

@@ -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 <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)+----------------------------------------------------------------------------

@@ -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

@@ -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. <program execution resumes and fails>+5. SENT Terminate event       <-- execution failed and we report it to exit cleanly+6. RECEIVED Scopes req        <-- happens as a sequence of 2 that wasn't canceled+7. <used to crash! because we're no longer at a breakpoint>++Now, we simply returned empty responses when these requests come in+while we're no longer at a breakpoint. The client will soon come to a halt+because of the termination event we sent.+-}++--------------------------------------------------------------------------------+-- * Stack trace+--------------------------------------------------------------------------------++-- | Get the stack frames at the point we're stopped at+getStacktrace :: Debugger [StackFrame]+getStacktrace = GHC.getResumeContext >>= \case+  [] ->+    -- See Note [Don't crash if not stopped]+    return []+  r:_+    | Just ss <- srcSpanToRealSrcSpan (GHC.resumeSpan r)+    -> return+        [ StackFrame+          { name = GHC.resumeDecl r+          , sourceSpan = realSrcSpanToSourceSpan ss+          }+        ]+    | otherwise ->+        -- No resume span; which should mean we're stopped on an exception.+        -- No info for now.+        return []++--------------------------------------------------------------------------------+-- * Scopes+--------------------------------------------------------------------------------++-- | Get the stack frames at the point we're stopped at+getScopes :: Debugger [ScopeInfo]+getScopes = GHC.getCurrentBreakSpan >>= \case+  Nothing ->+    -- See Note [Don't crash if not stopped]+    return []+  Just span+    | Just rss <- srcSpanToRealSrcSpan span+    , let sourceSpan = realSrcSpanToSourceSpan rss+    -> do+      -- It is /very important/ to report a number of variables (numVars) for+      -- larger scopes. If we just say "Nothing", then all variables of all+      -- scopes will be fetched at every stopped event.+      curr_modl <- expectJust <$> getCurrentBreakModule+      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 #-}+

@@ -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"

@@ -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++

@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."