haskell-debugger 0.9.0.0 → 0.10.0.0

raw patch · 35 files changed

+1849/−538 lines, 35 filesdep +file-embeddep +ghc-bootdep +ghc-boot-thdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: file-embed, ghc-boot, ghc-boot-th, haskell-debugger-view

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +36/−0
• README.md +47/−10
• haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs +11/−0
• haskell-debugger-view/src/GHC/Debugger/View/Class.hs +150/−0
• haskell-debugger-view/src/GHC/Debugger/View/Containers.hs +21/−0
• haskell-debugger-view/src/GHC/Debugger/View/Text.hs +11/−0
• haskell-debugger.cabal +22/−5
• haskell-debugger/GHC/Debugger.hs +4/−13
• haskell-debugger/GHC/Debugger/Breakpoint.hs +162/−25
• haskell-debugger/GHC/Debugger/Breakpoint/Map.hs +79/−0
• haskell-debugger/GHC/Debugger/Evaluation.hs +44/−6
• haskell-debugger/GHC/Debugger/Interface/Messages.hs +38/−67
• haskell-debugger/GHC/Debugger/Monad.hs +395/−219
• haskell-debugger/GHC/Debugger/Runtime.hs +18/−25
• haskell-debugger/GHC/Debugger/Runtime/Instances.hs +153/−0
• haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs +196/−0
• haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs-boot +7/−0
• haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs +2/−2
• haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs +25/−12
• haskell-debugger/GHC/Debugger/Session.hs +36/−14
• haskell-debugger/GHC/Debugger/Session/Builtin.hs +160/−0
• haskell-debugger/GHC/Debugger/Stopped.hs +3/−6
• haskell-debugger/GHC/Debugger/Stopped/Variables.hs +102/−62
• haskell-debugger/GHC/Debugger/Utils.hs +9/−4
• hdb/Development/Debug/Adapter.hs +1/−0
• hdb/Development/Debug/Adapter/Breakpoints.hs +20/−6
• hdb/Development/Debug/Adapter/Evaluation.hs +24/−19
• hdb/Development/Debug/Adapter/Exit.hs +7/−4
• hdb/Development/Debug/Adapter/Init.hs +4/−6
• hdb/Development/Debug/Adapter/Stopped.hs +0/−11
• hdb/Development/Debug/Interactive.hs +19/−3
• hdb/Development/Debug/Session/Setup.hs +1/−0
• hdb/Main.hs +39/−18
• test/haskell/Test/DAP.hs +1/−1
• test/haskell/Test/DAP/RunInTerminal.hs +2/−0

@@ -1,5 +1,41 @@ # Revision history for haskell-debugger +## 0.10.0.0 -- 2025-11-18++* Adds Custom Debug Visualisations!+    * The value inspection internals were refactored to always try first to use a+      custom visualization and fallback to the general-case visualization which+      mimics the heap representation of a value.+    * We ship a handful of custom visualisations for base types like `String`,+      `Int`, etc, and for types from a few core packages: `Text`, `ByteString`, `Map` and `IntMap`.+    * The user can add custom visualizations for the desired types by+      implementing an instance for `DebugView` from `haskell-debugger-view`+        * At runtime, `hdb` will pick up the `DebugView` instances in scope and use them when possible.+    * When the package dependency closure includes `haskell-debugger-view`, we+      will use that unit specifically. When it is not in the dependencies, we+      will load a built-in version in memory.+* Evaluate requests now return a structured and expandable response, akin to the variables pane+    * To show the whole value inline one can recover the previous behavior by+      calling `show` on the value to display.+    * This makes it possible to have structured results in the "Watch" pane.+* Adds support for conditional breakpoints and hit count breakpoints+* Bug fixes in variable inspection+* Bug fixes in multiple-home-units++## 0.9.0.0 -- 2025-10-13++### Main changes++* Run a proxy program with `runInTerminal` to allow stdin via the terminal process, if the client supports it.++### Bug fixes++* Fix bug where build failures were reported in a pop-up rather than stderr+* Fix crashes panicking with `findUnitIdOfEntryFile`+* Fix cli bug by use absolute entryFile path+* Fix bug caused by not canonicalizing special target and root+* Fix in variable expansion (expand `Term`s iteratively as the user expands the tree)+ ## 0.8.0.0 -- 2025-09-19  * Allow defaults for all settings except `entryFile` and return a proper error in that case

@@ -1,12 +1,6 @@ # Haskell 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.+We are working on a first class debugger for Haskell!  ![CI badge](https://github.com/well-typed/haskell-debugger/actions/workflows/debugger.yaml/badge.svg) ![Hackage badge](https://img.shields.io/hackage/v/haskell-debugger.svg) @@ -56,6 +50,20 @@ To run the debugger, simply hit the green run button. See the Features section below for what is currently supported. +# Multiple home units session++Multiple home units is supported but currently may require a workaround (issue is tracked by [#38](https://github.com/well-typed/haskell-debugger/issues/38)).++If your multiple home units session does not work by default (e.g. if you+cannot set breakpoints on different units), and you do not have a `hie.yaml`+file, you may want to try creating a `hie.yaml` file in the root of the+workspace with:+```+cradle:+    cabal:+        component: "all"+```+ # Related Work  `hdb` is inspired by the original@@ -80,7 +88,6 @@ 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:@@ -107,8 +114,38 @@ - [ ] Instruction breakpoints  ### Conditionals-- [ ] Conditional breakpoints     (breakpoint is hit only if condition is satisfied)-- [ ] Hit conditional breakpoints (stop after N number of hits)+- [x] Conditional breakpoints     (breakpoint is hit only if condition is satisfied)+- [x] Hit conditional breakpoints (stop after N number of hits)++## Custom Debug Visualizations++The user can extend the debugger visualization behavior (in a plugin sort of+way) by implementing `DebugView` from+[`haskell-debugger-view`](https://hackage.haskell.org/package/haskell-debugger-view)+for the desired types.++We ship built-in custom instances for various `base` datatypes, such as+`String` and `(a, b)`, and for a core packages as well, such as `Text`,+`ByteString`, `Map` and `IntMap`.++Here is an example of a completely custom `DebugView` instance for a+user-defined datatype. You can also see how the `IntMap` is displayed as a pair+of `Int` keys to their values as opposed as as a `Bin/Tip` tree mimicking its+real definition:++![Image showing custom debug view instance](https://github.com/user-attachments/assets/2ccb5858-4893-4b5a-a889-077d61937f28)++When the package dependency closure includes `haskell-debugger-view`, we will+use that unit specifically. When it is not in the dependencies, we will load a+built-in version in memory.++# Talks++### MuniHac 2025: A modern step-through debugger for Haskell+[![MuniHac 2025 - Friday, September 12th - Rodrigo Mesquita: A modern step-through debugger for Haskell](https://img.youtube.com/vi/urYtE15ryA0/0.jpg)](https://youtu.be/urYtE15ryA0)++### ZuriHac 2025: Haskell Implementor's Workshop: The GHC Debugger+[![Rodrigo Mesquita - The GHC Debugger (ZuriHac)](https://img.youtube.com/vi/p-hBweQg42s/0.jpg)](https://youtu.be/p-hBweQg42s)  # Building from source 

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Debugger.View.ByteString where++import GHC.Debugger.View.Class++import qualified Data.ByteString    as BS++instance DebugView BS.ByteString where+  debugValue  t = VarValue (show t) False+  debugFields _ = VarFields []+

@@ -0,0 +1,150 @@+{-# LANGUAGE DerivingVia, StandaloneDeriving, ViewPatterns, ImpredicativeTypes #-}+-- | The home of customizability for visualizing variables and values with @haskell-debugger@+module GHC.Debugger.View.Class+  (+    -- * Writing custom debug visualizations+    --+    -- | The entry point for custom visualizations is 'DebugView'.+    -- There are two axis of configuration:+    --+    -- 1. What to display inline in front of the variable name and whether it+    -- is expandable+    --+    -- 2. What fields are displayed when the value is expanded and what are+    -- their corresponding values+    --+    -- The former is answered by 'debugValue' / 'VarValue' and the latter by+    -- 'debugFields' / 'VarFields'.+    DebugView(..)++  , VarValue(..)+  , VarFields(..)+  , VarFieldValue(..)++  -- * Utilities+  --+  -- | These can make it easier to write your own custom instances.+  -- We also use them for the built-in custom instances.+  , BoringTy(..)++  -- * The internals+  --+  -- | These are used by @haskell-debugger@ when invoking these instances at+  -- runtime and reconstructing the result from the heap.+  --+  -- They should never be used by a user looking to write custom visualizations.+  , VarValueIO(..)+  , debugValueIOWrapper+  , VarFieldsIO(..)+  , debugFieldsIOWrapper+  )+  where++-- | Custom handling of debug terms (e.g. in the variables pane, or when+-- inspecting a lazy variable)+class DebugView a where++  -- | Compute the representation of a variable with the given value.+  --+  -- INVARIANT: this method should only called on values which are already in+  -- WHNF, never thunks.+  --+  -- That said, this method is responsible for determining how much it is+  -- forced when displaying it inline as a variable.+  --+  -- For instance, for @String@, @a@ will be fully forced to display the entire+  -- string in one go rather than as a linked list of @'Char'@.+  debugValue :: a -> VarValue++  -- | Compute the fields to display when expanding a value of type @a@.+  --+  -- This method should only be called to get the fields if the corresponding+  -- @'VarValue'@ has @'varExpandable' = True@.+  debugFields :: a -> VarFields++-- | The representation of the value for some variable on the debugger+data VarValue = VarValue+  { -- | The value to display inline for this variable+    varValue      :: String++    -- | Can this variable further be expanded (s.t. @'debugFields'@ is not null?)+  , varExpandable :: Bool+  }+  deriving (Show, Read)++-- | The representation for fields of a value which is expandable in the debugger+newtype VarFields = VarFields+  { varFields :: [(String, VarFieldValue)]+  }++-- | A box for subfields of a value.+--+-- Used to construct the debug-view list of fields one gets from expanding a datatype.+-- See, for instance, the @DebugView (a, b)@ instance for an example of how it is used.+--+-- The boxed value is returned as is and can be further forced or expanded by+-- the debugger, using either the existing @'DebugView'@ instance for the+-- existential @a@ (the instance is found at runtime), or the generic runtime+-- term inspection mechanisms otherwise.+data VarFieldValue = forall a. VarFieldValue a++--------------------------------------------------------------------------------++-- | Boring types scaffolding.+--+-- Meant to be used like:+--+-- @+-- deriving via (BoringTy Int) instance (DebugView Int)+-- @+--+-- to derive a 'DebugView' for a type whose terms should always be fully forced+-- and displayed whole rather than as parts.+--+-- 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.+newtype BoringTy a = BoringTy a++instance Show a => DebugView (BoringTy a) where+  debugValue (BoringTy x) = VarValue (show x) False+  debugFields _           = VarFields []++deriving via BoringTy Int     instance DebugView Int+deriving via BoringTy Word    instance DebugView Word+deriving via BoringTy Double  instance DebugView Double+deriving via BoringTy Float   instance DebugView Float+deriving via BoringTy Integer instance DebugView Integer+deriving via BoringTy Char    instance DebugView Char+deriving via BoringTy String  instance DebugView String++instance DebugView (a, b) where+  debugValue _ = VarValue "( , )" True+  debugFields (x, y) = VarFields+    [ ("fst", VarFieldValue x)+    , ("snd", VarFieldValue y) ]++--------------------------------------------------------------------------------+-- * (Internal) Wrappers required to call `evalStmt` on methods more easily+--------------------------------------------------------------------------------++-- | Wrapper to make evaluating from debugger easier+data VarValueIO = VarValueIO+  { varValueIO :: IO String+  , varExpandableIO :: Bool+  }++debugValueIOWrapper :: DebugView a => a -> IO [VarValueIO]+debugValueIOWrapper x = case debugValue x of+  VarValue str b ->+    pure [VarValueIO (pure str) b]++newtype VarFieldsIO = VarFieldsIO+  { varFieldsIO :: [(IO String, VarFieldValue)]+  }++debugFieldsIOWrapper :: DebugView a => a -> IO [VarFieldsIO]+debugFieldsIOWrapper x = case debugFields x of+  VarFields fls ->+    pure [VarFieldsIO [ (pure fl_s, b) | (fl_s, b) <- fls]]

@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Debugger.View.Containers where++import GHC.Debugger.View.Class++import qualified Data.IntMap        as IM+import qualified Data.Map           as M++instance DebugView (IM.IntMap a) where+  debugValue _ = VarValue "IntMap" True+  debugFields im = VarFields+    [ (show k, VarFieldValue v)+    | (k, v) <- IM.toList im+    ]++instance Show k => DebugView (M.Map k a) where+  debugValue _ = VarValue "Map" True+  debugFields m = VarFields+    [ (show k, VarFieldValue v)+    | (k, v) <- M.toList m+    ]

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Debugger.View.Text where++import GHC.Debugger.View.Class++import qualified Data.Text          as T++instance DebugView T.Text where+  debugValue  t = VarValue (show (T.unpack t)) False+  debugFields _ = VarFields []+

@@ -1,8 +1,8 @@ cabal-version:      3.12 name:               haskell-debugger-version:            0.9.0.0+version:            0.10.0.0 synopsis:-    A step-through machine-interface debugger for GHC Haskell+    A step-through debugger for GHC Haskell  description:        This package provides a standalone executable                     called @hdb@ which can be used to step-through Haskell@@ -31,6 +31,13 @@ build-type:         Simple extra-doc-files:    CHANGELOG.md                     README.md++                    -- Make sure to list all files which we embed with TH, so sdist + build works.+extra-source-files: haskell-debugger-view/src/GHC/Debugger/View/Class.hs+                    haskell-debugger-view/src/GHC/Debugger/View/Containers.hs+                    haskell-debugger-view/src/GHC/Debugger/View/Text.hs+                    haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs+ homepage:           https://github.com/well-typed/haskell-debugger bug-reports:        https://github.com/well-typed/haskell-debugger/issues @@ -50,23 +57,30 @@     import:           warnings     exposed-modules:  GHC.Debugger,                       GHC.Debugger.Breakpoint,+                      GHC.Debugger.Breakpoint.Map,                       GHC.Debugger.Evaluation,                       GHC.Debugger.Logger,                       GHC.Debugger.Stopped,                       GHC.Debugger.Stopped.Variables,                       GHC.Debugger.Utils,                       GHC.Debugger.Runtime,+                      GHC.Debugger.Runtime.Instances,+                      GHC.Debugger.Runtime.Instances.Discover,                        GHC.Debugger.Runtime.Term.Key,                       GHC.Debugger.Runtime.Term.Cache,                        GHC.Debugger.Monad,+                       GHC.Debugger.Session,+                      GHC.Debugger.Session.Builtin,                       GHC.Debugger.Interface.Messages     -- other-modules:     default-extensions: CPP-    build-depends:    base > 4.21 && < 5,+    build-depends:    base >= 4.22 && < 5,                       ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16,+                      ghc-boot-th >= 9.14 && < 9.16,+                      ghc-boot >= 9.14 && < 9.16,                       array >= 0.5.8 && < 0.6,                       containers >= 0.7 && < 0.9,                       mtl >= 2.3 && < 3,@@ -81,14 +95,17 @@                       base16-bytestring >= 1.0.2.0 && < 1.1,                       aeson >= 2.2.3 && < 2.3,                       hie-bios >= 0.15 && < 0.18,+                      file-embed >= 0.0.16 && < 0.1,                       -- Logger dependencies                       time >= 1.14 && < 2,                       prettyprinter >= 1.7.1 && < 2,                       text >= 2.1 && < 2.3,                       co-log-core >= 0.3.2.5 && < 0.4, +                      haskell-debugger-view >= 0.1 && < 1.0+     hs-source-dirs:   haskell-debugger-    default-language: Haskell2010+    default-language: GHC2021  executable hdb     import:           warnings@@ -146,7 +163,7 @@  test-suite haskell-debugger-test     import:           warnings-    default-language: Haskell2010+    default-language: GHC2021     -- other-extensions:     type:             exitcode-stdio-1.0     hs-source-dirs:   test/haskell/

@@ -10,7 +10,6 @@ import GHC.Debugger.Evaluation import GHC.Debugger.Stopped import GHC.Debugger.Monad-import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages import GHC.Debugger.Logger @@ -23,19 +22,10 @@ execute recorder = \case   ClearFunctionBreakpoints -> DidClearBreakpoints <$ clearBreakpoints Nothing   ClearModBreakpoints fp -> DidClearBreakpoints <$ clearBreakpoints (Just fp)-  SetBreakpoint bp -> DidSetBreakpoint <$> setBreakpoint bp BreakpointEnabled+  SetBreakpoint{brk, hitCount, condition} ->+    DidSetBreakpoint <$> setBreakpoint brk (condBreakEnableStatus hitCount condition)   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"+  GetBreakpointsAt bp -> DidGetBreakpoints <$> getBreakpointsAt bp   GetStacktrace -> GotStacktrace <$> getStacktrace   GetScopes -> GotScopes <$> getScopes   GetVariables kind -> GotVariables <$> getVariables kind@@ -55,3 +45,4 @@ instance Pretty DebuggerLog where   pretty = \ case     EvalLog msg -> pretty msg+

@@ -3,26 +3,35 @@    TypeApplications, ScopedTypeVariables, BangPatterns #-} module GHC.Debugger.Breakpoint where +import Prelude hiding ((<>))+import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader-import Data.IORef import Data.Bits (xor)+import Data.IORef+import System.Directory+import System.FilePath  import GHC import GHC.ByteCode.Breakpoints-import GHC.Utils.Error (logOutput)+import GHC.Data.Maybe import GHC.Driver.DynFlags as GHC import GHC.Driver.Env import GHC.Driver.Ppr as GHC+import GHC.Runtime.Interpreter import GHC.Runtime.Debugger.Breakpoints as GHC-import GHC.Unit.Module.Env as GHC+import GHC.Unit.Module.ModSummary+import GHC.Utils.Error (logOutput) import GHC.Utils.Outputable as GHC+import qualified GHCi.BreakArray as BA  import GHC.Debugger.Monad import GHC.Debugger.Session+import GHC.Debugger.Logger as Logger import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages+import qualified GHC.Debugger.Breakpoint.Map as BM  -------------------------------------------------------------------------------- -- * Breakpoints@@ -37,40 +46,39 @@   -- breakpoints for that module rather than keeping track,   -- but much less efficient at scale.   hsc_env <- getSession+  bpsRef <- asks activeBreakpoints   bids <- getActiveBreakpoints mfile   forM_ bids $ \bid -> do     GHC.setupBreakpoint (hscInterp hsc_env) bid (breakpointStatusInt BreakpointDisabled)--  -- Clear out the state-  bpsRef <- asks activeBreakpoints-  liftIO $ writeIORef bpsRef emptyModuleEnv+    -- Clear out from the state+    liftIO $ modifyIORef bpsRef (BM.delete bid) --- | Find a 'BreakpointId' and its span from a module + line + column.------ Used by 'setBreakpoints' and 'GetBreakpointsAt' requests-getBreakpointsAt :: ModSummary {-^ module -} -> Int {-^ line num -} -> Maybe Int {-^ column num -} -> Debugger (Maybe (Int, RealSrcSpan))-getBreakpointsAt modl lineNum columnNum = do-  -- TODO: Cache moduleLineMap.-  mticks <- makeModuleLineMap (ms_mod modl)-  let mbid = do-        ticks <- mticks-        case columnNum of-          Nothing -> findBreakByLine lineNum ticks-          Just col -> findBreakByCoord (lineNum, col) ticks-  return mbid+getBreakpointsAt :: Breakpoint -> Debugger (Maybe SourceSpan)+getBreakpointsAt ModuleBreak{path, lineNum, columnNum} = do+  mmodl <- getModuleByPath path+  case mmodl of+    Left e -> do+      logSDoc Logger.Warning e+      return Nothing+    Right modl -> do+      mbfnd <- findBreakpoint modl lineNum columnNum+      return $ realSrcSpanToSourceSpan . snd <$> mbfnd+getBreakpointsAt _ = error "unexpected getbreakpoints without ModuleBreak"  -- | Set a breakpoint in this session setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound+setBreakpoint bp BreakpointAfterCountCond{} = do+  logSDoc Logger.Warning $+    text $ "Setting a hit count condition on a conditional breakpoint is not yet supported. Ignoring breakpoint " ++ show bp+  return BreakNotFound setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do   mmodl <- getModuleByPath path   case mmodl of     Left e -> do-      displayWarnings [e]+      logSDoc Logger.Warning e       return BreakNotFound     Right modl -> do-      mbid <- getBreakpointsAt modl lineNum columnNum--      case mbid of+      findBreakpoint modl lineNum columnNum >>= \case         Nothing -> return BreakNotFound         Just (bix, spn) -> do           let bid = BreakpointId { bi_tick_mod = ms_mod modl@@ -116,7 +124,7 @@           = Opt_BreakOnError           | OnExceptionsBreak <- exception_bp           = Opt_BreakOnException-  dflags <- GHC.getInteractiveDynFlags+  dflags <- getInteractiveDebuggerDynFlags   let     -- changed if option is ON and bp is OFF (breakpoint disabled), or if     -- option is OFF and bp is ON (i.e. XOR)@@ -124,3 +132,132 @@     didChange = gopt opt dflags `xor` breakOn   setInteractiveDebuggerDynFlags $ dflags `ch_opt` opt   return (BreakFoundNoLoc didChange)++--------------------------------------------------------------------------------+-- * Lower-level interface+--------------------------------------------------------------------------------++-- | 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, [GHC.InternalBreakpointId])+registerBreakpoint bp status kind = do++  -- Set breakpoint in GHC session+  let breakpoint_count = breakpointStatusInt status+  hsc_env <- GHC.getSession+  internal_break_ids <- getInternalBreaksOf bp+  changed <- forM internal_break_ids $ \ibi -> do+    GHC.setupBreakpoint (hscInterp hsc_env) ibi breakpoint_count++    -- Register breakpoint in Debugger state for every internal breakpoint+    brksMapRef <- asks activeBreakpoints+    liftIO $ atomicModifyIORef' brksMapRef $ \brksMap ->+      case status of+        -- Disabling the breakpoint:+        BreakpointDisabled ->+          (BM.delete ibi brksMap, True{-assume map always contains BP, thus changes on deletion-})++        -- Enabling the breakpoint:+        _ -> case BM.lookup ibi brksMap of+          Just (status', _kind)+            | status' == status+            -> -- Nothing changed, OK+               (brksMap, False)+          _ -> -- Else, insert+            (BM.insert ibi (status, kind) brksMap, True)++  return (any id changed, internal_break_ids)++-- | 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.InternalBreakpointId]+getActiveBreakpoints mfile = do+  bm <- asks activeBreakpoints >>= liftIO . readIORef+  case mfile of+    Just file -> do+      mms <- getModuleByPath file+      case mms of+        Right ms -> do+          hsc_env    <- getSession+          imodBreaks <- liftIO $ expectJust <$> readIModBreaksMaybe (hsc_HUG hsc_env) (ms_mod ms)+          return+            [ ibi+            | ibi <- BM.keys bm+            , getBreakSourceMod ibi imodBreaks == ms_mod ms+            -- assert: status is always > disabled+            ]+        Left e -> do+          logSDoc Logger.Warning e+          return []+    Nothing -> do+      return+        [ ibi+        | (ibi, (status, kind)) <- BM.toList bm+        -- Keep only function breakpoints in this case+        , FunctionBreakpointKind == kind+        , assert (status > BreakpointDisabled) True+        ]++-- | 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+  BreakpointWhenCond{}       -> BA.breakOn  -- always stop, cond evaluated after+  BreakpointAfterCountCond{} -> BA.breakOn  -- ditto, decrease only when cond is true++-- | Find all the internal breakpoints that use the given source-level breakpoint id+getInternalBreaksOf :: BreakpointId -> Debugger [InternalBreakpointId]+getInternalBreaksOf bi = do+  bs <- mkBreakpointOccurrences+  return $+    fromMaybe [] {- still not found after refresh -} $+      lookupBreakpointOccurrences bs bi++--------------------------------------------------------------------------------+-- * Utils+--------------------------------------------------------------------------------++-- | Turn a @hitCount :: Maybe Int@ and @condition :: Maybe Text@ into an enabled @BreakpointStatus@.+condBreakEnableStatus :: Maybe Int {-^ hitCount -} -> Maybe String {-^ condition -} -> BreakpointStatus+condBreakEnableStatus hitCount condition = do+  case (hitCount, condition) of+    (Nothing, Nothing) -> BreakpointEnabled+    (Just i,  Nothing) -> BreakpointAfterCount i+    (Nothing, Just c)  -> BreakpointWhenCond c+    (Just i,  Just c)  -> BreakpointAfterCountCond i c++-- | Get a 'ModSummary' of a loaded module given its 'FilePath'+getModuleByPath :: FilePath -> Debugger (Either SDoc ModSummary)+getModuleByPath path = do+  -- get all loaded modules this every time as the loaded modules may have changed+  lms <- getAllLoadedModules+  absPath <- liftIO $ makeAbsolute path+  let matches ms = normalise (msHsFilePath ms) == normalise absPath+  return $ case filter matches lms of+    [x] -> Right x+    [] -> Left $ text "No module matched" <+> text path <> text "."+               $$ text "Loaded modules:"+               $$ vcat (map (text . msHsFilePath) lms)+               $$ text "Perhaps you've set a breakpoint on a module that isn't loaded into the session?"+    xs -> Left $ text "Too many modules (" <> ppr xs <> text ") matched" <+> text path+              <> text ". Please report a bug at https://github.com/well-typed/haskell-debugger."++-- | Find a 'BreakpointId' index and its span from a module + line + column.+--+-- Used by 'setBreakpoints' and 'GetBreakpointsAt' requests+findBreakpoint :: ModSummary {-^ module -} -> Int {-^ line num -} -> Maybe Int {-^ column num -} -> Debugger (Maybe (Int, RealSrcSpan))+findBreakpoint 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

@@ -0,0 +1,79 @@+{-# LANGUAGE NamedFieldPuns, DeriveFunctor, DerivingStrategies, GeneralizedNewtypeDeriving #-}+-- | Meant to be qualified with @import qualified GHC.Debugger.Breakpoint.Map as BM@+module GHC.Debugger.Breakpoint.Map+  ( BreakpointMap+  , insert+  , lookup+  , delete+  , empty+  , lookupModuleIBIs+  , keys+  , toList+  ) where++import Prelude hiding (lookup)+import qualified GHC+import GHC.Unit.Module.Env+import GHC.ByteCode.Breakpoints+import GHC.Utils.Outputable (Outputable)+import qualified Data.IntMap as IM++-- | A map keyed by 'InternalBreakpointId'+newtype BreakpointMap a = BreakpointMap (ModuleEnv (IM.IntMap a))+  deriving newtype Outputable++insert :: GHC.InternalBreakpointId -> a -> BreakpointMap a -> BreakpointMap a+insert InternalBreakpointId{ibi_info_mod, ibi_info_index}+        x (BreakpointMap bm0) = BreakpointMap $+  case lookupModuleEnv bm0 ibi_info_mod of+    Nothing ->+      extendModuleEnv bm0 ibi_info_mod $+        IM.singleton ibi_info_index x+    Just im ->+      extendModuleEnv bm0 ibi_info_mod $+        IM.insert ibi_info_index x im++lookup :: GHC.InternalBreakpointId -> BreakpointMap a -> Maybe a+lookup InternalBreakpointId{ibi_info_mod, ibi_info_index}+        (BreakpointMap bm0) = do+  lookupModuleEnv bm0 ibi_info_mod+  >>= IM.lookup ibi_info_index++delete :: GHC.InternalBreakpointId -> BreakpointMap a -> BreakpointMap a+delete InternalBreakpointId{ibi_info_mod, ibi_info_index}+        (BreakpointMap bm0) =+  case lookupModuleEnv bm0 ibi_info_mod of+    Nothing -> BreakpointMap bm0+    Just im -> BreakpointMap $+      extendModuleEnv bm0 ibi_info_mod $+        IM.delete ibi_info_index im++empty :: BreakpointMap a+empty = BreakpointMap emptyModuleEnv++-- | Retrieves all 'InternalBreakpointId's for a given 'Module'+-- Note: The internal breakpoints of a module are not necessarily the same as+-- the source-level breakpoints, so this shouldn't be used to get all internal+-- breakpoints with source-level occurrences in the given module.+lookupModuleIBIs :: GHC.Module -> BreakpointMap a -> [InternalBreakpointId]+lookupModuleIBIs m (BreakpointMap bm) =+  case lookupModuleEnv bm m of+    Nothing -> []+    Just im ->+      [ InternalBreakpointId m bix+      | bix <- IM.keys im+      ]++keys :: BreakpointMap a -> [InternalBreakpointId]+keys (BreakpointMap bm) =+  [ InternalBreakpointId m bix+  | (m, im) <- moduleEnvToList bm+  , bix <- IM.keys im+  ]++toList :: BreakpointMap a -> [(InternalBreakpointId, a)]+toList (BreakpointMap bm) =+  [ (InternalBreakpointId m bix, a)+  | (m, im)  <- moduleEnvToList bm+  , (bix, a) <- IM.toList im+  ]

@@ -14,6 +14,8 @@ import GHC.Utils.Outputable import Control.Monad.IO.Class import Control.Monad.Catch+import Control.Monad.Reader+import Data.IORef import qualified Data.List as List import Data.Maybe import System.FilePath@@ -39,7 +41,8 @@ import GHC.Debugger.Monad import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages-import GHC.Debugger.Logger+import GHC.Debugger.Logger as Logger+import qualified GHC.Debugger.Breakpoint.Map as BM  data EvalLog   = LogEvalModule GHC.Module@@ -55,7 +58,6 @@ -- | Run a program with debugging enabled debugExecution :: Recorder (WithSeverity EvalLog) -> FilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult debugExecution recorder entryFile 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?   modSummaryOfEntryFile <- findUnitIdOfEntryFile entryFile@@ -184,22 +186,58 @@     Right ExecBreak{} -> continueToCompletion >>= handleExecResult     Right r@ExecComplete{} -> handleExecResult r +-- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'.+--+-- We use this in 'doEval' because we want to ignore breakpoints in expressions given at the prompt.+continueToCompletion :: Debugger GHC.ExecResult+continueToCompletion = do+  execr <- GHC.resumeExec GHC.RunToCompletion Nothing+  case execr of+    GHC.ExecBreak{} -> continueToCompletion+    GHC.ExecComplete{} -> return execr+ -- | 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 [] -> return (EvalCompleted "" "" NoVariables) -- Evaluation completed without binding any result.         Right (n:_ns) -> inspectName n >>= \case-          Just VarInfo{varValue, varType} -> return (EvalCompleted varValue varType)+          Just VarInfo{varValue, varType, varRef} -> do+            return (EvalCompleted varValue varType varRef)           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 = breakPointId}+    ExecBreak {breakNames = _, breakPointId = Just bid} -> do+      bm <- liftIO . readIORef =<< asks activeBreakpoints+      case BM.lookup bid bm of+        -- todo: BreakpointAfterCountCond is not handled yet.+        Just (BreakpointWhenCond cond, _) -> do+          let evalFailedMsg e = text $ "Evaluation of conditional breakpoint expression failed with " ++ e ++ "\nIgnoring..."+          let resume = GHC.resumeExec GHC.RunToCompletion Nothing >>= handleExecResult+          doEval cond >>= \case+            EvalStopped{} -> error "impossible for doEval"+            EvalCompleted { resultVal, resultType } ->+              if resultType == "Bool" then do+                if resultVal == "True" then+                  return EvalStopped{breakId = Just bid}+                else+                  resume+              else do+                logSDoc Logger.Warning (evalFailedMsg "\"expression resultType is != Bool\"")+                resume+            EvalException { resultVal } -> do+              logSDoc Logger.Warning (evalFailedMsg resultVal)+              resume+            EvalAbortedWith e -> do+              logSDoc Logger.Warning (evalFailedMsg e)+              resume++        -- Unconditionally 'EvalStopped' in all other cases+        _ -> return EvalStopped{breakId = Just bid}  -- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'. inspectName :: Name -> Debugger (Maybe VarInfo)

@@ -1,20 +1,15 @@-{-# LANGUAGE DeriveGeneric,+{-# LANGUAGE LambdaCase,              StandaloneDeriving,              OverloadedStrings,              DuplicateRecordFields,              TypeApplications              #-}-{-# OPTIONS_GHC -Wno-orphans #-} -- JSON GHC.BreakpointId  -- | Types for sending and receiving messages to/from haskell-debugger module GHC.Debugger.Interface.Messages where -import GHC.Generics-import Data.Aeson import qualified GHC import qualified GHC.Utils.Outputable as GHC-import GHC.Unit.Types-import Language.Haskell.Syntax.Module.Name  -------------------------------------------------------------------------------- -- Commands@@ -24,7 +19,12 @@ data Command    -- | Set a breakpoint on a given function, or module by line number-  = SetBreakpoint Breakpoint+  = SetBreakpoint { brk       :: Breakpoint +                  , hitCount  :: Maybe Int+                  -- ^ Stop after N hits (if @isJust condition@, count down only when @eval condition == True@)+                  , condition :: Maybe String+                  -- ^ Stop if condition evalutes to True+                  }    -- | Delete a breakpoint on a given function, or module by line number   | DelBreakpoint Breakpoint@@ -80,16 +80,16 @@  -- | An entry point for program execution. data EntryPoint = MainEntry { mainName :: Maybe String } | FunctionEntry { fnName :: String }-  deriving (Show, Generic)+  deriving (Show)  -- | 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 }+  | FunctionBreak { function  :: String }   | OnExceptionsBreak   | OnUncaughtExceptionsBreak-  deriving (Show, Generic)+  deriving (Show)  -- | Information about a scope data ScopeInfo = ScopeInfo@@ -97,12 +97,10 @@       , sourceSpan :: SourceSpan       , numVars :: Maybe Int       , expensive :: Bool }-  deriving (Show, Generic)+  deriving (Show) -data VarFields = LabeledFields [VarInfo]-               | IndexedFields [VarInfo]-               | NoFields-               deriving (Show, Generic, Eq)+newtype VarFields = VarFields [VarInfo]+  deriving (Show, Eq)  -- | Information about a variable data VarInfo = VarInfo@@ -116,7 +114,7 @@       -- TODO:       --  memory reference using ghc-debug.       }-      deriving (Show, Generic, Eq)+      deriving (Show, Eq)  -- | What kind of breakpoint are we referring to, module or function breakpoints? -- Used e.g. in the 'ClearBreakpoints' request@@ -125,14 +123,16 @@   = ModuleBreakpointKind   -- | Function breakpoints   | FunctionBreakpointKind-  deriving (Show, Generic, Eq)+  deriving (Show, Eq) +instance GHC.Outputable BreakpointKind where ppr = GHC.text . show+ -- | Referring to existing scopes data ScopeVariablesReference   = LocalVariablesScope   | ModuleVariablesScope   | GlobalVariablesScope-  deriving (Show, Generic, Eq, Ord)+  deriving (Show, Eq, Ord)  -- | The type of variables referenced, or a particular variable referenced for its fields or value (when inspecting a thunk) data VariableReference@@ -152,8 +152,16 @@   -- Used to force its result or get its structured children   | SpecificVariable Int -  deriving (Show, Generic, Eq, Ord)+  deriving (Show, Eq, Ord) +-- | From 'ScopeVariablesReference' to a 'VariableReference' that can be used in @"variable"@ requests+scopeToVarRef :: ScopeVariablesReference -> VariableReference+scopeToVarRef = \case+  LocalVariablesScope -> LocalVariables+  ModuleVariablesScope -> ModuleVariables+  GlobalVariablesScope -> GlobalVariables++ instance Bounded VariableReference where   minBound = NoVariables   maxBound = SpecificVariable maxBound@@ -184,7 +192,7 @@       , endCol :: {-# UNPACK #-} !Int       -- ^ RealSrcSpan end col       }-      deriving (Show, Generic)+      deriving (Show)  -------------------------------------------------------------------------------- -- Responses@@ -224,15 +232,21 @@   -- | Found many breakpoints.   -- Caused by setting breakpoint on a name with multiple matches or many equations.   | ManyBreaksFound [BreakFound]-  deriving (Show, Generic)+  deriving (Show)  data EvalResult-  = EvalCompleted { resultVal :: String, resultType :: String }+  = EvalCompleted { resultVal :: String+                  , resultType :: String+                  , resultStructureRef :: VariableReference+                  -- ^ A structured representation of the result of evaluating+                  -- the expression given as a "virtual" 'VariableReference'+                  -- that the user can expand as a normal variable.+                  }   | EvalException { resultVal :: String, resultType :: String }   | EvalStopped   { breakId :: Maybe GHC.InternalBreakpointId {-^ 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)+  deriving (Show)  data StackFrame   = StackFrame@@ -241,58 +255,15 @@     , sourceSpan :: SourceSpan     -- ^ Source span for this stack frame     }-  deriving (Show, Generic)+  deriving (Show)  -------------------------------------------------------------------------------- -- 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.InternalBreakpointId where   show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix -instance ToJSON GHC.InternalBreakpointId where-  toJSON (GHC.InternalBreakpointId (Module unit mn) ix) =-    object [ "module_name" .= moduleNameString mn-           , "module_unit" .= unitString unit-           , "ix" .= ix-           ]-instance FromJSON GHC.InternalBreakpointId where-  parseJSON = withObject "InternalBreakpointId" $ \v -> GHC.InternalBreakpointId-        <$> (Module <$> (stringToUnit <$> v .: "module_unit") <*> (mkModuleName <$> v .: "module_name"))-        <*> v .: "ix"

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -5,49 +6,62 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}  module GHC.Debugger.Monad where -import Prelude hiding (mod)-import Data.Function-import System.Exit-import System.IO-import System.FilePath (normalise)-import System.Directory (makeAbsolute) import Control.Monad-import Control.Monad.IO.Class-import Control.Exception (assert)- import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Function+import Data.IORef+import Data.Maybe+import Prelude hiding (mod)+import System.IO+import System.Posix.Signals+import qualified Data.IntMap as IM+import qualified Data.List as L+import qualified Data.List.NonEmpty as NonEmpty  import GHC-import qualified GHCi.BreakArray as BA+import GHC.Data.FastString+import GHC.Data.StringBuffer+import GHC.Driver.Config.Diagnostic import GHC.Driver.DynFlags as GHC+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Main+import GHC.Driver.Make+import GHC.Driver.Ppr+import GHC.Runtime.Eval+import GHC.Runtime.Heap.Inspect+import GHC.Runtime.Interpreter as GHCi+import GHC.Runtime.Loader as GHC+import GHC.Types.Error+import GHC.Types.PkgQual+import GHC.Types.SourceError+import GHC.Types.SourceText+import GHC.Types.Unique.Supply as GHC+import GHC.Unit.Module.Graph import GHC.Unit.Module.ModSummary as GHC-import GHC.Utils.Outputable as GHC+import GHC.Unit.Types import GHC.Utils.Logger as GHC-import GHC.Types.Unique.Supply as GHC-import GHC.Runtime.Loader as GHC-import GHC.Runtime.Interpreter as GHCi-import GHC.Runtime.Heap.Inspect-import GHC.Unit.Module.Env as GHC-import GHC.Runtime.Debugger.Breakpoints-import GHC.Driver.Env--import Data.IORef-import Data.Maybe-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.IntMap as IM--import Control.Monad.Reader+import GHC.Utils.Outputable as GHC+import qualified GHC.LanguageExtensions as LangExt  import GHC.Debugger.Interface.Messages-import GHC.Debugger.Runtime.Term.Key+import GHC.Debugger.Logger as Logger import GHC.Debugger.Runtime.Term.Cache+import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Session-import System.Posix.Signals+import GHC.Debugger.Session.Builtin+import qualified GHC.Debugger.Breakpoint.Map as BM +import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache)+ -- | A debugger action. newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a }   deriving ( Functor, Applicative, Monad, MonadIO@@ -58,8 +72,8 @@ -- -- - 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+      { activeBreakpoints :: IORef (BM.BreakpointMap (BreakpointStatus, BreakpointKind))+        -- ^ Maps a 'InternalBreakpointId' in Trie representation (map of Module to map of Int) to the         -- 'BreakpointStatus' it was activated with.        , varReferences     :: IORef (IM.IntMap TermKey, TermKeyMap Int)@@ -76,8 +90,32 @@       , termCache         :: IORef TermCache       -- ^ TermCache +      , rtinstancesCache :: IORef RuntimeInstancesCache+      -- ^ RuntimeInstancesCache+       , genUniq           :: IORef Int       -- ^ Generates unique ints++      , hsDbgViewUnitId   :: Maybe UnitId+      -- ^ The unit-id of the companion @haskell-debugger-view@ unit, used for+      -- user-defined and built-in custom debug visualisations of values (e.g.+      -- for Strings or IntMap).+      --+      -- If the user depends on @haskell-debugger-view@ in its transitive+      -- closure, then we should use that exact unit which was solved by Cabal.+      -- The built-in instances and additional instances be available for the+      -- 'DebugView' class found in that unit. We can find the exact unit of+      -- the module by looking for @haskell-debugger-view@ in the module graph.+      --+      -- If the user does not depend on @haskell-debugger-view@ in any way,+      -- then we create our own unit and try to load the+      -- @haskell-debugger-view@ modules directly into it. As long as loading+      -- succeeds, the 'DebugView' class from this custom unit can be used to+      -- find the built-in instances for types like @'String'@+      --+      -- If the user explicitly disabled custom views, use @Nothing@.++      , dbgLogger :: Recorder (WithSeverity DebuggerMonadLog)       }  -- | Enabling/Disabling a breakpoint@@ -91,8 +129,15 @@       | BreakpointEnabled       -- | Breakpoint is disabled the first N times and enabled afterwards       | BreakpointAfterCount Int-      deriving (Eq, Ord)+      -- | Breakpoint is enabled when condition evaluates to true+      | BreakpointWhenCond String+      -- | Breakpoint is disabled the first N times the condition evaluates to+      -- true and enabled in the next time it is true+      | BreakpointAfterCountCond Int String+      deriving (Eq, Ord, Show) +instance Outputable BreakpointStatus where ppr = text . show+ -------------------------------------------------------------------------------- -- Operations --------------------------------------------------------------------------------@@ -104,17 +149,19 @@       }  -- | 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.+runDebugger :: Recorder (WithSeverity DebuggerMonadLog)+            -> Handle     -- ^ The handle to which GHC's output is logged. The debuggee output is not affected by this parameter.             -> FilePath   -- ^ Cradle root directory             -> FilePath   -- ^ Component root directory             -> FilePath   -- ^ The libdir (given with -B as an arg)             -> [String]   -- ^ The list of units included in the invocation             -> [String]   -- ^ The full ghc invocation (as constructed by hie-bios flags)+            -> [String]   -- ^ The extra GHC arguments (as given by the user in @extraGhcArgs@)             -> FilePath   -- ^ Path to the main function             -> RunDebuggerSettings -- ^ Other debugger run settings             -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation             -> IO a-runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Debugger action) = do+runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = do   let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation'   GHC.runGhc (Just libdir) $ do     -- Workaround #4162@@ -127,7 +174,8 @@           , GHC.canUseColor = conf.supportsANSIStyling           , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks           }-          -- Default GHCi settings+          -- Default debugger settings+          `GHC.xopt_set` LangExt.PackageImports           `GHC.gopt_set` GHC.Opt_ImplicitImportQualified           `GHC.gopt_set` GHC.Opt_IgnoreOptimChanges           `GHC.gopt_set` GHC.Opt_IgnoreHpcChanges@@ -138,155 +186,242 @@      GHC.modifyLogger $       -- Override the logger to output to the given handle-      GHC.pushLogHook (const $ debuggerLoggerAction dbg_out)+      GHC.pushLogHook $ const $ debuggerLoggerAction dbg_out -    -- TODO: this is weird, we set the session dynflags now to initialise-    -- the hsc_interp.-    -- This is incredibly dubious-    _ <- GHC.setSessionDynFlags dflags1+    dflags2 <- getLogger >>= \logger -> do+      -- Set the extra GHC arguments for ALL units by setting them early in+      -- dynflags. This is important to make sure unfoldings for interfaces+      -- loaded because of the built-in loaded classes (like+      -- GHC.Debugger.View.Class) behave the same as if they were loaded for+      -- the user program. Otherwise we may run into the problem which+      -- 3093efa27468fb2d31a617f6a0e4ff67a90f6623 tried to fix (but had to be+      -- reverted)+      (dflags2, fileish_args, warns)+        <- parseDynamicFlags logger dflags1 (map noLoc extraGhcArgs)+      liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)+      -- todo: consider fileish_args?+      forM_ fileish_args $ \fish_arg -> liftIO $ do+        logMsg logger MCOutput noSrcSpan $ text "Ignoring extraGhcArg which isn't a recognized flag:" <+> text (unLoc fish_arg)+        printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)+      return dflags2 +    -- Set the session dynflags now to initialise the hsc_interp.+    _ <- GHC.setSessionDynFlags dflags2+     -- Initialise plugins here because the plugin author might already expect this     -- subsequent call to `getLogger` to be affected by a plugin.     GHC.initializeSessionPlugins -    flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags1 rootDir+    GHC.getSessionDynFlags >>= \df -> liftIO $+      GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df)++    -- Discover the user-given flags and targets+    flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir++    -- Setup base HomeUnitGraph     setupHomeUnitGraph (NonEmpty.toList flagsAndTargets)+    -- Downsweep user-given modules first +    mod_graph_base <- doDownsweep Nothing -    dflags6 <- GHC.getSessionDynFlags+    if_cache <- Just <$> liftIO newIfaceCache -    -- Should this be done in GHC=-    liftIO $ GHC.initUniqSupply (GHC.initialUnique dflags6) (GHC.uniqueIncrement dflags6)+    -- Try to find or load the built-in classes from `haskell-debugger-view`+    (hdv_uid, loadedBuiltinModNames) <- findHsDebuggerViewUnitId mod_graph_base >>= \case+      Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do -    ok_flag <- GHC.load GHC.LoadAllTargets-    when (GHC.failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+        -- Not imported by any module: no custom views. Therefore, the builtin+        -- ones haven't been loaded. In this case, we will load the package ourselves. -    -- TODO: Shouldn't initLoaderState be called somewhere?+        -- Add the custom unit to the HUG+        let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base]+        addInMemoryHsDebuggerViewUnit base_dep_uids =<< getDynFlags +        tryLoadHsDebuggerViewModule l if_cache (const False) debuggerViewClassModName debuggerViewClassContents+          >>= \case+            Failed -> do+              -- Failed to load base debugger-view module!+              logWith l Debug $ LogFailedToCompileDebugViewModule debuggerViewClassModName+              return []+            Succeeded -> (debuggerViewClassModName:) . concat <$> do++              forM debuggerViewInstancesMods $ \(modName, modContent, pkgName) -> do+                -- Don't try to load instances whose packages are not even in+                -- the module graph:+                if any ((pkgName `L.isPrefixOf`) . unitIdString) base_dep_uids then do+                  tryLoadHsDebuggerViewModule l if_cache+                      ((\case+                          -- Keep only "GHC.Debugger.View.Class", which is a dependency of all these.+                          GHC.TargetFile f _+                            -> f == "in-memory:" ++ moduleNameString debuggerViewClassModName+                          _ -> False) . GHC.targetId)+                      modName modContent >>= \case+                    Failed -> do+                      logWith l Info $ LogFailedToCompileDebugViewModule modName+                      return []+                    Succeeded -> do+                      return [modName]+                else do+                  logWith l Debug $ LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids)+                  return []++      Just uid ->+        -- TODO: We assume for now that if you depended on+        -- @haskell-debugger-view@, then you also depend on all its transitive+        -- dependencies (containers, text, ...), thus can load all custom+        -- views. Hence all `debuggerViewBuiltinMods`. In the future, we+        -- may want to guard all dependencies behind cabal flags that the user+        -- can tweak when depending on `haskell-debugger-view`.+        return (uid, map fst debuggerViewBuiltinMods)++    -- Final load combining all base modules plus haskell-debugger-view ones that loaded successfully+    -- The targets which were successfully loaded have been set with `setTarget` (e.g. by setupHomeUnitGraph).+    final_mod_graph <- doDownsweep (Just mod_graph_base{-cached previous result-})+    success <- doLoad if_cache GHC.LoadAllTargets final_mod_graph+    when (GHC.failed success) $ liftIO $+      throwM DebuggerFailedToLoad+     -- 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"+    -- dbgView should always be available, either because we manually loaded it+    -- or because it's in the transitive closure.+    let dbgViewImps+          -- Using in-memory hs-dbg-view. It's a home-unit, so refer to it directly+          | hdv_uid == hsDebuggerViewInMemoryUnitId+          = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames+          -- It's available in a unit in the transitive closure. Resolve it.+          | otherwise+          = map (\mn ->+              GHC.IIDecl (GHC.simpleImportDecl mn)+              { ideclPkgQual = RawPkgQual+                  StringLiteral+                    { sl_st = NoSourceText+                    , sl_fs = mkFastString (unitIdString hdv_uid)+                    , sl_tc = Nothing+                    }+              }) loadedBuiltinModNames+     mss <- getAllLoadedModules-    GHC.setContext $ preludeImp : map (GHC.IIModule . GHC.ms_mod) mss -    runReaderT action =<< initialDebuggerState+    GHC.setContext+      (preludeImp :+        dbgViewImps +++        map (GHC.IIModule . GHC.ms_mod) mss) +    runReaderT action =<< initialDebuggerState l (if loadedBuiltinModNames == [] then Nothing else Just hdv_uid) --- | 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, [GHC.InternalBreakpointId])-registerBreakpoint bp@GHC.BreakpointId-                    { GHC.bi_tick_mod = mod-                    , GHC.bi_tick_index = bid } status kind = do+-- | Run downsweep on the currently set targets (see @hsc_targets@)+doDownsweep :: GhcMonad m+            => Maybe ModuleGraph -- ^ Re-use existing module graph which was already summarised+            -> m ModuleGraph -- ^ Module graph constructed from current set targets+doDownsweep reuse_mg = do+  hsc_env <- getSession+#if MIN_VERSION_ghc(9,15,0)+  let msg = batchMultiMsg hsc_env+#else+  let msg = batchMultiMsg+#endif+  (errs_base, mod_graph) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic (Just msg) (maybe [] mgModSummaries reuse_mg) [] False+  when (not $ null errs_base) $ do+#if MIN_VERSION_ghc(9,15,0)+    sec <- initSourceErrorContext . hsc_dflags <$> getSession+    throwErrors sec (fmap GhcDriverMessage (unionManyMessages errs_base))+#else+    throwErrors (fmap GhcDriverMessage (unionManyMessages errs_base))+#endif+  return mod_graph -  -- Set breakpoint in GHC session-  let breakpoint_count = breakpointStatusInt status-  hsc_env <- GHC.getSession-  internal_break_ids <- getInternalBreaksOf bp-  forM_ internal_break_ids $ \ibi -> do-    GHC.setupBreakpoint (hscInterp hsc_env) ibi breakpoint_count+doLoad :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> ModuleGraph -> m SuccessFlag+doLoad if_cache how_much mg = do+#if MIN_VERSION_ghc(9,15,0)+  msg <- batchMultiMsg <$> getSession+#else+  let msg = batchMultiMsg+#endif+  load' if_cache how_much mkUnknownDiagnostic (Just msg) mg -  -- 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)+-- | Returns @Just modName@ if the given module was successfully loaded+tryLoadHsDebuggerViewModule+  :: GhcMonad m+  => Recorder (WithSeverity DebuggerMonadLog)+  -> Maybe ModIfaceCache+  -> (GHC.Target -> Bool)+  -- ^ Predicate to determine which of the existing+  -- targets should be re-used when doing downsweep+  -- Should be as minimal as necessary (i.e. just DebugView class for the+  -- instances modules).+  -> ModuleName -> StringBuffer -> m SuccessFlag+tryLoadHsDebuggerViewModule l if_cache keepTarget modName modContents = do+  dflags <- getDynFlags+  -- Store existing targets to restore afterwards+  -- We want to use as little targets as possible to keep downsweep minimal+fast+  old_targets <- GHC.getTargets -      -- 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)+  -- Also: temporarily disable the logger! We don't want to show the user these+  -- modules we're trying to load and compile.+  restore_logger <- GHC.getLogger+  GHC.modifyLogger $+    -- Emit it all as Debug-level logs+    GHC.pushLogHook $ const $ \_ _ _ sdoc ->+      logWith l Logger.Debug $ LogSDoc dflags sdoc -  -- no races since the debugger execution is run in a single thread-  liftIO $ writeIORef brksRef newBrks-  return (changed, internal_break_ids)+  -- Make the target+  dvcT <- liftIO $ makeInMemoryHsDebuggerViewTarget modName modContents +  -- Make mod_graph just for this target+  GHC.setTargets (dvcT:filter keepTarget old_targets)+  dvc_mod_graph <- doDownsweep Nothing --- | 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.InternalBreakpointId]-getActiveBreakpoints mfile = do-  m <- asks activeBreakpoints >>= liftIO . readIORef-  case mfile of-    Just file -> do-      mms <- getModuleByPath file-      case mms of-        Right ms ->-          concat <$> mapM getInternalBreaksOf-            [ 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-      concat <$> mapM getInternalBreaksOf-        [ GHC.BreakpointId mod bix-        | (mod, im) <- moduleEnvToList m-        , (bix, (status, kind)) <- IM.assocs im+  -- And try to load it+  result <- doLoad if_cache (GHC.LoadUpTo [mkModule hsDebuggerViewInMemoryUnitId modName]) dvc_mod_graph -        -- Keep only function breakpoints in this case-        , FunctionBreakpointKind == kind+  -- Restore targets plus new one if success+  GHC.setTargets (old_targets ++ (if succeeded result then [dvcT] else [])) -        , assert (status > BreakpointDisabled) True-        ]+  -- Restore logger+  GHC.modifyLogger $+    GHC.pushLogHook (const $ putLogMsg restore_logger) --- | List all loaded modules 'ModSummary's-getAllLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]-getAllLoadedModules =-  (GHC.mgModSummaries <$> GHC.getModuleGraph) >>=-    filterM (\ms -> GHC.isLoadedModule (GHC.ms_unitid ms) (GHC.ms_mod_name ms)) --- | Get a 'ModSummary' of a loaded module given its 'FilePath'-getModuleByPath :: FilePath -> Debugger (Either String ModSummary)-getModuleByPath path = do-  -- do this every time as the loaded modules may have changed-  lms <- getAllLoadedModules-  absPath <- liftIO $ makeAbsolute path-  let matches ms = normalise (msHsFilePath ms) == normalise absPath-  return $ case filter matches lms of-    [x] -> Right x-    [] -> Left $ "No module matched " ++ path ++ ".\nLoaded modules:\n" ++ show (map msHsFilePath lms) ++ "\n. Perhaps you've set a breakpoint on a module that isn't loaded into the session?"-    xs -> Left $ "Too many modules (" ++ showPprUnsafe xs ++ ") matched " ++ path ++ ". Please report a bug at https://github.com/well-typed/haskell-debugger."+  return result  --------------------------------------------------------------------------------+-- * Finding Debugger View+--------------------------------------------------------------------------------++-- | Fetch the @haskell-debugger-view@ unit-id from the environment.+-- @Nothing@ means custom debugger views are disabled.+getHsDebuggerViewUid :: Debugger (Maybe UnitId)+getHsDebuggerViewUid = asks hsDbgViewUnitId++-- | Try to find the @haskell-debugger-view@ unit-id in the transitive closure,+-- or, otherwise, return the a custom unit for which we'll load the+-- @haskell-debugger-view@ modules in it (essentially preparing an in-memory+-- version of the library to find the built-in instances in).+--+-- See also comment on the @'hsDbgViewUnitId'@ field of @'DebuggerState'@+findHsDebuggerViewUnitId :: ModuleGraph -> GHC.Ghc (Maybe UnitId)+findHsDebuggerViewUnitId mod_graph = do++  -- Only looks at unit-nodes, this is not robust!+  -- TODO: Better lookup of unit-id+  let hskl_dbgr_vws =+        [ uid+        | UnitNode _deps uid <- mg_mss mod_graph+        , "haskell-debugger-view" `L.isPrefixOf` unitIdString uid+        ]++  case hskl_dbgr_vws of+    [hdv_uid] ->+      -- In transitive closure, use that one.+      return (Just hdv_uid)+    [] -> do+      return Nothing+    _  ->+      error "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!"++-------------------------------------------------------------------------------- -- Variable references -------------------------------------------------------------------------------- @@ -331,22 +466,67 @@ -- Utilities -------------------------------------------------------------------------------- +-- | 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 :: Recorder (WithSeverity DebuggerMonadLog) -> Maybe UnitId -> GHC.Ghc DebuggerState+initialDebuggerState l hsDbgViewUid =+  DebuggerState <$> liftIO (newIORef BM.empty)+                <*> liftIO (newIORef mempty)+                <*> liftIO (newIORef mempty)+                <*> liftIO (newIORef emptyRuntimeInstancesCache)+                <*> liftIO (newIORef 0)+                <*> pure hsDbgViewUid+                <*> pure l++-- | Lift a 'Ghc' action into a 'Debugger' one.+liftGhc :: GHC.Ghc a -> Debugger a+liftGhc = Debugger . ReaderT . const++data DebuggerFailedToLoad = DebuggerFailedToLoad+instance Exception DebuggerFailedToLoad+instance Show DebuggerFailedToLoad where+  show DebuggerFailedToLoad = "Failed to compile and load user project."++--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- * Modules+--------------------------------------------------------------------------------++-- | List all loaded modules 'ModSummary's+getAllLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getAllLoadedModules =+  (GHC.mgModSummaries <$> GHC.getModuleGraph) >>=+    filterM (\ms -> GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms))++--------------------------------------------------------------------------------+-- * Forcing laziness+--------------------------------------------------------------------------------++-- | The depth determines how much of the runtime structure is traversed.+-- @obtainTerm@ and friends handle fetching arbitrarily nested data structures+-- so we only depth enough to get to the next level of subterms. defaultDepth :: Int-defaultDepth =  2 -- the depth determines how much of the runtime structure is traversed.-                  -- @obtainTerm@ and friends handle fetching arbitrarily nested data structures-                  -- so we only depth enough to get to the next level of subterms.+defaultDepth =  2  -- | 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+seqTerm :: HscEnv -> Term -> IO Term+seqTerm hsc_env term = do   let     interp = hscInterp hsc_env     unit_env = hsc_unit_env hsc_env   case term of-    Suspension{val, ty} -> liftIO $ do+    Suspension{val, ty} -> do       r <- GHCi.seqHValue interp unit_env val       () <- fromEvalResult r       let@@ -354,69 +534,24 @@         forceDepth  = defaultDepth       cvObtainTerm hsc_env forceDepth forceThunks ty val     NewtypeWrap{wrapped_term} -> do-      wrapped_term' <- seqTerm wrapped_term+      wrapped_term' <- seqTerm hsc_env wrapped_term       return term{wrapped_term=wrapped_term'}     _ -> return term  -- | Evaluate a Term to NF-deepseqTerm :: Term -> Debugger Term-deepseqTerm t = case t of-  Suspension{}   -> do t' <- seqTerm t-                       deepseqTerm t'-  Term{subTerms} -> do subTerms' <- mapM deepseqTerm subTerms+deepseqTerm :: HscEnv -> Term -> IO Term+deepseqTerm hsc_env t = case t of+  Suspension{}   -> do t' <- seqTerm hsc_env t+                       deepseqTerm hsc_env t'+  Term{subTerms} -> do subTerms' <- mapM (deepseqTerm hsc_env) subTerms                        return t{subTerms = subTerms'}   NewtypeWrap{wrapped_term}-                 -> do wrapped_term' <- deepseqTerm wrapped_term+                 -> do wrapped_term' <- deepseqTerm hsc_env wrapped_term                        return t{wrapped_term = wrapped_term'}-  _              -> do seqTerm t----- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'.------ We use this in 'doEval' because we want to ignore breakpoints in expressions given at the prompt.-continueToCompletion :: Debugger GHC.ExecResult-continueToCompletion = do-  execr <- GHC.resumeExec GHC.RunToCompletion Nothing-  case execr of-    GHC.ExecBreak{} -> continueToCompletion-    GHC.ExecComplete{} -> return execr---- | Turn a 'BreakpointStatus' into its 'Int' representation for 'BreakArray'-breakpointStatusInt :: BreakpointStatus -> Int-breakpointStatusInt = \case-  BreakpointEnabled      -> BA.breakOn  -- 0-  BreakpointDisabled     -> BA.breakOff -- -1-  BreakpointAfterCount n -> n           -- n---- | Generate a new unique 'Int'-freshInt :: Debugger Int-freshInt = do-  ioref <- asks genUniq-  i <- readIORef ioref & liftIO-  let !i' = i+1-  writeIORef ioref i'  & liftIO-  return i---- | Initialize a 'DebuggerState'-initialDebuggerState :: GHC.Ghc DebuggerState-initialDebuggerState = DebuggerState <$> liftIO (newIORef emptyModuleEnv)-                                     <*> liftIO (newIORef mempty)-                                     <*> liftIO (newIORef mempty)-                                     <*> liftIO (newIORef 0)---- | Lift a 'Ghc' action into a 'Debugger' one.-liftGhc :: GHC.Ghc a -> Debugger a-liftGhc = Debugger . ReaderT . const------------------------------------------------------------------------------------type Warning = String--displayWarnings :: [Warning] -> Debugger ()-displayWarnings = liftIO . putStrLn . unlines+  _              -> do seqTerm hsc_env t  ----------------------------------------------------------------------------------- Instances+-- * Instances --------------------------------------------------------------------------------  instance GHC.HasLogger Debugger where@@ -427,11 +562,52 @@   setSession s = liftGhc $ GHC.setSession s  --------------------------------------------------------------------------------+-- * Logging+-------------------------------------------------------------------------------- --- | Find all the internal breakpoints that use the given source-level breakpoint id-getInternalBreaksOf :: BreakpointId -> Debugger [InternalBreakpointId]-getInternalBreaksOf bi = do-  bs <- mkBreakpointOccurrences-  return $-    fromMaybe [] {- still not found after refresh -} $-      lookupBreakpointOccurrences bs bi+-- | The logger action used to log GHC output+debuggerLoggerAction :: Handle -> GHC.LogAction+debuggerLoggerAction h a b c d = do+  hSetEncoding h utf8 -- GHC output uses utf8+  -- potentially use the `Recorder` here?+  defaultLogActionWithHandles h h a b c d++data DebuggerMonadLog+  = LogFailedToCompileDebugViewModule GHC.ModuleName+  | LogSkippingViewModuleNoPkg GHC.ModuleName String [String]+  | LogSDoc DynFlags SDoc++instance Pretty DebuggerMonadLog where+  pretty = \ case+    LogFailedToCompileDebugViewModule mn ->+      pretty $ "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views."+    LogSkippingViewModuleNoPkg mn pkg uids ->+      pretty $ "Skipping compilation of built-in " ++ moduleNameString mn ++ " module because package "+                ++ show pkg ++ " wasn't found in dependencies " ++ show uids+    LogSDoc dflags doc ->+      pretty $ showSDoc dflags doc++logSDoc :: Logger.Severity -> SDoc -> Debugger ()+logSDoc sev doc = do+  dflags <- getDynFlags+  l <- asks dbgLogger+  logWith l sev (LogSDoc dflags doc)++logAction :: Recorder (WithSeverity DebuggerMonadLog) -> DynFlags -> GHC.LogAction+logAction l dflags = \_ msg_class _ sdoc -> do+    logWith l (msgClassSeverity msg_class) $ LogSDoc dflags sdoc++msgClassSeverity :: MessageClass -> Logger.Severity+msgClassSeverity = \case+  MCOutput -> Info+  MCFatal -> Logger.Error+  MCInteractive -> Info+  MCDump -> Debug+  MCInfo -> Info+  MCDiagnostic sev _ _ -> ghcSevSeverity sev++ghcSevSeverity :: GHC.Severity -> Logger.Severity+ghcSevSeverity = \case+  SevIgnore -> Debug -- ?+  SevWarning -> Logger.Warning+  SevError -> Logger.Error

@@ -1,4 +1,4 @@-{-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns #-}+{-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns, TemplateHaskellQuotes #-} module GHC.Debugger.Runtime where  import Data.IORef@@ -6,8 +6,8 @@ import qualified Data.List as L  import GHC+import GHC.Utils.Outputable import GHC.Types.FieldLabel-import GHC.Tc.Utils.TcType import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect @@ -29,17 +29,11 @@     -- cache miss: reconstruct, then store.     Nothing ->       let-        -- For boring types we want to get the value as it is (by traversing it to-        -- the end), rather than stopping short and returning a suspension (e.g.-        -- for the string tail), because boring types are printed whole rather than-        -- being represented by an expandable structure.-        depth i = if isBoringTy (GHC.idType i) then maxBound else defaultDepth-         -- Recursively get terms until we hit the desired key.         getTerm = \case-          FromId i -> GHC.obtainTermFromId (depth i) False{-don't force-} i+          FromId i -> GHC.obtainTermFromId defaultDepth False{-don't force-} i           FromPath k pf -> do-            term <- getTerm k+            term <- obtainTerm k             liftIO $ expandTerm hsc_env $ case term of               Term{dc=Right dc, subTerms} -> case pf of                 PositionalIndex ix -> subTerms !! (ix-1)@@ -49,7 +43,12 @@                     Nothing -> error "Couldn't find labeled field in dataConFieldLabels"               NewtypeWrap{wrapped_term} ->                 wrapped_term -- regardless of PathFragment-              _ -> error "Unexpected term for the given TermKey"+              RefWrap{wrapped_term} ->+                wrapped_term -- regardless of PathFragment+              _ -> error ("Unexpected term for the given TermKey because <term> should have been expanded before and we're getting a path fragment!\n" ++ showPprUnsafe (ppr key <+> ppr k <+> ppr pf))+          FromCustomTerm _key _name ctm -> do+            -- For custom terms return them straightaway.+            liftIO $ expandTerm hsc_env ctm        in do         term <- getTerm key         liftIO $ modifyIORef tc_ref (insertTermCache key term)@@ -65,18 +64,12 @@ expandTerm :: HscEnv -> Term -> IO Term expandTerm hsc_env term = case term of   Term{val, ty} -> cvObtainTerm hsc_env defaultDepth False ty val-  (NewtypeWrap{}; RefWrap{}) -> do-    -- TODO: we don't do anything clever here yet-    return term-  -- For other terms there's no point in trying to expand-  (Suspension{}; Prim{}) -> return term---- | 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-+  RefWrap{wrapped_term} -> do+    wt' <- expandTerm hsc_env wrapped_term+    return term{wrapped_term=wt'}+  NewtypeWrap{wrapped_term} -> do+    wt' <- expandTerm hsc_env wrapped_term+    return term{wrapped_term=wt'}+  Suspension{val, ty} -> cvObtainTerm hsc_env defaultDepth False ty val+  Prim{} -> return term 

@@ -0,0 +1,153 @@+{-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments #-}+module GHC.Debugger.Runtime.Instances where++import Control.Exception+import Control.Monad+import Control.Monad.Reader++import GHC+import GHC.Builtin.Names+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Driver.Config+import GHC.Driver.Env+import GHC.Driver.Main+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad+import GHC.Plugins+import GHC.Rename.Env+import GHC.Rename.Expr+import GHC.Runtime.Eval+import GHC.Runtime.Heap.Inspect+import GHC.Runtime.Interpreter as Interp+import GHC.Tc.Gen.Expr+import GHC.Tc.Solver+import GHC.Tc.Types.Evidence+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcType+import GHC.Tc.Zonk.Type+import GHCi.Message++import GHC.Debugger.Monad+import GHC.Debugger.Session.Builtin+import GHC.Debugger.View.Class+import GHC.Debugger.Logger as Logger++import GHC.Debugger.Runtime.Instances.Discover++--------------------------------------------------------------------------------+-- * High level interface for 'DebugView' on 'Term's+--------------------------------------------------------------------------------++-- | Get the custom representation of this 'Term' by applying a 'DebugView'+-- instance 'debugValue' method if there is one.+debugValueTerm :: Term -> Debugger (Maybe VarValue)+debugValueTerm term = do+  hsc_env <- getSession+  let interp = hscInterp hsc_env+  let ty = termType term+  mbInst <- getDebugViewInstance ty+  case mbInst of+    Nothing -> return Nothing+    Just DebugViewInstance+      {instDebugValue, varValueIOTy} -> do+        liftIO (instDebugValue (val term)) >>= \case+          Left _e ->+            -- exception! ignore.+            return Nothing+          Right transformed_v -> do++            liftIO (cvObtainTerm hsc_env maxBound True varValueIOTy transformed_v) >>= \case++              -- Get the Term of the VarValue to decode fields+              Term{ ty=_{-assert==VarValueIO-}+                  , subTerms=[strTerm, boolTerm]+                  } -> do++                valStr <- liftIO $+                  evalString interp (val strTerm {- whose type is IO String, from varValueIO -})++                let valBool = case boolTerm of+                      Term{dc=Left "False"} -> False+                      Term{dc=Left "True"}  -> True+                      Term{dc=Right dc}+                        | falseDataCon == dc -> False+                      Term{dc=Right dc}+                        | trueDataCon == dc -> True+                      _ -> error "Decoding of VarValue failed"++                return $ Just VarValue+                  { varValue = valStr+                  , varExpandable = valBool+                  }+              _ ->+                -- Unexpected; the Term of VarValue should always be Term.+                return Nothing++-- | Get the custom representation of this 'Term' by applying a 'DebugView'+-- instance 'debugFields' method if there is one.+--+-- Returns the mappings from field labels to terms, where each term records the+-- type and pointer to the foreign heap value returned in the instance for that label.+--+-- Returns @Nothing@ if no instance was found for the type of the given term+debugFieldsTerm :: Term -> Debugger (Maybe [(String, Term)])+debugFieldsTerm term = do+  hsc_env <- getSession+  let interp = hscInterp hsc_env+  let ty = termType term+  mbInst <- getDebugViewInstance ty+  case mbInst of+    Nothing -> return Nothing+    Just DebugViewInstance+      {instDebugFields, varFieldsIOTy} -> do+        liftIO (instDebugFields (val term)) >>= \case+          Left _e ->+            -- exception! ignore.+            return Nothing+          Right transformed_v -> do++            liftIO (cvObtainTerm hsc_env 2 True varFieldsIOTy transformed_v) >>= \case++              -- Get the Term of the VarFieldsIO+              NewtypeWrap+                { wrapped_term=fieldsListTerm+                } -> do++                fieldsTerms <- listTermToTermsList fieldsListTerm++                -- Process each term for the instance fields+                Just <$> forM fieldsTerms \fieldTerm0 -> liftIO $ do+                  -- Expand @(IO String, VarFieldValue)@ tuple term for each field+                  seqTerm hsc_env fieldTerm0 >>= \case+                    Term{subTerms=[ioStrTerm, varFieldValTerm]} -> do++                      fieldStr <- evalString interp (val ioStrTerm)++                      -- Expand VarFieldValue term+                      seqTerm hsc_env varFieldValTerm >>= \case+                        Term{subTerms=[unexpandedValueTerm]} -> do+                          actualValueTerm <- liftIO $ do+                            let val_ty = termType unexpandedValueTerm+                            cvObtainTerm hsc_env defaultDepth False{-don't force-} val_ty (val unexpandedValueTerm)+                          return (fieldStr, actualValueTerm)++                        _ -> error "impossible; expected VarFieldValue"+                    _ -> error "impossible; expected 2-tuple term"+              _ -> error "debugFields instance returned something other than VarFields"++-- | Convert a Term representing a list @[a]@ to a list of the terms of type+-- @a@, where @a@ is the given @'Type'@ arg.+--+-- PRE-CON: Term represents a @[a]@+listTermToTermsList :: Term -> Debugger [Term]+listTermToTermsList Term{subTerms=[head_term, tail_term]}+  = do+    hsc_env <- getSession+    -- Expand next term:+    tail_term' <- liftIO $+      seqTerm hsc_env tail_term+    (head_term:) <$> listTermToTermsList tail_term'+listTermToTermsList _ = pure []+

@@ -0,0 +1,196 @@+module GHC.Debugger.Runtime.Instances.Discover+  (+  -- * Runtime 'DebugView' instance+    DebugViewInstance(..)++  -- * Cache for runtime instances+  , RuntimeInstancesCache+  , getDebugViewInstance+  , emptyRuntimeInstancesCache+  ) where++import Data.IORef+import Data.Function ((&))+import Control.Exception+import Control.Monad.Reader++import GHC+import GHC.Builtin.Names+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.Map.Type+import GHC.Driver.Config+import GHC.Driver.Env+import GHC.Driver.Main+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad+import GHC.Plugins+import GHC.Rename.Env+import GHC.Rename.Expr+import GHC.Runtime.Interpreter as Interp+import GHC.Tc.Gen.Expr+import GHC.Tc.Solver+import GHC.Tc.Types.Evidence+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcType+import GHC.Tc.Zonk.Type+import GHCi.Message++import GHC.Debugger.Monad+import GHC.Debugger.Session.Builtin+import GHC.Debugger.Logger as Logger++--------------------------------------------------------------------------------+-- * The Cache-level interface for runtime 'DebugView' instances+--------------------------------------------------------------------------------++-- | Cache 'DebugView' instances found at runtime to avoid trying to find them again.+-- If we found that a particular type doesn't have an instance, we record that as well.+type RuntimeInstancesCache = TypeMap (Maybe DebugViewInstance)++-- | Get a 'DebugViewInstance' for the given type, if one exists.+-- Looks up in the cache and otherwise tries to find the instance.+-- Returns @Nothing@ if no instance could be found.+getDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)+getDebugViewInstance ty = do+  rtinMapRef <- asks rtinstancesCache+  rtinMap    <- readIORef rtinMapRef & liftIO+  case lookupTypeMap rtinMap ty of+    Nothing -> do+      res <- findDebugViewInstance ty+      writeIORef rtinMapRef+        (extendTypeMap rtinMap ty res) & liftIO+      return res+    Just res ->+      return res++-- | An empty 'RuntimeInstancesCache'+emptyRuntimeInstancesCache :: RuntimeInstancesCache+emptyRuntimeInstancesCache = emptyTypeMap++--------------------------------------------------------------------------------+-- * Medium level interface for 'DebugView' on 'ForeignHValue's+-- This is cached by GHC.Debugger.Runtime.Instances.Cache+--------------------------------------------------------------------------------++-- | A 'DebugView' instance wrapper to call on values on the (potentially+-- foreign) interpreter heap+data DebugViewInstance = DebugViewInstance+  { -- | 'debugValueIOWrapper' for a specific instance+    instDebugValue  :: ForeignHValue -> IO (Either SomeException ForeignHValue)++    -- | 'debugFieldsIOWrapper' for a specific instance+  , instDebugFields :: ForeignHValue -> IO (Either SomeException ForeignHValue)++    -- | 'VarValueIO' type+    -- todo: pointless to compute this every time... (both of them)+  , varValueIOTy  :: Type+    -- | 'VarFieldsIO' type+  , varFieldsIOTy :: Type+  }++--------------------------------------------------------------------------------+-- * Impl. to find instance and load instance methods applied to right dictionary+--------------------------------------------------------------------------------++-- | Try to find the 'DebugView' instance for a given type using the+-- @haskell-debugger-view@ unit found at session set-up time (see+-- @'hsDbgViewUnitId'@)+findDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance)+findDebugViewInstance needle_ty = do+  hsc_env <- getSession++  mhdv_uid <- getHsDebuggerViewUid+  case mhdv_uid of+    Just hdv_uid -> do+      let modl = mkModule (RealUnit (Definite hdv_uid)) debuggerViewClassModName+      let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr)++      (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ do++        -- Types used by DebugView+        varValueIOTy    <-  fmap mkTyConTy . tcLookupTyCon+                        =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarValueIO"))+        varFieldsIOTy   <-  fmap mkTyConTy . tcLookupTyCon+                        =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarFieldsIO"))++        ioTyCon <- tcLookupTyCon ioTyConName++        -- Try to compile and load an expression for all methods of `DebugView`+        -- applied to the dictionary for the given Type (`needle_ty`)+        let debugValueMN  = mthdRdrName "debugValueIOWrapper"+            debugFieldsMN = mthdRdrName "debugFieldsIOWrapper"+            debugValueWrapperMT =+              mkVisFunTyMany needle_ty $+                mkTyConApp ioTyCon [mkListTy varValueIOTy]+            debugFieldsWrapperMT =+              mkVisFunTyMany needle_ty $+                mkTyConApp ioTyCon [mkListTy varFieldsIOTy]+        !debugValue_fval  <- compileAndLoadMthd debugValueMN  debugValueWrapperMT+        !debugFields_fval <- compileAndLoadMthd debugFieldsMN debugFieldsWrapperMT++        let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone+            interp    = hscInterp hsc_env++            -- If we hit a breakpoint while evaluating this, just keep going.+            handleStatus (EvalBreak _ _ resume_ctxt _) = do+              resume_ctxt_fhv <- mkFinalizedHValue interp resume_ctxt+              handleStatus =<< Interp.resumeStmt interp eval_opts resume_ctxt_fhv+            -- When completed, return value+            handleStatus (EvalComplete _ (EvalException e)) =+              return (Left (fromSerializableException e))+            handleStatus (EvalComplete _ (EvalSuccess [hval])) =+              return (Right hval)+            handleStatus (EvalComplete _ (EvalSuccess _)) =+              return (Left (SomeException (userError "unexpected more than one value bound for evaluation of DebugView method")))++        return DebugViewInstance+          { instDebugValue = \x_fval -> do+              handleStatus =<< evalStmt interp eval_opts+                (EvalThis debugValue_fval `EvalApp` EvalThis x_fval)+          , instDebugFields = \x_fval -> do+              handleStatus =<< evalStmt interp eval_opts+                (EvalThis debugFields_fval `EvalApp` EvalThis x_fval)+          , varValueIOTy+          , varFieldsIOTy+          }++      case res of+        Nothing -> do+          logSDoc Logger.Debug $+            text "Couldn't compile DebugView instance for" <+> ppr needle_ty $$ ppr err_msgs+          -- The error is for debug purposes. We simply won't use a custom instance:+          return Nothing+        Just is ->+          return $ Just is+    Nothing ->+      -- Custom view is disabled+      return Nothing++-- | Try to compile and load a class method for the given type.+--+-- E.g. @compileAndLoadMthd "debugValue" (<ty> -> VarValue)@ returns the+-- foreign value for an expression @debugValue@ applied to the dictionary for+-- the requested type.+compileAndLoadMthd :: RdrName -- ^ Name of method/name of function that takes dictionary+                   -> Type    -- ^ The final type of expr when funct is alredy applied to dict+                   -> TcM ForeignHValue+compileAndLoadMthd mthName mthTy = do+  hsc_env <- getTopEnv++  let expr = nlHsVar mthName++  -- Rn, Tc, desugar applied to DebugView dictionary+  (expr', _)    <- rnExpr (unLoc expr)+  (expr'', wcs) <- captureConstraints $ tcExpr expr' (Check mthTy)+  ev            <- simplifyTop wcs+  failIfErrsM -- Before Zonking! If solving the constraint failed, `ev == []`.+  let final_exp = mkHsDictLet (EvBinds ev) (noLocA expr'')+  tc_expr_final <- zonkTopLExpr final_exp+  (_, Just ds_expr) <- initDsTc $ dsLExpr tc_expr_final++  -- Compile to a BCO and load it+  (mthd_fval, _, _) <- liftIO $ hscCompileCoreExpr hsc_env noSrcSpan ds_expr++  return mthd_fval

@@ -0,0 +1,7 @@+module GHC.Debugger.Runtime.Instances.Discover where++import GHC.Core.Map.Type++type RuntimeInstancesCache = TypeMap (Maybe DebugViewInstance)+data DebugViewInstance+emptyRuntimeInstancesCache :: RuntimeInstancesCache

@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs, DataKinds #-} module GHC.Debugger.Runtime.Term.Cache where  import GHC.Runtime.Eval@@ -38,7 +38,7 @@ --------------------------------------------------------------------------------  -- | Mapping from 'TermKey' to @a@. Backs 'TermCache', but is more general.-type TermKeyMap a = IdEnv (Map [PathFragment] a)+type TermKeyMap a = IdEnv (Map [PathFragment True] a)  -- | Lookup a 'TermKey' in a 'TermKeyMap'. lookupTermKeyMap :: TermKey -> TermKeyMap a -> Maybe a

@@ -1,10 +1,11 @@-{-# LANGUAGE GADTs, ViewPatterns #-}+{-# LANGUAGE GADTs, ViewPatterns, DataKinds #-} module GHC.Debugger.Runtime.Term.Key where  import Prelude hiding ((<>))  import GHC import GHC.Utils.Outputable+import GHC.Runtime.Eval  -- | A 'TermKey' serves to fetch a Term in a Debugger session. -- Note: A 'TermKey' is only valid in the stopped context it was created in.@@ -14,28 +15,40 @@    -- | Append a PathFragment to the current Term Key. Used to construct keys   -- for indexed and labeled fields.-  FromPath :: TermKey -> PathFragment -> TermKey+  FromPath :: TermKey -> PathFragment False -> TermKey +  -- | Use a custom term, by custom name, along a TermKey path, rather than+  -- reconstructing one from the 'FromId' root.+  FromCustomTerm :: TermKey -> String -> Term -> TermKey+ -- | A term may be identified by an 'Id' (such as a local variable) plus a list -- of 'PathFragment's to an arbitrarily nested field.-data PathFragment+data PathFragment (b :: Bool {- whether allow custom field -}) where   -- | A positional index is an index from 1 to inf-  = PositionalIndex Int+  PositionalIndex :: Int -> PathFragment b   -- | A labeled field indexes a datacon fields by name-  | LabeledField Name-  deriving (Eq, Ord)+  LabeledField    :: Name -> PathFragment b+  -- | Similar to LabeledField, but originates from a custom 'DebugView'+  -- instance rather than a proper data con label (hence why we don't have a name).+  CustomField     :: String -> PathFragment True+deriving instance Eq (PathFragment b)+deriving instance Ord (PathFragment b)  instance Outputable TermKey where-  ppr (FromId i)          = ppr i-  ppr (FromPath _ last_p) = ppr last_p+  ppr (FromId i)             = ppr i+  ppr (FromPath _ last_p)    = ppr last_p+  ppr (FromCustomTerm _ s _) = text s -instance Outputable PathFragment where+instance Outputable (PathFragment b) where   ppr (PositionalIndex i) = text "_" <> ppr i   ppr (LabeledField n)    = ppr n+  ppr (CustomField s)     = text s  -- | >>> unconsTermKey (FromPath (FromPath (FromId hi) (Pos 1)) (Pos 2)) -- (hi, [1, 2])-unconsTermKey :: TermKey -> (Id, [PathFragment])+unconsTermKey :: TermKey -> (Id, [PathFragment True]) unconsTermKey = go [] where-  go acc (FromId i) = (i, reverse acc)-  go acc (FromPath k p) = go (p:acc) k+  go acc (FromId i)                       = (i, reverse acc)+  go acc (FromPath k (PositionalIndex i)) = go (PositionalIndex i:acc) k+  go acc (FromPath k (LabeledField n))    = go (LabeledField n:acc) k+  go acc (FromCustomTerm k s _)           = go (CustomField s:acc) k

@@ -36,6 +36,7 @@ import GHC.ResponseFile (expandResponse) import HIE.Bios.Environment as HIE import System.FilePath+import Data.Time import qualified System.Directory as Directory import qualified System.Environment as Env @@ -52,6 +53,10 @@ import GHC.Driver.Env import GHC.Types.SrcLoc import Language.Haskell.Syntax.Module.Name+import qualified Data.Foldable as Foldable+import qualified GHC.Unit.Home.Graph as HUG+import Data.Maybe+import GHC.Types.Target (InputFileBuffer)  -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m@@ -89,7 +94,7 @@         -- Canonicalize! Why? Because the targets we get from the cradle are normalised and if we don't normalise the "special target" then they aren't deduplicated properly.         canon_fp <- liftIO $ Directory.canonicalizePath abs_fp         let special_target = mkSimpleTarget df canon_fp-        pure $ (df, special_target : targets) NonEmpty.:| []+        pure $ (df, if null targets then [special_target] else targets) NonEmpty.:| []     where       initMulti unitArgFiles =         forM unitArgFiles $ \f -> do@@ -157,13 +162,11 @@   -- additionally, set checked dflags so we don't lose fixes   initial_home_graph <- createUnitEnvFromFlags dflags0 unitDflags   let home_units = unitEnv_keys initial_home_graph-  home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+  init_home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do     let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv         dflags = homeUnitEnv_dflags homeUnitEnv         old_hpt = homeUnitEnv_hpt homeUnitEnv--    (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags cached_unit_dbs home_units-+    (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags Nothing home_units     updated_dflags <- GHC.updatePlatformConstants dflags mconstants     pure HomeUnitEnv       { homeUnitEnv_units = unit_state@@ -173,6 +176,24 @@       , homeUnitEnv_home_unit = Just home_unit       } +  let cached_unit_dbs = concat . catMaybes . fmap homeUnitEnv_unit_dbs $ Foldable.toList init_home_unit_graph++  let homeUnitEnv = fromJust $ HUG.unitEnv_lookup_maybe interactiveGhcDebuggerUnitId init_home_unit_graph+      dflags = homeUnitEnv_dflags homeUnitEnv+      old_hpt = homeUnitEnv_hpt homeUnitEnv+  (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags (Just cached_unit_dbs) home_units++  updated_dflags <- GHC.updatePlatformConstants dflags mconstants+  let ie = HomeUnitEnv+       { homeUnitEnv_units = unit_state+       , homeUnitEnv_unit_dbs = Just dbs+       , homeUnitEnv_dflags = updated_dflags+       , homeUnitEnv_hpt = old_hpt+       , homeUnitEnv_home_unit = Just home_unit+       }++  let home_unit_graph = HUG.unitEnv_insert interactiveGhcDebuggerUnitId ie init_home_unit_graph+   let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup interactiveGhcDebuggerUnitId home_unit_graph   let unit_env = UnitEnv         { ue_platform        = targetPlatform dflags1@@ -203,7 +224,7 @@     ts <- forM cis $ \(df, targets) -> do       -- evaluate $ liftRnf rwhnf targets -      let mk t = fromTargetId (importPaths df) exts (homeUnitId_ df) (GHC.targetId t)+      let mk t = fromTargetId (importPaths df) exts (homeUnitId_ df) (GHC.targetId t) (GHC.targetContents t)       ctargets <- concatMapM mk targets        return (L.nubOrdOn targetTarget ctargets)@@ -220,8 +241,8 @@   -- convenient lookup table from 'FilePath' to 'TargetDetails'.   , targetUnitId :: UnitId   -- ^ UnitId of 'targetTarget'.+  , targetContents :: Maybe (InputFileBuffer, UTCTime)   }-  deriving (Eq, Ord)  -- | A simplified view on a 'TargetId'. --@@ -231,29 +252,30 @@  -- | Turn a 'TargetDetails' into a 'GHC.Target'. toGhcTarget :: TargetDetails -> GHC.Target-toGhcTarget (TargetDetails tid _ uid) = case tid of-  TargetModule modl -> GHC.Target (GHC.TargetModule modl) True uid Nothing-  TargetFile fp -> GHC.Target (GHC.TargetFile fp Nothing) True uid Nothing+toGhcTarget (TargetDetails tid _ uid cts) = case tid of+  TargetModule modl -> GHC.Target (GHC.TargetModule modl) True uid cts+  TargetFile fp -> GHC.Target (GHC.TargetFile fp Nothing) True uid cts  fromTargetId :: [FilePath]          -- ^ import paths              -> [String]            -- ^ extensions to consider              -> UnitId              -> GHC.TargetId+             -> Maybe (InputFileBuffer, UTCTime)              -> IO [TargetDetails] -- For a target module we consider all the import paths-fromTargetId is exts unitId (GHC.TargetModule modName) = do+fromTargetId is exts unitId (GHC.TargetModule modName) ctts = do     let fps = [i </> moduleNameSlashes modName -<.> ext <> boot               | ext <- exts               , i <- is               , boot <- ["", "-boot"]               ]-    return [TargetDetails (TargetModule modName) fps unitId]+    return [TargetDetails (TargetModule modName) fps unitId ctts] -- For a 'TargetFile' we consider all the possible module names-fromTargetId _ _ unitId (GHC.TargetFile f _) = do+fromTargetId _ _ unitId (GHC.TargetFile f _) ctts = do     let other           | "-boot" `L.isSuffixOf` f = dropEnd 5 f           | otherwise = (f ++ "-boot")-    return [TargetDetails (TargetFile f) [f, other] unitId]+    return [TargetDetails (TargetFile f) [f, other] unitId ctts]  -- ---------------------------------------------------------------------------- -- GHC Utils that should likely be exposed by GHC

@@ -0,0 +1,160 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Built-in units and modules+module GHC.Debugger.Session.Builtin+  ( -- * Built-in mods+    debuggerViewBuiltinMods+  , debuggerViewInstancesMods+  , debuggerViewClassModName, debuggerViewClassContents++    -- * In memory unit+  , hsDebuggerViewInMemoryUnitId+  , addInMemoryHsDebuggerViewUnit+  , makeInMemoryHsDebuggerViewTarget++  -- Note:+  -- Don't export instances mods individually to make sure we get warnings if+  -- we add new modules but forget to put any part of them there.+  )+  where++import Data.FileEmbed+import Data.Function+import Data.Time++import GHC+import GHC.Unit+import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Monad+import GHC.Data.StringBuffer+import qualified GHC.Unit.Home.Graph as HUG+import qualified GHC.Unit.Home.PackageTable as HPT+import qualified GHC.Unit.State as State++--------------------------------------------------------------------------------+-- * Built-in Modules+--------------------------------------------------------------------------------++-- | The set of modules to load from @haskell-debugger-view@.+-- NOTE: This list should always be kept up to date with the modules listed in+-- @exposed-modules@ in @haskell-debugger-view@ to make sure all (possibly+-- orphan) instances are loaded and available.+debuggerViewBuiltinMods :: [(ModuleName, StringBuffer)]+debuggerViewBuiltinMods = (debuggerViewClassModName, debuggerViewClassContents):map (\(a,b,_) -> (a,b)) debuggerViewInstancesMods++-- | The modules which provide orphan instances for types defined in external packages.+-- We will try to load each of these modules separately.+debuggerViewInstancesMods :: [(ModuleName, StringBuffer, String {- package name -})]+debuggerViewInstancesMods =+  [ ( debuggerViewContainersModName+    , debuggerViewContainersContents+    , "containers"+    )+  , ( debuggerViewTextModName+    , debuggerViewTextContents+    , "text"+    )+  , ( debuggerViewByteStringModName+    , debuggerViewByteStringContents+    , "bytestring"+    )+  ]++-- | GHC.Debugger.View.Class+debuggerViewClassModName :: ModuleName+debuggerViewClassModName = mkModuleName "GHC.Debugger.View.Class"++-- | GHC.Debugger.View.Containers+debuggerViewContainersModName :: ModuleName+debuggerViewContainersModName = mkModuleName "GHC.Debugger.View.Containers"++-- | GHC.Debugger.View.Text+debuggerViewTextModName :: ModuleName+debuggerViewTextModName = mkModuleName "GHC.Debugger.View.Text"++-- | GHC.Debugger.View.ByteString+debuggerViewByteStringModName :: ModuleName+debuggerViewByteStringModName = mkModuleName "GHC.Debugger.View.ByteString"++--------------------------------------------------------------------------------+-- * In memory haskell-debugger-view+--------------------------------------------------------------------------------++-- | The fixed unit-id (@haskell-debugger-view-in-memory@) for when we load the haskell-debugger-view modules in memory+hsDebuggerViewInMemoryUnitId :: UnitId+hsDebuggerViewInMemoryUnitId = toUnitId $ stringToUnit "haskell-debugger-view-in-memory"++-- | Create a unit @haskell-debugger-view@ which uses in-memory files for the modules+--  and add it to the HUG+addInMemoryHsDebuggerViewUnit+  :: GhcMonad m+  => [UnitId] -- ^ The unit-ids from the transitive dependencies closure of the user-given targets+  -> DynFlags -- ^ Dynflags resulting from first downsweep of user given targets+  -> m ()+addInMemoryHsDebuggerViewUnit base_uids initialDynFlags = do+  let imhdv_dflags = initialDynFlags+        { homeUnitId_ = hsDebuggerViewInMemoryUnitId+        , importPaths = []+        , packageFlags =+          [ ExposePackage+                  ("-package-id " ++ unitIdString unitId)+                  (UnitIdArg $ RealUnit (Definite unitId))+                  (ModRenaming True [])+          | unitId <- base_uids+          , unitId /= rtsUnitId+          , unitId /= ghcInternalUnitId+          ]+        }+        & setGeneralFlag' Opt_HideAllPackages+  hsc_env <- getSession+  (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger hsc_env) imhdv_dflags Nothing mempty+  updated_dflags <- liftIO $ updatePlatformConstants imhdv_dflags mconstants+  emptyHpt <- liftIO HPT.emptyHomePackageTable+  modifySession $ \env ->+    env+      -- Inserts the in-memory hdv unit+      & hscUpdateHUG (\hug ->+          let hdv_hue = HUG.HomeUnitEnv+               { HUG.homeUnitEnv_units = unit_state+               , HUG.homeUnitEnv_unit_dbs = Just dbs+               , HUG.homeUnitEnv_dflags = updated_dflags+               , HUG.homeUnitEnv_hpt = emptyHpt+               , HUG.homeUnitEnv_home_unit = Just home_unit+               }+           in HUG.unitEnv_insert hsDebuggerViewInMemoryUnitId hdv_hue hug+      )++-- | Make an in-memory 'GHC.Target' for a @haskell-debugger-view@ built-in+-- module from the module name and contents+makeInMemoryHsDebuggerViewTarget :: ModuleName -> StringBuffer -> IO GHC.Target+makeInMemoryHsDebuggerViewTarget modName sb = do+    time <- getCurrentTime+    let mkTarget mn contents = GHC.Target+          { targetId = GHC.TargetFile ("in-memory:" ++ moduleNameString mn) Nothing+          , targetAllowObjCode = False+          , GHC.targetUnitId = hsDebuggerViewInMemoryUnitId+          , GHC.targetContents = Just (contents, time)+          }+    return $ mkTarget modName sb++--------------------------------------------------------------------------------+-- * In memory module contents+--------------------------------------------------------------------------------++-- | The contents of GHC.Debugger.View.Class in memory+debuggerViewClassContents :: StringBuffer+debuggerViewClassContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/Class.hs")++-- | The contents of GHC.Debugger.View.Containers in memory+debuggerViewContainersContents :: StringBuffer+debuggerViewContainersContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/Containers.hs")++-- | GHC.Debugger.View.Text+debuggerViewTextContents :: StringBuffer+debuggerViewTextContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/Text.hs")++-- | GHC.Debugger.View.ByteString+debuggerViewByteStringContents :: StringBuffer+debuggerViewByteStringContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs")+

@@ -181,10 +181,7 @@                 -- Return ONLY the fields                  termVarFields key term >>= \case-                  NoFields -> return []-                  LabeledFields xs -> return xs-                  IndexedFields xs -> return xs-+                  VarFields vfs -> return vfs        -- (VARR)(a) from here onwards @@ -196,7 +193,7 @@         case GHC.resumeBreakpointId r of           Nothing -> return []           Just ibi -> do-            curr_modl <- liftIO $ bi_tick_mod . getBreakSourceId ibi <$>+            curr_modl <- liftIO $ getBreakSourceMod ibi <$>                           readIModBreaks (hsc_HUG hsc_env) ibi             things <- typeEnvElts <$> getTopEnv curr_modl             mapM (\tt -> do@@ -208,7 +205,7 @@         case GHC.resumeBreakpointId r of           Nothing -> return []           Just ibi -> do-            curr_modl <- liftIO $ bi_tick_mod . getBreakSourceId ibi <$>+            curr_modl <- liftIO $ getBreakSourceMod ibi <$>                           readIModBreaks (hsc_HUG hsc_env) ibi             names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl             mapM (\n-> do

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,    DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,-   TypeApplications, ScopedTypeVariables, BangPatterns #-}+   TypeApplications, ScopedTypeVariables, BangPatterns, DerivingVia, TypeAbstractions #-} module GHC.Debugger.Stopped.Variables where  import Data.IORef@@ -13,12 +13,15 @@ import GHC.Runtime.Eval import GHC.Core.DataCon import GHC.Core.TyCo.Rep-import qualified GHC.Runtime.Debugger as GHCD+import qualified GHC.Runtime.Debugger     as GHCD import qualified GHC.Runtime.Heap.Inspect as GHCI +import GHC.Debugger.View.Class hiding (VarFields)+ import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages import GHC.Debugger.Runtime+import GHC.Debugger.Runtime.Instances import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Runtime.Term.Cache import GHC.Debugger.Utils@@ -47,38 +50,48 @@ -- This is used to come up with terms for the fields of an already `seq`ed -- variable which was expanded. termVarFields :: TermKey -> Term -> Debugger VarFields-termVarFields top_key top_term =+termVarFields top_key top_term = do -  -- Make 'VarInfo's for the first layer of subTerms only.-  case top_term of-      -- Boring types don't get subfields-      _ | isBoringTy (GHCI.termType top_term) ->-        return NoFields+  vcVarFields <- debugFieldsTerm top_term +  case vcVarFields of+    -- The custom instance case (top_term should always be a @Term@ if @Just@)+    Just fls -> do++      let keys = map (\(f_name, f_term) -> FromCustomTerm top_key f_name f_term) fls+      VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys++    -- The general case+    _ -> case top_term of+      -- Make 'VarInfo's for the first layer of subTerms only.       Term{dc=Right dc, subTerms=_{- don't use directly! go through @obtainTerm@ -}} -> do         case dataConFieldLabels dc of           -- Not a record type,           -- Use indexed fields           [] -> do             let keys = zipWith (\ix _ -> FromPath top_key (PositionalIndex ix)) [1..] (dataConOrigArgTys dc)-            IndexedFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys+            VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys           -- Is a record data con,           -- Use field labels           dataConFields -> do             let keys = map (FromPath top_key . LabeledField . flSelector) dataConFields-            LabeledFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys+            VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys       NewtypeWrap{dc=Right dc, wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do         case dataConFieldLabels dc of           [] -> do             let key = FromPath top_key (PositionalIndex 1)             wvi <- obtainTerm key >>= termToVarInfo key-            return (IndexedFields [wvi])+            return (VarFields [wvi])           [fld] -> do             let key = FromPath top_key (LabeledField (flSelector fld))             wvi <- obtainTerm key >>= termToVarInfo key-            return (LabeledFields [wvi])+            return (VarFields [wvi])           _ -> error "unexpected number of Newtype fields: larger than 1"-      _ -> return NoFields+      RefWrap{wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do+        let key = FromPath top_key (PositionalIndex 1)+        wvi <- obtainTerm key >>= termToVarInfo key+        return (VarFields [wvi])+      _ -> return (VarFields [])   -- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds@@ -95,51 +108,78 @@     checkFn _ = False     isFn = checkFn ty -    isThunk = if not isFn then-      case term0 of-        Suspension{} -> True-        _ -> False-      else False--  term <- if not isThunk && isBoringTy ty-            then forceTerm key term0 -- make sure that if it's an evaluated boring term then it is /fully/ evaluated.-            else pure term0--  let-    -- We scrape the subterms to display as the var's value. The structure is-    -- displayed in the editor itself by expanding the variable sub-fields-    termHead t-      -- But show strings and lits in full-      | isBoringTy ty = t-      | otherwise     = case t of-         Term{}                    -> t{subTerms = []}-         _                         -> t   varName <- display key   varType <- display ty-  -- Pass type as value for functions since actual value is useless-  varValue <- if isFn-    then pure $ "<fn> :: " ++ varType-    else display =<< GHCD.showTerm (termHead term)-  -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term)+  case term0 of+    -- The simple case: The term is a a thunk...+    Suspension{} -> do+      ir <- getVarReference key+      return VarInfo+        { varName+        , varType+        , varValue = if isFn+            then "<fn> :: " ++ varType+            else "_"+        , varRef = if isFn+            then NoVariables+            else SpecificVariable ir -- allows forcing the thunk+        , isThunk = not isFn+        } -  -- The VarReference allows user to expand variable structure and inspect its value.-  -- Here, we do not want to allow expanding a term that is fully evaluated.-  -- We only want to return @SpecificVariable@ (which allows expansion) for-  -- values with sub-fields or thunks.-  varRef <- do-    if GHCI.isFullyEvaluatedTerm term ||-       -- Even if it is already evaluated, we do want to display a-       -- structure as long if it is not a "boring type" (one that does not-       -- provide useful information from being expanded)-       -- (e.g. consider how awkward it is to expand Char# 10 and I# 20)-       (not isThunk && (isBoringTy ty || not (hasDirectSubTerms term)))-     then do-        return NoVariables-     else do-        ir <- getVarReference key-        return (SpecificVariable ir)+    -- Otherwise, try to apply and decode a custom 'DebugView', or default to+    -- the inspecting the original term generically+    _ -> do -  return VarInfo{..}+      -- Try to apply `DebugView.debugValue`+      mterm <- debugValueTerm term0++      case mterm of+        -- Default to generic representation+        Nothing -> do++          let+            -- In the general case, scrape the subterms to display as the var's value.+            -- The structure is displayed in the editor itself by expanding the+            -- variable sub-fields+            termHead t = case t of+               Term{} -> t{subTerms = []}+               _      -> t++          varValue <- display =<< GHCD.showTerm (termHead term0)++          -- 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 hasDirectSubTerms term0+             then do+                ir <- getVarReference key+                return (SpecificVariable ir)+             else do+                return NoVariables++          return VarInfo+            { varName, varType+            , isThunk = False+            , varValue, varRef }++        Just VarValue{varExpandable, varValue=value} -> do++          varRef <-+            if varExpandable+            then do+                ir <- getVarReference key+                return (SpecificVariable ir)+             else do+                return NoVariables+          return VarInfo+            { varName, varType+            , isThunk = False+            , varValue = value+            , varRef+            }+   where     hasDirectSubTerms = \case       Suspension{}   -> False@@ -148,16 +188,16 @@       RefWrap{}      -> True       Term{subTerms} -> not $ null subTerms --- | Forces a term to WHNF in the general case, or to NF in the case of 'isBoringTy'.--- The term is updated at the given key.+-- | Forces a term to WHNF+--+-- The term is updated in the cache at the given key. forceTerm :: TermKey -> Term -> Debugger Term forceTerm key term = do-  let ty = GHCI.termType term-  term' <- if isBoringTy ty-              -- deepseq boring types like String, because it is more helpful-              -- to print them whole than their structure.-              then deepseqTerm term-              else seqTerm term+  hsc_env <- getSession++  term' <- liftIO $ seqTerm hsc_env term+   -- update cache with the forced term right away instead of invalidating it.   asks termCache >>= \r -> liftIO $ modifyIORef' r (insertTermCache key term')   return term'+

@@ -1,13 +1,18 @@ {-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,    DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,    TypeApplications, ScopedTypeVariables, BangPatterns #-}-module GHC.Debugger.Utils where+module GHC.Debugger.Utils+  ( module GHC.Debugger.Utils+  , module GHC.Utils.Outputable+  , module GHC.Utils.Trace+  ) where  import GHC import GHC.Data.FastString-import GHC.Driver.DynFlags as GHC-import GHC.Driver.Ppr as GHC-import GHC.Utils.Outputable as GHC+import GHC.Driver.DynFlags+import GHC.Driver.Ppr+import GHC.Utils.Outputable+import GHC.Utils.Trace  import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages

@@ -45,6 +45,7 @@ instance MonadFail DebugAdaptor where   fail a = error a   -- TODO: PROPER ERROR HANDLING with termination, possibly delete this instance+  -- use: exitWithMsg.  -------------------------------------------------------------------------------- -- * Utilities

@@ -4,6 +4,7 @@ import qualified Data.Text as T import qualified Data.Map as Map import qualified Data.IntSet as IS+import Text.Read import Control.Monad import Data.Maybe @@ -23,7 +24,11 @@   file <- fileFromSourcePath breakpointLocationsArgumentsSource    DidGetBreakpoints mspan <--    sendSync (GetBreakpointsAt (ModuleBreak file breakpointLocationsArgumentsLine breakpointLocationsArgumentsColumn))+    sendSync $ GetBreakpointsAt+      ModuleBreak { path      = file+                  , lineNum   = breakpointLocationsArgumentsLine+                  , columnNum = breakpointLocationsArgumentsColumn+                  }    let locs = case mspan of         Nothing -> []@@ -51,7 +56,13 @@   -- Set requested ones   breaks <- forM breaks_wanted $ \bp -> do     DidSetBreakpoint bf <--      sendSync (SetBreakpoint (ModuleBreak file (DAP.sourceBreakpointLine bp) (DAP.sourceBreakpointColumn bp)))+      sendSync $ SetBreakpoint+        ModuleBreak { path      = file+                    , lineNum   = DAP.sourceBreakpointLine bp+                    , columnNum = DAP.sourceBreakpointColumn bp+                    }+        (readMaybe @Int =<< (T.unpack <$> DAP.sourceBreakpointHitCondition bp))+        (T.unpack <$> DAP.sourceBreakpointCondition bp)     registerBreakFound bf    sendSetBreakpointsResponse (concat breaks)@@ -61,7 +72,7 @@ commandSetFunctionBreakpoints = do   SetFunctionBreakpointsArguments{..} <- getArguments   let-    breaks_wanted = mapMaybe functionBreakpointName setFunctionBreakpointsArgumentsBreakpoints+    breaks_wanted = setFunctionBreakpointsArgumentsBreakpoints    -- Clear existing function breakpoints   DidClearBreakpoints <- sendSync ClearFunctionBreakpoints@@ -69,7 +80,10 @@   -- Set requested ones   breaks <- forM breaks_wanted $ \bp -> do     DidSetBreakpoint bf <--      sendSync (SetBreakpoint (FunctionBreak (T.unpack bp)))+      sendSync $ SetBreakpoint+        FunctionBreak { function  = T.unpack $ fromJust {- not optional -} $ DAP.functionBreakpointName bp }+        (readMaybe @Int =<< (T.unpack <$> DAP.functionBreakpointHitCondition bp))+        (T.unpack <$> DAP.functionBreakpointCondition bp)     registerBreakFound bf    sendSetFunctionBreakpointsResponse (concat breaks)@@ -87,11 +101,11 @@   let breakOnError      = BREAK_ON_ERROR `elem` setExceptionBreakpointsArgumentsFilters    when breakOnExceptions $ do-    DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak)+    DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak Nothing Nothing)     pure ()    when breakOnError $ do-    DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak)+    DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak Nothing Nothing)     pure ()    sendSetExceptionBreakpointsResponse

@@ -36,30 +36,35 @@ -- | Command for evaluation (includes evaluation-on-hover) commandEvaluate :: DebugAdaptor () commandEvaluate = do-  EvaluateArguments {..} <- getArguments+  EvaluateArguments {evaluateArgumentsFrameId=_todo, ..} <- getArguments++  let simpleEvalResp res ty = EvaluateResponse+        { evaluateResponseResult             = res+        , evaluateResponseType               = ty+        , evaluateResponsePresentationHint   = Nothing+        , evaluateResponseVariablesReference = 0+        , evaluateResponseNamedVariables     = Nothing+        , evaluateResponseIndexedVariables   = Nothing+        , evaluateResponseMemoryReference    = Nothing+        }+   DidEval er <- sendSync (DoEval (T.unpack evaluateArgumentsExpression))   case er of     EvalStopped{} -> error "impossible, execution is resumed automatically for 'DoEval'"-    EvalAbortedWith e -> do+    EvalAbortedWith e ->       -- 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 (simpleEvalResp (T.pack e) (T.pack ""))+    EvalException {resultVal, resultType} ->+      sendEvaluateResponse (simpleEvalResp (T.pack resultVal) (T.pack resultType))+    EvalCompleted{resultVal, resultType, resultStructureRef} -> do       sendEvaluateResponse EvaluateResponse-        { evaluateResponseResult  = T.pack $ resultVal er-        , evaluateResponseType    = T.pack $ resultType er-        , evaluateResponsePresentationHint    = Nothing-        , evaluateResponseVariablesReference  = 0-        , evaluateResponseNamedVariables      = Nothing-        , evaluateResponseIndexedVariables    = Nothing-        , evaluateResponseMemoryReference     = Nothing+        { evaluateResponseResult             = T.pack resultVal+        , evaluateResponseType               = T.pack resultType+        , evaluateResponsePresentationHint   = Nothing+        , evaluateResponseVariablesReference = fromEnum resultStructureRef+        , evaluateResponseNamedVariables     = Nothing+        , evaluateResponseIndexedVariables   = Nothing+        , evaluateResponseMemoryReference    = Nothing         }  --------------------------------------------------------------------------------

@@ -25,6 +25,7 @@ import DAP import Data.Function import System.IO+import Control.Monad import Control.Monad.IO.Class import Control.Exception import Control.Exception.Context@@ -71,12 +72,14 @@   -- killing the output thread with @destroyDebugSession@)   -> String   -- ^ Error message, logged with notification-  -> DebugAdaptor a+  -> 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+  has_data <- hReady final_handle & liftIO+  when has_data $ do+      -- get all pending output from GHC+      c <- T.hGetContents final_handle & liftIO+      Output.neutral c   exitWithMsg msg  -- | Logs the error to the debug console and sends a terminate event

@@ -52,11 +52,13 @@  data InitLog   = DebuggerLog Debugger.DebuggerLog+  | DebuggerMonadLog Debugger.DebuggerMonadLog   | FlagsLog FlagsLog  instance Pretty InitLog where   pretty = \ case     DebuggerLog msg -> pretty msg+    DebuggerMonadLog msg -> pretty msg     FlagsLog msg -> pretty msg  --------------------------------------------------------------------------------@@ -125,7 +127,6 @@             , 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.@@ -236,8 +237,6 @@                -> IO () debuggerThread recorder finished_init writeDebuggerOutput workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do -  let finalGhcInvocation = ghcInvocation ++ extraGhcArgs-   -- See Notes (CWD) above   setCurrentDirectory workDir @@ -246,13 +245,12 @@     Output.console $ T.pack $       "libdir: " <> libdir <> "\n" <>       "units: " <> unwords units <> "\n" <>-      "args: " <> unwords finalGhcInvocation+      "args: " <> unwords (ghcInvocation ++ extraGhcArgs)    catches     (do-      Debugger.runDebugger writeDebuggerOutput rootDir componentDir libdir units finalGhcInvocation mainFp runConf $ do+      Debugger.runDebugger (cmapWithSev DebuggerMonadLog recorder) writeDebuggerOutput rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do         liftIO $ signalInitialized (Right ())-         forever $ do           req <- takeMVar requests & liftIO           resp <- (Debugger.execute (cmapWithSev DebuggerLog recorder) req <&> Right)

@@ -153,14 +153,3 @@         }     } ------------------------------------------------------------------------------------ * Utilities------------------------------------------------------------------------------------- | From 'ScopeVariablesReference' to a 'VariableReference' that can be used in @"variable"@ requests-scopeToVarRef :: ScopeVariablesReference -> VariableReference-scopeToVarRef = \case-  LocalVariablesScope -> LocalVariables-  ModuleVariablesScope -> ModuleVariables-  GlobalVariablesScope -> GlobalVariables-

@@ -27,12 +27,14 @@  data InteractiveLog   = DebuggerLog DebuggerLog+  | DebuggerMonadLog DebuggerMonadLog   | FlagsLog FlagsLog  instance Pretty InteractiveLog where   pretty = \ case     DebuggerLog msg -> pretty msg     FlagsLog msg -> pretty msg+    DebuggerMonadLog msg -> pretty msg  -- | Run it runIDM :: Recorder (WithSeverity InteractiveLog)@@ -58,10 +60,10 @@             , supportsANSIHyperlinks = False             } -      let finalGhcInvocation = ghcInvocation ++ extraGhcArgs       let absEntryFile = normalise $ projectRoot </> entryFile+      let debugRec = cmapWithSev DebuggerMonadLog logger -      runDebugger stdout rootDir componentDir libdir units finalGhcInvocation absEntryFile defaultRunConf $+      runDebugger debugRec stdout rootDir componentDir libdir units ghcInvocation extraGhcArgs absEntryFile defaultRunConf $         fmap fst $           evalRWST (runInputT (setComplete noCompletion defaultSettings) act)                    (entryFile, entryPoint, entryArgs) Nothing@@ -164,6 +166,20 @@   ( flag' OnUncaughtExceptionsBreak ( long "error" )   ) +conditionalBreakParser :: Parser (Maybe String)+conditionalBreakParser =+  optional (option str+    ( long "condition"+   <> metavar "CONDITION"+   <> help "Only stop when CONDITION evaluates to True" ))++hitCountBreakParser :: Parser (Maybe Int)+hitCountBreakParser =+  optional (option auto+    ( long "hit"+   <> metavar "N:INT"+   <> help "Ignore first N:INT times this breakpoint is hit" ))+ runParser :: FilePath -> String -> [String] -> Parser Command runParser entryFile entryPoint entryArgs =   -- --entry <name> with some args@@ -194,7 +210,7 @@ cmdParser :: FilePath -> String -> [String] -> Parser Command cmdParser entryFile entryPoint entryArgs = hsubparser   ( Options.Applicative.command "break"-    ( info (SetBreakpoint <$> breakpointParser)+    ( info (SetBreakpoint <$> breakpointParser <*> hitCountBreakParser <*> conditionalBreakParser)       ( progDesc "Set a breakpoint" ) )   <>     Options.Applicative.command "delete"

@@ -75,6 +75,7 @@              -> ExceptT String IO (Either String HieBiosFlags) hieBiosSetup logger projectRoot entryFile = do +  logT "Figuring out the right flags to compile the project using hie-bios..."   cradle <- hieBiosCradle logger projectRoot entryFile & ExceptT    -- GHC is found in PATH (by hie-bios as well).

@@ -2,9 +2,7 @@ module Main where  import System.Environment-import System.Process import Data.Maybe-import Data.Aeson import Data.IORef import Text.Read import Control.Concurrent@@ -39,8 +37,8 @@ --------------------------------------------------------------------------------  defaultStdoutForwardingAction :: T.Text -> IO ()-defaultStdoutForwardingAction line = do-  T.hPutStrLn stderr ("[INTERCEPTED STDOUT] " <> line)+defaultStdoutForwardingAction l = do+  T.hPutStrLn stderr ("[INTERCEPTED STDOUT] " <> l)  main :: IO () main = do@@ -79,9 +77,14 @@   let     hostDefault = "0.0.0.0"     portDefault = port-    capabilities = defaultCapabilities-      { -- Exception breakpoints!-        exceptionBreakpointFilters            = [ defaultExceptionBreakpointsFilter+    capabilities = Capabilities+      { supportsConfigurationDoneRequest      = True+      , supportsFunctionBreakpoints           = True+      , supportsConditionalBreakpoints        = True+      , supportsHitConditionalBreakpoints     = True+      , supportsEvaluateForHovers             = False+      -- Exception Breakpoints:+      , exceptionBreakpointFilters            = [ defaultExceptionBreakpointsFilter                                                   { exceptionBreakpointsFilterLabel = "All exceptions"                                                   , exceptionBreakpointsFilterFilter = BREAK_ON_EXCEPTION                                                   }@@ -90,27 +93,45 @@                                                   , 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+      , supportsStepBack                      = False+      , supportsSetVariable                   = False+      , supportsRestartFrame                  = False+      , supportsGotoTargetsRequest            = False+      , supportsStepInTargetsRequest          = False+      , supportsCompletionsRequest            = False+      , completionTriggerCharacters           = []       , supportsModulesRequest                = False       , additionalModuleColumns               = [ defaultColumnDescriptor                                                   { columnDescriptorAttributeName = "Extra"                                                   , columnDescriptorLabel = "Label"                                                   }                                                 ]+      , supportedChecksumAlgorithms           = []+      , supportsRestartRequest                = False+      , supportsExceptionOptions              = True       , supportsValueFormattingOptions        = True+      , supportsExceptionInfoRequest          = False       , supportTerminateDebuggee              = True+      , supportSuspendDebuggee                = False+      , supportsDelayedStackTraceLoading      = False       , supportsLoadedSourcesRequest          = False-      , supportsExceptionOptions              = True+      , supportsLogPoints                     = False+      , supportsTerminateThreadsRequest       = False+      , supportsSetExpression                 = False+      , supportsTerminateRequest              = False+      , supportsDataBreakpoints               = False+      , supportsReadMemoryRequest             = False+      , supportsWriteMemoryRequest            = False+      , supportsDisassembleRequest            = False+      , supportsCancelRequest                 = False+      -- Display which breakpoints are valid when user intends to set+      -- breakpoint on given line:+      , supportsBreakpointLocationsRequest    = True+      , supportsClipboardContext              = False+      , supportsSteppingGranularity           = False+      , supportsInstructionBreakpoints        = False       , supportsExceptionFilterOptions        = False+      , supportsSingleThreadExecutionRequests = False       }   ServerConfig     <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST"

@@ -118,5 +118,5 @@         Left e -> fail e         Right actual           | toHashMapText ex `H.isSubmapOf` toHashMapText actual -> pure ()-          | otherwise -> encodePretty actual @=? encodePretty ex+          | otherwise -> encodePretty ex @=? encodePretty actual     _ -> fail "Invalid JSON"

@@ -107,6 +107,8 @@       _ <- shouldReceive handle             ["type" .= ("event" :: String), "event" .= ("output" :: String)]       _ <- shouldReceive handle+            ["type" .= ("event" :: String), "event" .= ("output" :: String)]+      _ <- shouldReceive handle             [ "command" .= ("launch" :: String)             , "success" .= True]       _ <- shouldReceive handle