From 9cea815615eb57fbbe54c5136e01042021110084 Mon Sep 17 00:00:00 2001 From: meipp Date: Fri, 19 Sep 2025 08:30:23 +0200 Subject: [PATCH 01/40] Incomplete state of Debug instance visualization --- haskell-debugger/GHC/Debugger/Runtime.hs | 40 +++++++++++++++++++ .../GHC/Debugger/Stopped/Variables.hs | 4 +- 2 files changed, 43 insertions(+), 1 deletion(-) diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs index 1f90ec0..8543b83 100644 --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -15,6 +15,20 @@ import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Runtime.Term.Cache import GHC.Debugger.Monad +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Types.Name +import GHC.Core.Class +import GHC.Core.InstEnv +import Debug.Trace +import qualified GHC.Linker.Loader as Loader +import GHC.Driver.Env +import GHC.Types.Var +import GHC.Driver.Config +import GHCi.Message +import GHC.Runtime.Interpreter +import GHC.Utils.Outputable + -- | Obtain the runtime 'Term' from a 'TermKey'. -- -- The 'TermKey' will be looked up in the 'TermCache' to avoid recomputing the @@ -81,4 +95,30 @@ isBoringTy :: Type -> Bool isBoringTy t = isDoubleTy t || isFloatTy t || isIntTy t || isWordTy t || isStringTy t || isIntegerTy t || isNaturalTy t || isCharTy t +onDebugInstance :: Term -> Type -> Debugger Bool +onDebugInstance term t = do + hsc_env <- getSession + instances <- getInstancesForType t + + case filter ((== "Debug") . occNameString . occName . tyConName . classTyCon . is_cls) instances of + (c:_) -> do + let methods = (classOpItems . is_cls) c + traceM ("Found Debug instance with methods: " ++ (show . map (occNameString . occName . fst)) methods ++ "") + case filter ((== "debugDisplayTree") . occNameString . occName . fst) methods of + (m:_) -> do + let dfun = is_dfun c + traceM $ "Dictionary function: " ++ showSDocUnsafe (ppr dfun) ++ " :: " ++ showSDocUnsafe (ppr (varType dfun)) + + let method_id = fst m :: Id + traceM $ "debugDisplayTree method: " ++ showSDocUnsafe (ppr method_id) ++ " :: " ++ showSDocUnsafe (ppr (varType method_id)) + + (method_hv, _, _) <- liftIO $ Loader.loadName (hscInterp hsc_env) hsc_env (GHC.Types.Var.varName method_id) + (dfun_hv, _, _) <- liftIO $ Loader.loadName (hscInterp hsc_env) hsc_env (GHC.Types.Var.varName dfun) + + -- this call fails + ev <- liftIO $ evalStmt (hscInterp hsc_env) (initEvalOpts (hsc_dflags hsc_env) EvalStepNone) (EvalApp (EvalApp (EvalThis method_hv) (EvalThis dfun_hv)) (EvalThis (val term))) + return True + [] -> return False + return False + _ -> return False diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs index 06c640d..cfbaeb3 100644 --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -123,7 +123,9 @@ termToVarInfo key term0 = do -- Pass type as value for functions since actual value is useless varValue <- if isFn then pure $ " :: " ++ varType - else display =<< GHCD.showTerm (termHead term) + else do + _ <- onDebugInstance term ty + display =<< GHCD.showTerm (termHead term) -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term) -- The VarReference allows user to expand variable structure and inspect its value. From 5bcdba98cec1d284875b42891df78e90004ea0a1 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 31 Oct 2025 12:14:34 +0000 Subject: [PATCH 02/40] expandTerm: RefWrap and NewtypeWrap cases --- haskell-debugger/GHC/Debugger/Runtime.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs index 8543b83..65c1f20 100644 --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -81,9 +81,12 @@ obtainTerm key = do 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 + 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'} -- For other terms there's no point in trying to expand (Suspension{}; Prim{}) -> return term From ea1f006b43bd2a4758739ba2d5b20535217791c3 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 31 Oct 2025 14:31:32 +0000 Subject: [PATCH 03/40] refactor: Don't do work to expand boring ty twice We used to, for "boring tys" - in `obtainTerm`, use `depth = maxBound` to traverse arbitrarily deep - right after, in `termToVarInfo`, use `deepseqTerm` to force it till the end again. To simplify, always do the latter and forget the former. In preparation of #47 --- haskell-debugger/GHC/Debugger/Runtime.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs index 65c1f20..a1725b8 100644 --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -43,15 +43,9 @@ obtainTerm key = do -- 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 liftIO $ expandTerm hsc_env $ case term of From 6e7ebeba0751d3fed41ac0a9fb04e5cbc80f4b30 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 31 Oct 2025 14:37:50 +0000 Subject: [PATCH 04/40] refactor: Move isBoringTy to Debugger.Stopped.Variables --- haskell-debugger/GHC/Debugger/Runtime.hs | 8 -------- haskell-debugger/GHC/Debugger/Stopped/Variables.hs | 8 ++++++++ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs index a1725b8..c4823ed 100644 --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -84,14 +84,6 @@ expandTerm hsc_env term = case term of -- 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 - onDebugInstance :: Term -> Type -> Debugger Bool onDebugInstance term t = do hsc_env <- getSession diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs index cfbaeb3..9ecd371 100644 --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -165,3 +165,11 @@ forceTerm key term = do -- update cache with the forced term right away instead of invalidating it. asks termCache >>= \r -> liftIO $ modifyIORef' r (insertTermCache key term') 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 From d6e899005ebbd642a3ad68e103a8753cec1ff475 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 3 Nov 2025 11:48:40 +0000 Subject: [PATCH 05/40] Bump version to 0.10.0 --- .github/workflows/release.yaml | 2 +- CHANGELOG.md | 2 ++ haskell-debugger.cabal | 2 +- vscode-extension/default.nix | 2 +- vscode-extension/package.json | 2 +- 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index a3febd5..4ce8bfa 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -75,7 +75,7 @@ jobs: with: pat: ${{ secrets.VS_MARKETPLACE_TOKEN }} registryUrl: https://marketplace.visualstudio.com - extensionFile: ${{ runner.temp }}/extension/haskell-debugger-extension-0.9.0.vsix + extensionFile: ${{ runner.temp }}/extension/haskell-debugger-extension-0.10.0.vsix # Publish a new hackage release of the haskell-debugger - name: Hackage Release diff --git a/CHANGELOG.md b/CHANGELOG.md index 4607ee8..9637d5f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,7 @@ # Revision history for haskell-debugger +## 0.10.0.0 -- Unreleased + ## 0.9.0.0 -- 2025-10-13 ### Main changes diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 825eff7..8858ffc 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -1,6 +1,6 @@ cabal-version: 3.12 name: haskell-debugger -version: 0.9.0.0 +version: 0.10.0.0 synopsis: A step-through debugger for GHC Haskell diff --git a/vscode-extension/default.nix b/vscode-extension/default.nix index 2c455dd..1d8416b 100644 --- a/vscode-extension/default.nix +++ b/vscode-extension/default.nix @@ -2,7 +2,7 @@ pkgs.buildNpmPackage { pname = "haskell-debugger-extension"; - version = "0.9.0"; + version = "0.10.0"; src = ./.; npmDepsHash = "sha256-rvPlvEsFygi/EYh0vcOBDAC4Sf5nzJIfaN8HjdsVXE0="; diff --git a/vscode-extension/package.json b/vscode-extension/package.json index eb485c8..a90dc17 100644 --- a/vscode-extension/package.json +++ b/vscode-extension/package.json @@ -1,7 +1,7 @@ { "name": "haskell-debugger-extension", "displayName": "Haskell Debugger", - "version": "0.9.0", + "version": "0.10.0", "publisher": "Well-Typed", "description": "The GHC Haskell Debugger", "repository": "https://github.com/well-typed/haskell-debugger", From 97323a9e4b41057b6ace3a5f32cf272a3bf68fe0 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 3 Nov 2025 10:41:33 +0000 Subject: [PATCH 06/40] feat: Custom Debug Instances This commit introduces the haskell-view-debugger package with a class for defining custom visualisations for the debugger It refactors and improves the internals of the debugger variable inspection code to leverage custom instances when they are available. We do this by compiling on the fly the method applied to the dictionary for the type of the value we're inspecting, loading it, and applying it to the value. Lastly, we have special logic to decode the return types (VarValue and VarFields) from their heap-representation Terms. We get rid of the ad-hoc special logic for displaying strings and/or boring types and for seqing, resulting in a more uniform and extensible design. This commit does not include two things that will follow up: 1. Caching DebugViewInstances with a Core.Map.Type trie map 2. Loading the DebugView class module and built-in instances ourselves when the user program does not transitively depend on them. Fixes #47 Co-authored-by: Matthew Pickering --- cabal.project | 2 +- haskell-debugger-view/CHANGELOG.md | 5 + .../haskell-debugger-view.cabal | 21 + .../src/GHC/Debugger/View/Class.hs | 141 +++++++ haskell-debugger.cabal | 3 + haskell-debugger/GHC/Debugger/Breakpoint.hs | 2 +- .../GHC/Debugger/Interface/Messages.hs | 2 + haskell-debugger/GHC/Debugger/Monad.hs | 23 +- haskell-debugger/GHC/Debugger/Runtime.hs | 48 +-- .../GHC/Debugger/Runtime/Instances.hs | 367 ++++++++++++++++++ .../GHC/Debugger/Runtime/Term/Cache.hs | 4 +- .../GHC/Debugger/Runtime/Term/Key.hs | 37 +- haskell-debugger/GHC/Debugger/Session.hs | 30 +- .../GHC/Debugger/Stopped/Variables.hs | 161 ++++---- hdb/Development/Debug/Adapter/Init.hs | 3 +- 15 files changed, 707 insertions(+), 142 deletions(-) create mode 100644 haskell-debugger-view/CHANGELOG.md create mode 100644 haskell-debugger-view/haskell-debugger-view.cabal create mode 100644 haskell-debugger-view/src/GHC/Debugger/View/Class.hs create mode 100644 haskell-debugger/GHC/Debugger/Runtime/Instances.hs diff --git a/cabal.project b/cabal.project index f973de4..ddeb56a 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -packages: . +packages: . haskell-debugger-view allow-newer: ghc-bignum,containers,time,ghc,base,template-haskell diff --git a/haskell-debugger-view/CHANGELOG.md b/haskell-debugger-view/CHANGELOG.md new file mode 100644 index 0000000..4b4f0a2 --- /dev/null +++ b/haskell-debugger-view/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for haskell-debugger-view + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/haskell-debugger-view/haskell-debugger-view.cabal b/haskell-debugger-view/haskell-debugger-view.cabal new file mode 100644 index 0000000..b5d871d --- /dev/null +++ b/haskell-debugger-view/haskell-debugger-view.cabal @@ -0,0 +1,21 @@ +cabal-version: 3.12 +name: haskell-debugger-view +version: 0.1.0.0 +license: NONE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +build-type: Simple +extra-doc-files: CHANGELOG.md + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: GHC.Debugger.View.Class + build-depends: base, + containers >= 0.7 && < 0.9, + text >= 2.1 && < 2.3, + bytestring >= 0.12.1 && < 0.13, + hs-source-dirs: src + default-language: GHC2021 diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs new file mode 100644 index 0000000..2d32887 --- /dev/null +++ b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DerivingVia, StandaloneDeriving, ViewPatterns, ImpredicativeTypes #-} +module GHC.Debugger.View.Class where + +import qualified Data.ByteString as BS + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import qualified Data.IntMap as IM +import qualified Data.Map as M + +-- | 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 + +-- | 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 + +-------------------------------------------------------------------------------- + +-- | 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) ] + +instance DebugView T.Text where + debugValue t = VarValue (show (T.unpack t)) False + debugFields _ = VarFields [] + +instance DebugView BS.ByteString where + debugValue t = VarValue (show (T.unpack (T.decodeUtf8 t))) False + debugFields _ = VarFields [] + +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 + ] + +-------------------------------------------------------------------------------- +-- * (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]] diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 8858ffc..fe64d8a 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -57,6 +57,7 @@ library GHC.Debugger.Stopped.Variables, GHC.Debugger.Utils, GHC.Debugger.Runtime, + GHC.Debugger.Runtime.Instances, GHC.Debugger.Runtime.Term.Key, GHC.Debugger.Runtime.Term.Cache, @@ -68,6 +69,7 @@ library default-extensions: CPP build-depends: base > 4.21 && < 5, ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16, + ghc-boot-th >= 9.14 && < 9.16, array >= 0.5.8 && < 0.6, containers >= 0.7 && < 0.9, mtl >= 2.3 && < 3, @@ -87,6 +89,7 @@ library 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: GHC2021 diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs index e215be8..dbfe574 100644 --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -118,7 +118,7 @@ setBreakpoint exception_bp bp_status = do = 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) diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs index 2afdb79..2218ed7 100644 --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -105,6 +105,8 @@ data ScopeInfo = ScopeInfo , expensive :: Bool } deriving (Show, Generic) +-- Seems like this could just be a newtype over [VarInfo] +-- -- TODO: MERGE INTO NEWTYPE OVER LIST VARINFO data VarFields = LabeledFields [VarInfo] | IndexedFields [VarInfo] | NoFields diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index bf144df..037d247 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -324,14 +324,13 @@ defaultDepth = 2 -- the depth determines how much of the runtime structure is t -- | 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 @@ -339,21 +338,21 @@ seqTerm term = do 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 + _ -> do seqTerm hsc_env t -- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'. -- diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs index c4823ed..d3cddd7 100644 --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns #-} +{-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns, TemplateHaskellQuotes #-} module GHC.Debugger.Runtime where import Data.IORef @@ -7,28 +7,14 @@ import qualified Data.List as L import GHC import GHC.Types.FieldLabel -import GHC.Tc.Utils.TcType import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Runtime.Term.Cache +import GHC.Debugger.Runtime.Instances import GHC.Debugger.Monad -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Types.Name -import GHC.Core.Class -import GHC.Core.InstEnv -import Debug.Trace -import qualified GHC.Linker.Loader as Loader -import GHC.Driver.Env -import GHC.Types.Var -import GHC.Driver.Config -import GHCi.Message -import GHC.Runtime.Interpreter -import GHC.Utils.Outputable - -- | Obtain the runtime 'Term' from a 'TermKey'. -- -- The 'TermKey' will be looked up in the 'TermCache' to avoid recomputing the @@ -60,6 +46,9 @@ obtainTerm key = do RefWrap{wrapped_term} -> wrapped_term -- regardless of PathFragment _ -> error "Unexpected term for the given TermKey" + 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) @@ -84,30 +73,3 @@ expandTerm hsc_env term = case term of -- For other terms there's no point in trying to expand (Suspension{}; Prim{}) -> return term -onDebugInstance :: Term -> Type -> Debugger Bool -onDebugInstance term t = do - hsc_env <- getSession - instances <- getInstancesForType t - - case filter ((== "Debug") . occNameString . occName . tyConName . classTyCon . is_cls) instances of - (c:_) -> do - let methods = (classOpItems . is_cls) c - traceM ("Found Debug instance with methods: " ++ (show . map (occNameString . occName . fst)) methods ++ "") - case filter ((== "debugDisplayTree") . occNameString . occName . fst) methods of - (m:_) -> do - let dfun = is_dfun c - traceM $ "Dictionary function: " ++ showSDocUnsafe (ppr dfun) ++ " :: " ++ showSDocUnsafe (ppr (varType dfun)) - - let method_id = fst m :: Id - traceM $ "debugDisplayTree method: " ++ showSDocUnsafe (ppr method_id) ++ " :: " ++ showSDocUnsafe (ppr (varType method_id)) - - (method_hv, _, _) <- liftIO $ Loader.loadName (hscInterp hsc_env) hsc_env (GHC.Types.Var.varName method_id) - (dfun_hv, _, _) <- liftIO $ Loader.loadName (hscInterp hsc_env) hsc_env (GHC.Types.Var.varName dfun) - - -- this call fails - ev <- liftIO $ evalStmt (hscInterp hsc_env) (initEvalOpts (hsc_dflags hsc_env) EvalStepNone) (EvalApp (EvalApp (EvalThis method_hv) (EvalThis dfun_hv)) (EvalThis (val term))) - - return True - [] -> return False - return False - _ -> return False diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs new file mode 100644 index 0000000..37d640a --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments #-} +module GHC.Debugger.Runtime.Instances where + +import Control.Exception +import Control.Monad +import Data.Either +import Control.Monad.Reader +import Data.IORef +import Data.Maybe +import qualified Data.List as L + +import GHC +import GHC.Builtin.Names +import GHC.Core.Class +import GHC.Core.InstEnv +import GHC.Unit.Module.Graph +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Driver.Config +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.HsToCore +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.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.ThToHs +import GHC.Types.FieldLabel +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var +import GHC.Unit.Finder +import GHC.Unit.State +import GHC.Utils.Outputable +import GHCi.Message +import qualified GHC.Linker.Loader as Loader +import qualified GHC.Runtime.Heap.Inspect as Inspect +import qualified GHC.Runtime.Debugger as GHCD + +import GHC.Debugger.Monad +import GHC.Debugger.Runtime.Term.Cache +import GHC.Debugger.Runtime.Term.Key +import GHC.Debugger.Utils +import GHC.Debugger.View.Class +import GHC.Tc.Utils.Monad +import GHC.Debugger.Session +import GHC.Tc.Solver +import GHC.Tc.Types.Evidence +import GHC.Tc.Zonk.Type +import GHC.HsToCore.Monad +import GHC.HsToCore.Expr + +-------------------------------------------------------------------------------- +-- * 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 dflags = hsc_dflags hsc_env + let ty = Inspect.termType term + mbInst <- findDebugViewInstance 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 2 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 + _ -> False + + 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 dflags = hsc_dflags hsc_env + let ty = Inspect.termType term + mbInst <- findDebugViewInstance ty + case mbInst of + Nothing -> return Nothing + Just DebugViewInstance + {instDebugFields, varFieldsIOTy, varFieldValueTy, ioTyCon} -> 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 = Inspect.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 [] + +-------------------------------------------------------------------------------- +-- * Medium level interface for 'DebugView' on 'ForeignHValue's +-------------------------------------------------------------------------------- + +-- | 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 + -- | 'VarFieldValue' type + , varFieldValueTy :: Type + -- | 'IO' Ty con + , ioTyCon :: TyCon + } + +-------------------------------------------------------------------------------- +-- * Impl. to find instance and load instance methods applied to right dictionary +-------------------------------------------------------------------------------- + +-- As long as the user depends on GHC.Debugger.View.Class somewhere in their full transitive closure, +-- then we get haskell-debugger-view unit-id from the module graph; and all +-- built-in instances are available because they're defined in that module. +-- +-- If it's NOT anywhere in the closure, we want to load it ourselves to bring +-- the built-in instances into scope. + +{- +How to : +1. Make a unit id for this in memory package +2. Make a ModSummary for each of the modules in haskell-debugger-view + 2.1. Probably summariseFile with the StringBuffer argument + +-- +3. Call 'compileOne' function on the ModSummary to know whether it will work or not +4. Get HomeModInfo then add it to the HUG/HPT ? +-- +Alternatively: +If I knew it was going to compile, I could just load it into the interactive +context directly? +-- +Main issue: how to setup the environment for the home package? +When I create the home package I have to pass some package flags +If I want to use e.g. containers for some modules I need to find the right +unit-id of containers that the user is using to pick the right one. + +I could just get the module graph from the user program and just use all of them since that's the "maximal" set + +If containers is not in the existing build plan then no need to try and compile that module +(If load to int. context did work) + +-------------------------------------------------------------------------------- +Perhaps more easily: + +Just get the user module graph and inject the modules + +Add to the module graph a ModSummary node for all of the haskell-debugger-view +modules and try to load the module graph whole again. +Use | LoadDependenciesOf HomeUnitModule for 'load' +-} + +findDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance) +findDebugViewInstance needle_ty = do + hsc_env <- getSession + + -- We want to attempt finding DebugView instances twice. + -- Once: using the haskell-debugger-view unit-id found by looking for + -- "GHC.Debugger.View.Class" in the module graph. + -- - This will be the module depended on by the user or library authors to + -- define custom instances for types they use in their program -- which is + -- why it's so important to find the right unit-id. + -- Second: using a built-in unit-id for a runtime-loaded version of haskell-debugger-view. + -- - We look for our own custom defined instances with this unit id if there + -- was none found for the former. + + -- TODO: Better lookup of unit-id, and do it on 'runDebugger' and store... + mod_graph <- getModuleGraph + 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] -> liftIO $ do + + let modl = mkModule (RealUnit (Definite hdv_uid)) (mkModuleName "GHC.Debugger.View.Class") + let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr) + + (err_msgs, res) <- 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")) + varFieldValueTy <- fmap mkTyConTy . tcLookupTyCon + =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarFieldValue")) + + 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 + , varFieldValueTy + , ioTyCon + } + + case res of + Nothing -> do + pprTraceM "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 + ms -> do + -- 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!!! + -- + -- ... + -- PRINCIPLE: User code should not have to be modified to use the debugger + return Nothing + +-- | Try to compile and load a class method for the given type. +-- +-- E.g. @compileAndLoadMthd "debugValue" ( -> 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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs index 6933f72..35fc330 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs, DataKinds #-} module GHC.Debugger.Runtime.Term.Cache where import GHC.Runtime.Eval @@ -38,7 +38,7 @@ insertTermCache = insertTermKeyMap -------------------------------------------------------------------------------- -- | 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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs index c4b38fc..3cfcf45 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs @@ -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 @@ data TermKey where -- | 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 diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index 6830e7c..0f1be6a 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -52,6 +52,12 @@ import qualified GHC.Unit.State as State import GHC.Driver.Env import GHC.Types.SrcLoc import Language.Haskell.Syntax.Module.Name +import GHC.Utils.Trace +import GHC.Utils.Outputable (ppr, ($$)) +import GHC.Data.FastString +import qualified Data.Foldable as Foldable +import qualified GHC.Unit.Home.Graph as HUG +import Data.Maybe -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m @@ -157,13 +163,11 @@ initHomeUnitEnv unitDflags env = do -- 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 +177,24 @@ initHomeUnitEnv unitDflags env = do , 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 diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs index 9ecd371..e11a0fa 100644 --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -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,16 @@ import GHC.Types.Var 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 qualified GHC.Debugger.View.Class as VC + 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,14 +51,20 @@ tyThingToVarInfo t = case t of -- 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 + + vcVarFields <- debugFieldsTerm top_term + + case vcVarFields of + -- The custom instance case (top_term should always be a @Term@ if @Just@) + Just fls -> 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 + let keys = map (\(f_name, f_term) -> FromCustomTerm top_key f_name f_term) fls + LabeledFields <$> 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, @@ -99,51 +109,78 @@ termToVarInfo key term0 = do 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 $ " :: " ++ varType - else do - _ <- onDebugInstance term ty - display =<< GHCD.showTerm (termHead term) - -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term) - - -- The VarReference allows user to expand variable structure and inspect its value. - -- Here, we do not want to allow expanding a term that is fully evaluated. - -- We only want to return @SpecificVariable@ (which allows expansion) for - -- values with sub-fields or thunks. - varRef <- do - if -- Display a structure as long it is not a "boring type" (one that does not - -- provide useful information from being expanded) - -- (e.g. consider how awkward it is to expand Char# 10 and I# 20) - (not isThunk && (isBoringTy ty || not (hasDirectSubTerms term))) - then do - return NoVariables - else do - ir <- getVarReference key - return (SpecificVariable ir) - - return VarInfo{..} + 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 " :: " ++ varType + else "_" + , varRef = if isFn + then NoVariables + else SpecificVariable ir -- allows forcing the thunk + , isThunk = not isFn + } + + -- Otherwise, try to apply and decode a custom 'DebugView', or default to + -- the inspecting the original term generically + _ -> do + + -- 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 @@ -152,24 +189,16 @@ termToVarInfo key term0 = do 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' --- | A boring type is one for which we don't care about the structure and would --- rather see "whole" when being inspected. Strings and literals are a good --- example, because it's more useful to see the string value than it is to see --- a linked list of characters where each has to be forced individually. -isBoringTy :: Type -> Bool -isBoringTy t = isDoubleTy t || isFloatTy t || isIntTy t || isWordTy t || isStringTy t - || isIntegerTy t || isNaturalTy t || isCharTy t diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 3deac59..893c917 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -45,6 +45,8 @@ import GHC.Debugger.Interface.Messages hiding (Command, Response) import DAP import Development.Debug.Adapter.Handles import Development.Debug.Session.Setup +import GHC.Debugger.Utils hiding ((<>)) +import GHC.Driver.Session -------------------------------------------------------------------------------- -- * Logging @@ -252,7 +254,6 @@ debuggerThread recorder finished_init writeDebuggerOutput workDir HieBiosFlags{. (do Debugger.runDebugger writeDebuggerOutput rootDir componentDir libdir units finalGhcInvocation mainFp runConf $ do liftIO $ signalInitialized (Right ()) - forever $ do req <- takeMVar requests & liftIO resp <- (Debugger.execute (cmapWithSev DebuggerLog recorder) req <&> Right) From 788d2c345c5dac3b29276e96ce40c76cb0795ee2 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 7 Nov 2025 16:20:57 +0000 Subject: [PATCH 07/40] fix: Only add special target if there are no targets Fixes #118 --- haskell-debugger/GHC/Debugger/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index 0f1be6a..d0c96fe 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -95,7 +95,7 @@ parseHomeUnitArguments cfp compRoot units theOpts dflags rootDir = do -- 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 From 7f62324d12bcdeed5395fac29b7405bbed9b3057 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 7 Nov 2025 17:23:06 +0000 Subject: [PATCH 08/40] Flatten VarFields into newtype --- .../GHC/Debugger/Interface/Messages.hs | 8 ++------ haskell-debugger/GHC/Debugger/Runtime.hs | 2 ++ haskell-debugger/GHC/Debugger/Stopped.hs | 5 +---- haskell-debugger/GHC/Debugger/Stopped/Variables.hs | 14 +++++++------- 4 files changed, 12 insertions(+), 17 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs index 2218ed7..a0be566 100644 --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -105,12 +105,8 @@ data ScopeInfo = ScopeInfo , expensive :: Bool } deriving (Show, Generic) --- Seems like this could just be a newtype over [VarInfo] --- -- TODO: MERGE INTO NEWTYPE OVER LIST VARINFO -data VarFields = LabeledFields [VarInfo] - | IndexedFields [VarInfo] - | NoFields - deriving (Show, Generic, Eq) +newtype VarFields = VarFields [VarInfo] + deriving (Show, Generic, Eq) -- | Information about a variable data VarInfo = VarInfo diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs index d3cddd7..2b141aa 100644 --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -6,6 +6,8 @@ import Control.Monad.Reader import qualified Data.List as L import GHC +import GHC.Utils.Outputable +import GHC.Utils.Trace import GHC.Types.FieldLabel import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs index 6ead0c4..8baac92 100644 --- a/haskell-debugger/GHC/Debugger/Stopped.hs +++ b/haskell-debugger/GHC/Debugger/Stopped.hs @@ -181,10 +181,7 @@ getVariables vk = do -- 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 diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs index e11a0fa..bf23e06 100644 --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -60,7 +60,7 @@ termVarFields top_key top_term = do Just fls -> do let keys = map (\(f_name, f_term) -> FromCustomTerm top_key f_name f_term) fls - LabeledFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys + VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys -- The general case _ -> case top_term of @@ -71,28 +71,28 @@ termVarFields top_key top_term = do -- 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" RefWrap{wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do let key = FromPath top_key (PositionalIndex 1) wvi <- obtainTerm key >>= termToVarInfo key - return (IndexedFields [wvi]) - _ -> return NoFields + return (VarFields [wvi]) + _ -> return (VarFields []) -- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds From 433c83f574f7b75a3667376227c67c9a34f40128 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 10 Nov 2025 10:41:55 +0000 Subject: [PATCH 09/40] fix: Re-use cache when recursing into path fragments Fixes bug that caused a crash when inspecting a non-custom-debug view value inside of a custom-debug-view value --- haskell-debugger/GHC/Debugger/Runtime.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs index 2b141aa..88b5acc 100644 --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -35,7 +35,7 @@ obtainTerm key = do getTerm = \case 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) @@ -47,7 +47,7 @@ obtainTerm key = do wrapped_term -- regardless of PathFragment RefWrap{wrapped_term} -> wrapped_term -- regardless of PathFragment - _ -> error "Unexpected term for the given TermKey" + _ -> error ("Unexpected term for the given TermKey because 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 @@ -72,6 +72,6 @@ expandTerm hsc_env term = case term of NewtypeWrap{wrapped_term} -> do wt' <- expandTerm hsc_env wrapped_term return term{wrapped_term=wt'} - -- For other terms there's no point in trying to expand - (Suspension{}; Prim{}) -> return term + Suspension{val, ty} -> cvObtainTerm hsc_env defaultDepth False ty val + Prim{} -> return term From 04ecc1217d3160419b03c4c26d37fbf6869bfa00 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 10 Nov 2025 11:26:47 +0000 Subject: [PATCH 10/40] Add test for #47 with custom instance Includes test for non-debug-view value inside of debug-view value instance --- test/integration-tests/data/T47a/Main.hs | 29 +++++++++++++++ test/integration-tests/data/T47a/T47a.cabal | 19 ++++++++++ .../integration-tests/data/T47a/cabal.project | 1 + test/integration-tests/test/adapter.test.ts | 35 +++++++++++++++++++ 4 files changed, 84 insertions(+) create mode 100644 test/integration-tests/data/T47a/Main.hs create mode 100644 test/integration-tests/data/T47a/T47a.cabal create mode 100644 test/integration-tests/data/T47a/cabal.project diff --git a/test/integration-tests/data/T47a/Main.hs b/test/integration-tests/data/T47a/Main.hs new file mode 100644 index 0000000..d18ec2b --- /dev/null +++ b/test/integration-tests/data/T47a/Main.hs @@ -0,0 +1,29 @@ +module Main where +import GHC.Debugger.View.Class + +import qualified Data.IntMap as IM +import qualified Data.Map as M + +data X = X String + deriving Show + +data Y = Y String + deriving Show + +instance DebugView X where + debugValue _ = VarValue "SDJFLSKDJFLKSDJFLSJDKFL" True + debugFields (X s) = VarFields + [ ("field1", (VarFieldValue s)) + , ("myfield2", (VarFieldValue (length s))) + , ("field4", (VarFieldValue 2345)) + , ("field5", (VarFieldValue (2345 :: Double))) + -- important! test no-debug-view type inside of debug-view instance. this used to crash: + , ("field3", (VarFieldValue (Y (show (length "inner Y"))))) + ] + +main :: IO () +main = f (X "A33") + +f :: Show a => a -> IO () +f action = do + print action diff --git a/test/integration-tests/data/T47a/T47a.cabal b/test/integration-tests/data/T47a/T47a.cabal new file mode 100644 index 0000000..8ec4db6 --- /dev/null +++ b/test/integration-tests/data/T47a/T47a.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.14 +name: T47a +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable t47a + import: warnings + main-is: Main.hs + build-depends: base, containers + build-depends: haskell-debugger-view + hs-source-dirs: . + default-language: Haskell2010 + diff --git a/test/integration-tests/data/T47a/cabal.project b/test/integration-tests/data/T47a/cabal.project new file mode 100644 index 0000000..9d07da8 --- /dev/null +++ b/test/integration-tests/data/T47a/cabal.project @@ -0,0 +1 @@ +packages: . ./haskell-debugger-view/ diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 2887c45..0614190 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -82,6 +82,10 @@ describe("Debug Adapter Tests", function () { const tmp = mkdtempSync(join(tmpdir(), "hdb-")) + path const data = process.cwd() + path; cpSync(data, tmp, { recursive: true }) // Copy data contents to temp directory + + // Copy dependency too for now (until it's available on hackage) + const hsDebugView = process.cwd() + "/../../haskell-debugger-view"; + cpSync(hsDebugView, tmp + "/haskell-debugger-view", { recursive: true }) // Copy data contents to temp directory return realpathSync(tmp) } @@ -626,6 +630,37 @@ describe("Debug Adapter Tests", function () { assert.strictEqual(_1Var.value, '333'); assert.strictEqual(_2Var.value, '34'); }) + + it('user-defined custom instance (issue #47)', async () => { + let config = mkConfig({ + projectRoot: "/data/T47a", + entryFile: "Main.hs", + entryPoint: "main", + entryArgs: [], + extraGhcArgs: [] + }) + + const expected = { path: config.projectRoot + "/" + config.entryFile, line: 29 } + await dc.hitBreakpoint(config, { path: config.entryFile, line: 29 }, expected, expected); + + let locals = await fetchLocalVars(); + const tVar = await forceLazy(locals.get('action')); + assert.strictEqual(tVar.value, "SDJFLSKDJFLKSDJFLSJDKFL") + const tChild = await expandVar(tVar); + const _1Var = await forceLazy(tChild.get('field1')); + assert.strictEqual(_1Var.value, '"A33"'); + const _2Var = await forceLazy(tChild.get('myfield2')); + assert.strictEqual(_2Var.value, '3'); + const _3Var = await forceLazy(tChild.get('field3')); + assert.strictEqual(_3Var.value, 'Y'); + const _3Child = await expandVar(_3Var); + const _3_1Var = await forceLazy(_3Child.get("_1")) + assert.strictEqual(_3_1Var.value, '"7"'); + const _4Var = await tChild.get('field4'); + assert.strictEqual(_4Var.value, '2345'); + const _5Var = await tChild.get('field5'); + assert.strictEqual(_5Var.value, '2345.0'); + }) }) describe("Stepping out (step-out)", function () { From bb60560922f3a4557117727bb2b5f5799819cfd7 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 10 Nov 2025 11:36:04 +0000 Subject: [PATCH 11/40] fix: Use propper logger in findDebugViewInstance Rather than pprTraceM --- haskell-debugger/GHC/Debugger/Runtime/Instances.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs index 37d640a..f694c3b 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -10,6 +10,8 @@ import Data.Maybe import qualified Data.List as L import GHC +import GHC.Utils.Logger +import GHC.Types.Error import GHC.Builtin.Names import GHC.Core.Class import GHC.Core.InstEnv @@ -245,6 +247,7 @@ Use | LoadDependenciesOf HomeUnitModule for 'load' findDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance) findDebugViewInstance needle_ty = do hsc_env <- getSession + logger <- getLogger -- We want to attempt finding DebugView instances twice. -- Once: using the haskell-debugger-view unit-id found by looking for @@ -325,7 +328,8 @@ findDebugViewInstance needle_ty = do case res of Nothing -> do - pprTraceM "Couldn't compile DebugView instance for" (ppr needle_ty $$ ppr err_msgs) + liftIO $ logMsg logger MCDump noSrcSpan $ + 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 -> From 0889a259274ffc6b7cd0844042cffc714fa618aa Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 10 Nov 2025 14:24:49 +0000 Subject: [PATCH 12/40] Delete JSON instances for adapter-debugger Messages We haven't needed these in a long while since the adapter and debugger lib run in the same process --- .../GHC/Debugger/Interface/Messages.hs | 71 ++++--------------- 1 file changed, 12 insertions(+), 59 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs index a0be566..cb99d2e 100644 --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -1,17 +1,13 @@ {-# LANGUAGE LambdaCase, - DeriveGeneric, StandaloneDeriving, OverloadedStrings, DuplicateRecordFields, TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- JSON GHC.BreakpointId -- | Types for sending and receiving messages to/from haskell-debugger module GHC.Debugger.Interface.Messages where -import GHC.Generics -import Data.Aeson import qualified GHC import qualified GHC.Utils.Outputable as GHC import GHC.Unit.Types @@ -86,7 +82,7 @@ data Command -- | 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. @@ -95,7 +91,7 @@ data Breakpoint | FunctionBreak { function :: String } | OnExceptionsBreak | OnUncaughtExceptionsBreak - deriving (Show, Generic) + deriving (Show) -- | Information about a scope data ScopeInfo = ScopeInfo @@ -103,10 +99,10 @@ data ScopeInfo = ScopeInfo , sourceSpan :: SourceSpan , numVars :: Maybe Int , expensive :: Bool } - deriving (Show, Generic) + deriving (Show) newtype VarFields = VarFields [VarInfo] - deriving (Show, Generic, Eq) + deriving (Show, Eq) -- | Information about a variable data VarInfo = VarInfo @@ -120,7 +116,7 @@ data VarInfo = VarInfo -- 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 @@ -129,7 +125,7 @@ data BreakpointKind = ModuleBreakpointKind -- | Function breakpoints | FunctionBreakpointKind - deriving (Show, Generic, Eq) + deriving (Show, Eq) instance GHC.Outputable BreakpointKind where ppr = GHC.text . show @@ -138,7 +134,7 @@ 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 @@ -158,7 +154,7 @@ data VariableReference -- 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 @@ -198,7 +194,7 @@ data SourceSpan = SourceSpan , endCol :: {-# UNPACK #-} !Int -- ^ RealSrcSpan end col } - deriving (Show, Generic) + deriving (Show) -------------------------------------------------------------------------------- -- Responses @@ -238,7 +234,7 @@ data BreakFound -- | 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 @@ -252,7 +248,7 @@ data EvalResult | 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 @@ -261,58 +257,15 @@ data StackFrame , 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" From d4a4e98232db95ba7b252df8a552447bba37e9f7 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 10 Nov 2025 16:02:05 +0000 Subject: [PATCH 13/40] Load in-memory haskell-debugger-view when it is not in closure Continues #47 and adds test for this --- .../src/GHC/Debugger/View/Class.hs | 56 ++++---- haskell-debugger/GHC/Debugger/Monad.hs | 121 ++++++++++++++++-- .../GHC/Debugger/Runtime/Instances.hs | 37 +----- haskell-debugger/GHC/Debugger/Session.hs | 21 +-- test/integration-tests/data/T47b/Main.hs | 11 ++ test/integration-tests/test/adapter.test.ts | 25 ++++ 6 files changed, 195 insertions(+), 76 deletions(-) create mode 100644 test/integration-tests/data/T47b/Main.hs diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs index 2d32887..1947a76 100644 --- a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs @@ -1,13 +1,13 @@ {-# LANGUAGE DerivingVia, StandaloneDeriving, ViewPatterns, ImpredicativeTypes #-} module GHC.Debugger.View.Class where -import qualified Data.ByteString as BS - -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import qualified Data.IntMap as IM -import qualified Data.Map as M +-- import qualified Data.ByteString as BS +-- +-- import qualified Data.Text as T +-- import qualified Data.Text.Encoding as T +-- +-- import qualified Data.IntMap as IM +-- import qualified Data.Map as M -- | The representation of the value for some variable on the debugger data VarValue = VarValue @@ -94,27 +94,27 @@ instance DebugView (a, b) where [ ("fst", VarFieldValue x) , ("snd", VarFieldValue y) ] -instance DebugView T.Text where - debugValue t = VarValue (show (T.unpack t)) False - debugFields _ = VarFields [] - -instance DebugView BS.ByteString where - debugValue t = VarValue (show (T.unpack (T.decodeUtf8 t))) False - debugFields _ = VarFields [] - -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 - ] +-- instance DebugView T.Text where +-- debugValue t = VarValue (show (T.unpack t)) False +-- debugFields _ = VarFields [] +-- +-- instance DebugView BS.ByteString where +-- debugValue t = VarValue (show (T.unpack (T.decodeUtf8 t))) False +-- debugFields _ = VarFields [] +-- +-- 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 +-- ] -------------------------------------------------------------------------------- -- * (Internal) Wrappers required to call `evalStmt` on methods more easily diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 037d247..2ba39cc 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -11,6 +11,7 @@ module GHC.Debugger.Monad where import Prelude hiding (mod) +import Data.Time import Data.Function import System.Exit import System.IO @@ -21,11 +22,15 @@ import Control.Monad.IO.Class import Control.Exception (assert) import Control.Monad.Catch +import GHC.Utils.Trace import GHC +import GHC.Data.StringBuffer import GHC.Data.Maybe (expectJust) import qualified GHCi.BreakArray as BA import GHC.Driver.DynFlags as GHC +import GHC.Unit.Module.Graph +import GHC.Unit.Types import GHC.Unit.Module.ModSummary as GHC import GHC.Utils.Outputable as GHC import GHC.Utils.Logger as GHC @@ -40,6 +45,7 @@ import Data.IORef import Data.Maybe import qualified Data.List.NonEmpty as NonEmpty import qualified Data.IntMap as IM +import qualified Data.List as L import Control.Monad.Reader import System.Posix.Signals @@ -81,6 +87,25 @@ data DebuggerState = DebuggerState , 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@. } -- | Enabling/Disabling a breakpoint @@ -159,8 +184,14 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- subsequent call to `getLogger` to be affected by a plugin. GHC.initializeSessionPlugins + -- Discover the user-given flags and targets flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags1 rootDir - setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) + + -- Add in-memory haskell-debugger-view unit + inMemHDV <- liftIO $ makeInMemoryHDV dflags1 + + -- Setup preliminary HomeUnitGraph + setupHomeUnitGraph (NonEmpty.toList flagsAndTargets ++ [inMemHDV]) dflags6 <- GHC.getSessionDynFlags @@ -170,16 +201,20 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb ok_flag <- GHC.load GHC.LoadAllTargets when (GHC.failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) + -- TODO: Add flag to disable this + hdv_uid <- makeHsDebuggerViewUnitId + -- TODO: Shouldn't initLoaderState be called somewhere? -- Set interactive context to import all loaded modules -- TODO: Think about Note [GHCi and local Preludes] and what is done in `getImplicitPreludeImports` let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" + -- dbgView should always be available, either because we manually loaded it or because it's in the transitive closure. + let dbgViewImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "GHC.Debugger.View.Class" mss <- getAllLoadedModules - GHC.setContext $ preludeImp : map (GHC.IIModule . GHC.ms_mod) mss - - runReaderT action =<< initialDebuggerState + GHC.setContext $ preludeImp : dbgViewImp : map (GHC.IIModule . GHC.ms_mod) mss + runReaderT action =<< initialDebuggerState (Just hdv_uid) -- | The logger action used to log GHC output debuggerLoggerAction :: Handle -> LogAction @@ -187,6 +222,72 @@ debuggerLoggerAction h a b c d = do hSetEncoding h utf8 -- GHC output uses utf8 defaultLogActionWithHandles h h a b c d +-- | 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, create a custom unit to 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'@ +makeHsDebuggerViewUnitId :: GHC.Ghc UnitId +makeHsDebuggerViewUnitId = do + + -- TODO: Better lookup of unit-id than by filtering list? + mod_graph <- getModuleGraph + -- Only looks at unit-nodes, this is not robust! + 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 hdv_uid + [] -> do + -- 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. + return inMemoryHDVUid + _ -> + error "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!" + +-- | The fixed unit-id for when we load the haskell-debugger-view modules in memory +inMemoryHDVUid :: UnitId +inMemoryHDVUid = toUnitId $ stringToUnit "haskell-debugger-view-in-memory" + +-- | Create a unit @haskell-debugger-view@ which uses in-memory files for the modules +makeInMemoryHDV :: DynFlags {- initial dynflags -} -> IO (DynFlags, [GHC.Target]) +makeInMemoryHDV initialDynFlags = do + let hdvDynFlags = initialDynFlags + { homeUnitId_ = inMemoryHDVUid + , importPaths = [] + , packageFlags = [] + -- [ ExposePackage + -- ("-package-id " ++ unitIdString unitId) + -- (UnitIdArg $ RealUnit (Definite unitId)) + -- (ModRenaming True []) + -- | (unitId, _) <- unitEnvList + -- ] + } + time <- getCurrentTime + bufa <- hGetStringBuffer "/Users/romes/Developer/ghc-debugger/haskell-debugger-view/src/GHC/Debugger/View/Class.hs" + return + ( hdvDynFlags + , [ GHC.Target + { targetId = GHC.TargetFile "dummy" Nothing + , targetAllowObjCode = False + , GHC.targetUnitId = inMemoryHDVUid + , GHC.targetContents = Just (bufa , time) + } + ] + ) + + -- | 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. @@ -383,11 +484,13 @@ freshInt = do return i -- | Initialize a 'DebuggerState' -initialDebuggerState :: GHC.Ghc DebuggerState -initialDebuggerState = DebuggerState <$> liftIO (newIORef BM.empty) - <*> liftIO (newIORef mempty) - <*> liftIO (newIORef mempty) - <*> liftIO (newIORef 0) +initialDebuggerState :: Maybe UnitId -> GHC.Ghc DebuggerState +initialDebuggerState hsDbgViewUid = + DebuggerState <$> liftIO (newIORef BM.empty) + <*> liftIO (newIORef mempty) + <*> liftIO (newIORef mempty) + <*> liftIO (newIORef 0) + <*> pure hsDbgViewUid -- | Lift a 'Ghc' action into a 'Debugger' one. liftGhc :: GHC.Ghc a -> Debugger a diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs index f694c3b..ddb14f4 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -81,7 +81,7 @@ debugValueTerm term = do return Nothing Right transformed_v -> do - liftIO (cvObtainTerm hsc_env 2 True varValueIOTy transformed_v) >>= \case + liftIO (cvObtainTerm hsc_env maxBound True varValueIOTy transformed_v) >>= \case -- Get the Term of the VarValue to decode fields Term{ ty=_{-assert==VarValueIO-} @@ -98,7 +98,7 @@ debugValueTerm term = do | falseDataCon == dc -> False Term{dc=Right dc} | trueDataCon == dc -> True - _ -> False + _ -> error "Decoding of VarValue failed" return $ Just VarValue { varValue = valStr @@ -249,27 +249,9 @@ findDebugViewInstance needle_ty = do hsc_env <- getSession logger <- getLogger - -- We want to attempt finding DebugView instances twice. - -- Once: using the haskell-debugger-view unit-id found by looking for - -- "GHC.Debugger.View.Class" in the module graph. - -- - This will be the module depended on by the user or library authors to - -- define custom instances for types they use in their program -- which is - -- why it's so important to find the right unit-id. - -- Second: using a built-in unit-id for a runtime-loaded version of haskell-debugger-view. - -- - We look for our own custom defined instances with this unit id if there - -- was none found for the former. - - -- TODO: Better lookup of unit-id, and do it on 'runDebugger' and store... - mod_graph <- getModuleGraph - 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] -> liftIO $ do - + mhdv_uid <- getHsDebuggerViewUid + case mhdv_uid of + Just hdv_uid -> liftIO $ do let modl = mkModule (RealUnit (Definite hdv_uid)) (mkModuleName "GHC.Debugger.View.Class") let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr) @@ -334,13 +316,8 @@ findDebugViewInstance needle_ty = do return Nothing Just is -> return $ Just is - ms -> do - -- 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!!! - -- - -- ... - -- PRINCIPLE: User code should not have to be modified to use the debugger + Nothing -> + -- Custom view is disabled return Nothing -- | Try to compile and load a class method for the given type. diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index d0c96fe..f7e06c1 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -36,6 +36,7 @@ import qualified Data.Containers.ListUtils as L 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 @@ -58,6 +59,7 @@ import GHC.Data.FastString 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 @@ -225,7 +227,7 @@ setupMultiHomeUnitGhcSession exts hsc_env cis = do 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) @@ -242,8 +244,8 @@ data TargetDetails = TargetDetails -- 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'. -- @@ -253,29 +255,30 @@ data Target = TargetModule ModuleName | TargetFile FilePath -- | 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 diff --git a/test/integration-tests/data/T47b/Main.hs b/test/integration-tests/data/T47b/Main.hs new file mode 100644 index 0000000..f7565b9 --- /dev/null +++ b/test/integration-tests/data/T47b/Main.hs @@ -0,0 +1,11 @@ +module Main where + +data X = X (String, Double) + deriving Show + +main :: IO () +main = f (X ("A33", 3456)) + +f :: Show a => a -> IO () +f action = do + print action diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 0614190..4836df6 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -661,6 +661,31 @@ describe("Debug Adapter Tests", function () { const _5Var = await tChild.get('field5'); assert.strictEqual(_5Var.value, '2345.0'); }) + + it('user-defined custom instance without haskell-debugger-view dependency (issue #47)', async () => { + let config = mkConfig({ + projectRoot: "/data/T47b", + entryFile: "Main.hs", + entryPoint: "main", + entryArgs: [], + extraGhcArgs: [] + }) + + const expected = { path: config.projectRoot + "/" + config.entryFile, line: 11 } + await dc.hitBreakpoint(config, { path: config.entryFile, line: 11 }, expected, expected); + + let locals = await fetchLocalVars(); + const tVar = await forceLazy(locals.get('action')); + assert.strictEqual(tVar.value, "X") + const tChild = await expandVar(tVar); + const _1Var = await tChild.get('_1'); + assert.strictEqual(_1Var.value, '( , )'); + const _1Child = await expandVar(_1Var); + const _2Var = await forceLazy(_1Child.get('fst')); + assert.strictEqual(_2Var.value, '"A33"'); + const _3Var = await _1Child.get('snd'); + assert.strictEqual(_3Var.value, '3456.0'); + }) }) describe("Stepping out (step-out)", function () { From e3c0e481dd6242b82775547dfa1ab8e586a8f606 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 10 Nov 2025 16:08:57 +0000 Subject: [PATCH 14/40] Use file-embed to embed class in hdb --- haskell-debugger.cabal | 2 ++ haskell-debugger/GHC/Debugger/Monad.hs | 8 +++++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index fe64d8a..33dab2d 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -84,11 +84,13 @@ library 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 diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 2ba39cc..6eebc1c 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} module GHC.Debugger.Monad where @@ -20,6 +21,7 @@ import System.Directory (makeAbsolute) import Control.Monad import Control.Monad.IO.Class import Control.Exception (assert) +import Data.FileEmbed import Control.Monad.Catch import GHC.Utils.Trace @@ -275,14 +277,14 @@ makeInMemoryHDV initialDynFlags = do -- ] } time <- getCurrentTime - bufa <- hGetStringBuffer "/Users/romes/Developer/ghc-debugger/haskell-debugger-view/src/GHC/Debugger/View/Class.hs" + let buffer = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/Class.hs") return ( hdvDynFlags , [ GHC.Target - { targetId = GHC.TargetFile "dummy" Nothing + { targetId = GHC.TargetFile "dummy-for-GHC.Debugger.View.Class" Nothing , targetAllowObjCode = False , GHC.targetUnitId = inMemoryHDVUid - , GHC.targetContents = Just (bufa , time) + , GHC.targetContents = Just (buffer, time) } ] ) From 50e184dbb2d2f72148bc7933578514294b9bb5d6 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 10 Nov 2025 17:12:00 +0000 Subject: [PATCH 15/40] Robust loading of built-in debug view classes Makes sure to try the following in order - First, try to find existing haskell-debugger-view dependency - Second, try to load built-in haskell-debugger-view modules if no dependency was found - Third, gracefully default to not using custom instances at all if the built-in modules failed to load Things left to do: - gracefully try to load modules for the orphan instances (text, bs, containers, ...) both for in-memory and as dependency. - refactor to cache DebugInstanceView - refactor Monad module to clean this up a bit further --- .../haskell-debugger-view.cabal | 6 + .../src/GHC/Debugger/View/ByteString.hs | 11 ++ .../src/GHC/Debugger/View/Containers.hs | 21 ++++ .../src/GHC/Debugger/View/Text.hs | 11 ++ haskell-debugger/GHC/Debugger/Monad.hs | 115 +++++++++++++----- 5 files changed, 131 insertions(+), 33 deletions(-) create mode 100644 haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs create mode 100644 haskell-debugger-view/src/GHC/Debugger/View/Containers.hs create mode 100644 haskell-debugger-view/src/GHC/Debugger/View/Text.hs diff --git a/haskell-debugger-view/haskell-debugger-view.cabal b/haskell-debugger-view/haskell-debugger-view.cabal index b5d871d..d354186 100644 --- a/haskell-debugger-view/haskell-debugger-view.cabal +++ b/haskell-debugger-view/haskell-debugger-view.cabal @@ -12,7 +12,13 @@ common warnings library import: warnings + -- If you add a module here make sure to also add this module to the list + -- of modules that we attempt to load when haskell-debug-view is not + -- dependend upon transitively, in GHC.Debugger.Runtime.... exposed-modules: GHC.Debugger.View.Class + GHC.Debugger.View.Containers + GHC.Debugger.View.Text + GHC.Debugger.View.ByteString build-depends: base, containers >= 0.7 && < 0.9, text >= 2.1 && < 2.3, diff --git a/haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs b/haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs new file mode 100644 index 0000000..191371b --- /dev/null +++ b/haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs @@ -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 [] + diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Containers.hs b/haskell-debugger-view/src/GHC/Debugger/View/Containers.hs new file mode 100644 index 0000000..a2a5327 --- /dev/null +++ b/haskell-debugger-view/src/GHC/Debugger/View/Containers.hs @@ -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 + ] diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Text.hs b/haskell-debugger-view/src/GHC/Debugger/View/Text.hs new file mode 100644 index 0000000..470d73f --- /dev/null +++ b/haskell-debugger-view/src/GHC/Debugger/View/Text.hs @@ -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 [] + diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 6eebc1c..d76db34 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -27,6 +27,11 @@ import Control.Monad.Catch import GHC.Utils.Trace import GHC +import GHC.Driver.Make +import GHC.Driver.Messager +import GHC.Driver.Errors.Types +import GHC.Types.SourceError +import GHC.Types.Error import GHC.Data.StringBuffer import GHC.Data.Maybe (expectJust) import qualified GHCi.BreakArray as BA @@ -189,34 +194,82 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- Discover the user-given flags and targets flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags1 rootDir - -- Add in-memory haskell-debugger-view unit - inMemHDV <- liftIO $ makeInMemoryHDV dflags1 - - -- Setup preliminary HomeUnitGraph - setupHomeUnitGraph (NonEmpty.toList flagsAndTargets ++ [inMemHDV]) + -- Setup base HomeUnitGraph + setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) dflags6 <- GHC.getSessionDynFlags - -- Should this be done in GHC= + -- Should this be done in GHC? liftIO $ GHC.initUniqSupply (GHC.initialUnique dflags6) (GHC.uniqueIncrement dflags6) - ok_flag <- GHC.load GHC.LoadAllTargets - when (GHC.failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) - - -- TODO: Add flag to disable this - hdv_uid <- makeHsDebuggerViewUnitId - - -- TODO: Shouldn't initLoaderState be called somewhere? +#if __GLASGOW_HASKELL__ > 914 + msg <- batchMultiMsg <$> getSession +#else + let msg = batchMultiMsg +#endif + + -- Get mod_graph for base HUG + (errs_base, mod_graph_base) <- depanalE mkUnknownDiagnostic (Just msg) [] False + + when (not $ isEmptyMessages errs_base) $ do +#if __GLASGOW_HASKELL__ > 914 + sec <- initSourceErrorContext . hsc_dflags <$> getSession + throwErrors sec (fmap GhcDriverMessage errs_base) +#else + throwErrors (fmap GhcDriverMessage errs_base) +#endif + + mhdv_uid <- findHsDebuggerViewUnitId mod_graph_base + (hdv_uid, mod_graph) <- case mhdv_uid of + Nothing -> do + -- 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. + + -- Add in-memory haskell-debugger-view unit + inMemHDV <- liftIO $ makeInMemoryHDV dflags1 + -- Try again, with custom modules loaded + setupHomeUnitGraph (NonEmpty.toList flagsAndTargets ++ [inMemHDV]) + (errs, mod_graph) <- depanalE mkUnknownDiagnostic (Just msg) [] False + when (not $ isEmptyMessages errs) $ do +#if __GLASGOW_HASKELL__ > 914 + sec <- initSourceErrorContext . hsc_dflags <$> getSession + throwErrors sec (fmap GhcDriverMessage errs) +#else + throwErrors (fmap GhcDriverMessage errs) +#endif + return (inMemoryHDVUid, mod_graph) + + Just uid -> + return (uid, mod_graph_base) + + (success, dbg_view_loaded) <- + -- Load only up to debugger-view modules + load' noIfaceCache (GHC.LoadUpTo [mkModule hdv_uid (mkModuleName "GHC.Debugger.View.Class")]) mkUnknownDiagnostic (Just msg) mod_graph + >>= \case + Failed -> (, False) <$> do + -- Failed to load debugger-view modules! Try again without the haskell-debugger-view modules + logger <- getLogger + liftIO $ logMsg logger MCInfo noSrcSpan $ + text "Failed to compile built-in DebugView modules! Ignoring custom debug views." + setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) + load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base + Succeeded -> (, True) <$> do + -- It worked! Now load everything else + load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) 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 dbgViewImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "GHC.Debugger.View.Class" mss <- getAllLoadedModules - GHC.setContext $ preludeImp : dbgViewImp : map (GHC.IIModule . GHC.ms_mod) mss + GHC.setContext $ + preludeImp + : (if dbg_view_loaded then [dbgViewImp] else []) + ++ map (GHC.IIModule . GHC.ms_mod) mss - runReaderT action =<< initialDebuggerState (Just hdv_uid) + runReaderT action =<< initialDebuggerState (if dbg_view_loaded then Just hdv_uid else Nothing) -- | The logger action used to log GHC output debuggerLoggerAction :: Handle -> LogAction @@ -230,17 +283,16 @@ getHsDebuggerViewUid :: Debugger (Maybe UnitId) getHsDebuggerViewUid = asks hsDbgViewUnitId -- | Try to find the @haskell-debugger-view@ unit-id in the transitive closure, --- or, otherwise, create a custom unit to load the @haskell-debugger-view@ --- modules in it (essentially preparing an in-memory version of the library to --- find the built-in instances in). +-- 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'@ -makeHsDebuggerViewUnitId :: GHC.Ghc UnitId -makeHsDebuggerViewUnitId = do +findHsDebuggerViewUnitId :: ModuleGraph -> GHC.Ghc (Maybe UnitId) +findHsDebuggerViewUnitId mod_graph = do - -- TODO: Better lookup of unit-id than by filtering list? - mod_graph <- getModuleGraph -- 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 @@ -250,11 +302,9 @@ makeHsDebuggerViewUnitId = do case hskl_dbgr_vws of [hdv_uid] -> -- In transitive closure, use that one. - return hdv_uid + return (Just hdv_uid) [] -> do - -- 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. - return inMemoryHDVUid + return Nothing _ -> error "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!" @@ -269,12 +319,6 @@ makeInMemoryHDV initialDynFlags = do { homeUnitId_ = inMemoryHDVUid , importPaths = [] , packageFlags = [] - -- [ ExposePackage - -- ("-package-id " ++ unitIdString unitId) - -- (UnitIdArg $ RealUnit (Definite unitId)) - -- (ModRenaming True []) - -- | (unitId, _) <- unitEnvList - -- ] } time <- getCurrentTime let buffer = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/Class.hs") @@ -498,6 +542,11 @@ initialDebuggerState hsDbgViewUid = 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." + -------------------------------------------------------------------------------- type Warning = String From d0c874d43f9a7f21729b0d140a6ba172b0acec9d Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Tue, 11 Nov 2025 16:45:56 +0000 Subject: [PATCH 16/40] refactor: Move things from .Monad module to better ones --- haskell-debugger.cabal | 1 + haskell-debugger/GHC/Debugger.hs | 13 +- haskell-debugger/GHC/Debugger/Breakpoint.hs | 159 +++++++++++++-- haskell-debugger/GHC/Debugger/Evaluation.hs | 12 +- haskell-debugger/GHC/Debugger/Monad.hs | 188 ++++-------------- haskell-debugger/GHC/Debugger/Runtime.hs | 2 - .../GHC/Debugger/Runtime/Instances.hs | 58 ++---- .../GHC/Debugger/Stopped/Variables.hs | 1 - hdb/Development/Debug/Adapter/Init.hs | 2 - hdb/Development/Debug/Session/Setup.hs | 1 + hdb/Main.hs | 6 +- 11 files changed, 204 insertions(+), 239 deletions(-) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 33dab2d..584259c 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -63,6 +63,7 @@ library GHC.Debugger.Runtime.Term.Cache, GHC.Debugger.Monad, + GHC.Debugger.Session, GHC.Debugger.Interface.Messages -- other-modules: diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs index 3567c89..e869d90 100644 --- a/haskell-debugger/GHC/Debugger.hs +++ b/haskell-debugger/GHC/Debugger.hs @@ -10,7 +10,6 @@ import GHC.Debugger.Breakpoint import GHC.Debugger.Evaluation import GHC.Debugger.Stopped import GHC.Debugger.Monad -import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages import GHC.Debugger.Logger @@ -26,17 +25,7 @@ execute recorder = \case 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 diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs index dbfe574..f3585a1 100644 --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -3,20 +3,28 @@ 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.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 @@ -44,24 +52,22 @@ clearBreakpoints mfile = do -- 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 + displayWarnings [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 - displayWarnings ["Setting a hit count condition on a conditional breakpoint is not yet supported. Ignoring breakpoint " ++ show bp] + displayWarnings [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 @@ -70,9 +76,7 @@ setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do displayWarnings [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 @@ -128,7 +132,93 @@ setBreakpoint exception_bp bp_status = do return (BreakFoundNoLoc didChange) -------------------------------------------------------------------------------- --- Utils +-- * 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 + displayWarnings [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@. @@ -140,3 +230,32 @@ condBreakEnableStatus hitCount condition = do (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 Warning 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 diff --git a/haskell-debugger/GHC/Debugger/Evaluation.hs b/haskell-debugger/GHC/Debugger/Evaluation.hs index 15e17a8..900e767 100644 --- a/haskell-debugger/GHC/Debugger/Evaluation.hs +++ b/haskell-debugger/GHC/Debugger/Evaluation.hs @@ -186,6 +186,16 @@ doEval expr = do 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 @@ -206,7 +216,7 @@ handleExecResult = \case case BM.lookup bid bm of -- todo: BreakpointAfterCountCond is not handled yet. Just (BreakpointWhenCond cond, _) -> do - let evalFailedMsg e = "Evaluation of conditional breakpoint expression failed with " ++ e ++ "\nIgnoring..." + 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" diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index d76db34..0b3799d 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -11,57 +11,44 @@ module GHC.Debugger.Monad where -import Prelude hiding (mod) -import Data.Time -import Data.Function -import System.Exit -import System.IO -import System.FilePath (normalise) -import System.Directory (makeAbsolute) import Control.Monad +import Control.Monad.Catch import Control.Monad.IO.Class -import Control.Exception (assert) +import Control.Monad.Reader import Data.FileEmbed - -import Control.Monad.Catch -import GHC.Utils.Trace +import Data.Function +import Data.IORef +import Data.Time +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 GHC.Data.StringBuffer +import GHC.Driver.DynFlags as GHC +import GHC.Driver.Env +import GHC.Driver.Errors.Types import GHC.Driver.Make import GHC.Driver.Messager -import GHC.Driver.Errors.Types -import GHC.Types.SourceError +import GHC.Runtime.Heap.Inspect +import GHC.Runtime.Interpreter as GHCi +import GHC.Runtime.Loader as GHC import GHC.Types.Error -import GHC.Data.StringBuffer -import GHC.Data.Maybe (expectJust) -import qualified GHCi.BreakArray as BA -import GHC.Driver.DynFlags as GHC +import GHC.Types.SourceError +import GHC.Types.Unique.Supply as GHC import GHC.Unit.Module.Graph -import GHC.Unit.Types 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.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 qualified Data.List as L - -import Control.Monad.Reader -import System.Posix.Signals +import GHC.Utils.Outputable as GHC import GHC.Debugger.Interface.Messages -import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Runtime.Term.Cache +import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Session -import GHC.ByteCode.Breakpoints import qualified GHC.Debugger.Breakpoint.Map as BM -- | A debugger action. @@ -333,91 +320,6 @@ makeInMemoryHDV initialDynFlags = do ] ) - --- | 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 - displayWarnings [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 - ] - --- | List all loaded modules 'ModSummary's -getAllLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary] -getAllLoadedModules = - (GHC.mgModSummaries <$> GHC.getModuleGraph) >>= - filterM (\ms -> GHC.isLoadedModule (GHC.ms_unitid ms) (GHC.ms_mod_name ms)) - --- | Get a 'ModSummary' of a loaded module given its 'FilePath' -getModuleByPath :: FilePath -> Debugger (Either String ModSummary) -getModuleByPath path = do - -- do this every time as the loaded modules may have changed - lms <- getAllLoadedModules - absPath <- liftIO $ makeAbsolute path - let matches ms = normalise (msHsFilePath ms) == normalise absPath - return $ case filter matches lms of - [x] -> Right x - [] -> Left $ "No module matched " ++ path ++ ".\nLoaded modules:\n" ++ show (map msHsFilePath lms) ++ "\n. Perhaps you've set a breakpoint on a module that isn't loaded into the session?" - xs -> Left $ "Too many modules (" ++ showPprUnsafe xs ++ ") matched " ++ path ++ ". Please report a bug at https://github.com/well-typed/haskell-debugger." - -------------------------------------------------------------------------------- -- Variable references -------------------------------------------------------------------------------- @@ -501,25 +403,6 @@ deepseqTerm hsc_env t = case t of return t{wrapped_term = wrapped_term'} _ -> do seqTerm hsc_env 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 - BreakpointWhenCond{} -> BA.breakOn -- always stop, cond evaluated after - BreakpointAfterCountCond{} -> BA.breakOn -- ditto, decrease only when cond is true - -- | Generate a new unique 'Int' freshInt :: Debugger Int freshInt = do @@ -549,10 +432,22 @@ instance Show DebuggerFailedToLoad where -------------------------------------------------------------------------------- -type Warning = String +type Warning = SDoc displayWarnings :: [Warning] -> Debugger () -displayWarnings = liftIO . putStrLn . unlines +displayWarnings ws = do + logger <- getLogger + liftIO $ logMsg logger MCInfo noSrcSpan (vcat ws) + +-------------------------------------------------------------------------------- +-- * 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)) -------------------------------------------------------------------------------- -- Instances @@ -565,12 +460,3 @@ instance GHC.GhcMonad Debugger where getSession = liftGhc GHC.getSession setSession s = liftGhc $ GHC.setSession s --------------------------------------------------------------------------------- - --- | 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 diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs index 88b5acc..b2bda6f 100644 --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -7,14 +7,12 @@ import qualified Data.List as L import GHC import GHC.Utils.Outputable -import GHC.Utils.Trace import GHC.Types.FieldLabel import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Runtime.Term.Cache -import GHC.Debugger.Runtime.Instances import GHC.Debugger.Monad -- | Obtain the runtime 'Term' from a 'TermKey'. diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs index ddb14f4..1500283 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -3,26 +3,17 @@ module GHC.Debugger.Runtime.Instances where import Control.Exception import Control.Monad -import Data.Either import Control.Monad.Reader -import Data.IORef -import Data.Maybe -import qualified Data.List as L import GHC -import GHC.Utils.Logger -import GHC.Types.Error import GHC.Builtin.Names -import GHC.Core.Class -import GHC.Core.InstEnv -import GHC.Unit.Module.Graph import GHC.Core.TyCon import GHC.Core.Type import GHC.Driver.Config import GHC.Driver.Env -import GHC.Driver.Errors.Types import GHC.Driver.Main -import GHC.HsToCore +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad import GHC.Plugins import GHC.Rename.Env import GHC.Rename.Expr @@ -30,33 +21,18 @@ 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.ThToHs -import GHC.Types.FieldLabel -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Var -import GHC.Unit.Finder -import GHC.Unit.State -import GHC.Utils.Outputable +import GHC.Tc.Zonk.Type +import GHC.Types.Error +import GHC.Utils.Logger import GHCi.Message -import qualified GHC.Linker.Loader as Loader -import qualified GHC.Runtime.Heap.Inspect as Inspect -import qualified GHC.Runtime.Debugger as GHCD import GHC.Debugger.Monad -import GHC.Debugger.Runtime.Term.Cache -import GHC.Debugger.Runtime.Term.Key -import GHC.Debugger.Utils import GHC.Debugger.View.Class -import GHC.Tc.Utils.Monad -import GHC.Debugger.Session -import GHC.Tc.Solver -import GHC.Tc.Types.Evidence -import GHC.Tc.Zonk.Type -import GHC.HsToCore.Monad -import GHC.HsToCore.Expr -------------------------------------------------------------------------------- -- * High level interface for 'DebugView' on 'Term's @@ -68,8 +44,7 @@ debugValueTerm :: Term -> Debugger (Maybe VarValue) debugValueTerm term = do hsc_env <- getSession let interp = hscInterp hsc_env - let dflags = hsc_dflags hsc_env - let ty = Inspect.termType term + let ty = termType term mbInst <- findDebugViewInstance ty case mbInst of Nothing -> return Nothing @@ -119,13 +94,12 @@ debugFieldsTerm :: Term -> Debugger (Maybe [(String, Term)]) debugFieldsTerm term = do hsc_env <- getSession let interp = hscInterp hsc_env - let dflags = hsc_dflags hsc_env - let ty = Inspect.termType term + let ty = termType term mbInst <- findDebugViewInstance ty case mbInst of Nothing -> return Nothing Just DebugViewInstance - {instDebugFields, varFieldsIOTy, varFieldValueTy, ioTyCon} -> do + {instDebugFields, varFieldsIOTy} -> do liftIO (instDebugFields (val term)) >>= \case Left _e -> -- exception! ignore. @@ -153,7 +127,7 @@ debugFieldsTerm term = do seqTerm hsc_env varFieldValTerm >>= \case Term{subTerms=[unexpandedValueTerm]} -> do actualValueTerm <- liftIO $ do - let val_ty = Inspect.termType unexpandedValueTerm + let val_ty = termType unexpandedValueTerm cvObtainTerm hsc_env defaultDepth False{-don't force-} val_ty (val unexpandedValueTerm) return (fieldStr, actualValueTerm) @@ -193,10 +167,6 @@ data DebugViewInstance = DebugViewInstance , varValueIOTy :: Type -- | 'VarFieldsIO' type , varFieldsIOTy :: Type - -- | 'VarFieldValue' type - , varFieldValueTy :: Type - -- | 'IO' Ty con - , ioTyCon :: TyCon } -------------------------------------------------------------------------------- @@ -262,8 +232,6 @@ findDebugViewInstance needle_ty = do =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarValueIO")) varFieldsIOTy <- fmap mkTyConTy . tcLookupTyCon =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarFieldsIO")) - varFieldValueTy <- fmap mkTyConTy . tcLookupTyCon - =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarFieldValue")) ioTyCon <- tcLookupTyCon ioTyConName @@ -304,8 +272,6 @@ findDebugViewInstance needle_ty = do (EvalThis debugFields_fval `EvalApp` EvalThis x_fval) , varValueIOTy , varFieldsIOTy - , varFieldValueTy - , ioTyCon } case res of diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs index bf23e06..8732bfa 100644 --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -17,7 +17,6 @@ import qualified GHC.Runtime.Debugger as GHCD import qualified GHC.Runtime.Heap.Inspect as GHCI import GHC.Debugger.View.Class hiding (VarFields) -import qualified GHC.Debugger.View.Class as VC import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 893c917..61bbd82 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -45,8 +45,6 @@ import GHC.Debugger.Interface.Messages hiding (Command, Response) import DAP import Development.Debug.Adapter.Handles import Development.Debug.Session.Setup -import GHC.Debugger.Utils hiding ((<>)) -import GHC.Driver.Session -------------------------------------------------------------------------------- -- * Logging diff --git a/hdb/Development/Debug/Session/Setup.hs b/hdb/Development/Debug/Session/Setup.hs index 9306dd9..e3c9c0a 100644 --- a/hdb/Development/Debug/Session/Setup.hs +++ b/hdb/Development/Debug/Session/Setup.hs @@ -75,6 +75,7 @@ hieBiosSetup :: Recorder (WithSeverity FlagsLog) -> 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). diff --git a/hdb/Main.hs b/hdb/Main.hs index b468d82..1c37e23 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -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 @@ import Development.Debug.Interactive -------------------------------------------------------------------------------- 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 From 58ea4443c3c6496ac150d0994e16352acc8d153a Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Tue, 11 Nov 2025 17:39:40 +0000 Subject: [PATCH 17/40] refactor: Move some builtin things from Monad --- haskell-debugger.cabal | 1 + haskell-debugger/GHC/Debugger/Monad.hs | 143 ++++++++---------- .../GHC/Debugger/Runtime/Instances.hs | 47 +----- .../GHC/Debugger/Session/Builtin.hs | 58 +++++++ hdb/Development/Debug/Adapter/Init.hs | 1 - 5 files changed, 124 insertions(+), 126 deletions(-) create mode 100644 haskell-debugger/GHC/Debugger/Session/Builtin.hs diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 584259c..b748a7c 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -65,6 +65,7 @@ library GHC.Debugger.Monad, GHC.Debugger.Session, + GHC.Debugger.Session.Builtin, GHC.Debugger.Interface.Messages -- other-modules: default-extensions: CPP diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 0b3799d..43eae96 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -15,10 +15,8 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Reader -import Data.FileEmbed import Data.Function import Data.IORef -import Data.Time import Prelude hiding (mod) import System.IO import System.Posix.Signals @@ -27,7 +25,6 @@ import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty import GHC -import GHC.Data.StringBuffer import GHC.Driver.DynFlags as GHC import GHC.Driver.Env import GHC.Driver.Errors.Types @@ -49,6 +46,7 @@ import GHC.Debugger.Interface.Messages import GHC.Debugger.Runtime.Term.Cache import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Session +import GHC.Debugger.Session.Builtin import qualified GHC.Debugger.Breakpoint.Map as BM -- | A debugger action. @@ -169,27 +167,23 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- Override the logger to output to the given handle GHC.pushLogHook (const $ debuggerLoggerAction dbg_out) - -- TODO: this is weird, we set the session dynflags now to initialise - -- the hsc_interp. - -- This is incredibly dubious + -- Set the session dynflags now to initialise the hsc_interp. _ <- GHC.setSessionDynFlags dflags1 -- Initialise plugins here because the plugin author might already expect this -- subsequent call to `getLogger` to be affected by a plugin. GHC.initializeSessionPlugins + 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 dflags1 rootDir -- Setup base HomeUnitGraph setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) - dflags6 <- GHC.getSessionDynFlags - - -- Should this be done in GHC? - liftIO $ GHC.initUniqSupply (GHC.initialUnique dflags6) (GHC.uniqueIncrement dflags6) - -#if __GLASGOW_HASKELL__ > 914 +#if MIN_VERSION_ghc(9,15,0) msg <- batchMultiMsg <$> getSession #else let msg = batchMultiMsg @@ -199,7 +193,7 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb (errs_base, mod_graph_base) <- depanalE mkUnknownDiagnostic (Just msg) [] False when (not $ isEmptyMessages errs_base) $ do -#if __GLASGOW_HASKELL__ > 914 +#if MIN_VERSION_ghc(9,15,0) sec <- initSourceErrorContext . hsc_dflags <$> getSession throwErrors sec (fmap GhcDriverMessage errs_base) #else @@ -213,32 +207,31 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- ones haven't been loaded. In this case, we will load the package ourselves. -- Add in-memory haskell-debugger-view unit - inMemHDV <- liftIO $ makeInMemoryHDV dflags1 + inMemHDV <- liftIO . makeInMemoryHsDebuggerViewUnit =<< getDynFlags -- Try again, with custom modules loaded setupHomeUnitGraph (NonEmpty.toList flagsAndTargets ++ [inMemHDV]) (errs, mod_graph) <- depanalE mkUnknownDiagnostic (Just msg) [] False when (not $ isEmptyMessages errs) $ do -#if __GLASGOW_HASKELL__ > 914 +#if MIN_VERSION_ghc(9,15,0) sec <- initSourceErrorContext . hsc_dflags <$> getSession throwErrors sec (fmap GhcDriverMessage errs) #else throwErrors (fmap GhcDriverMessage errs) #endif - return (inMemoryHDVUid, mod_graph) + return (hsDebuggerViewInMemoryUnitId, mod_graph) Just uid -> return (uid, mod_graph_base) (success, dbg_view_loaded) <- -- Load only up to debugger-view modules - load' noIfaceCache (GHC.LoadUpTo [mkModule hdv_uid (mkModuleName "GHC.Debugger.View.Class")]) mkUnknownDiagnostic (Just msg) mod_graph + load' noIfaceCache (GHC.LoadUpTo [mkModule hdv_uid debuggerViewClassModName]) mkUnknownDiagnostic (Just msg) mod_graph >>= \case Failed -> (, False) <$> do -- Failed to load debugger-view modules! Try again without the haskell-debugger-view modules logger <- getLogger liftIO $ logMsg logger MCInfo noSrcSpan $ text "Failed to compile built-in DebugView modules! Ignoring custom debug views." - setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base Succeeded -> (, True) <$> do -- It worked! Now load everything else @@ -249,7 +242,7 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- Set interactive context to import all loaded modules 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 dbgViewImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "GHC.Debugger.View.Class" + let dbgViewImp = GHC.IIDecl . GHC.simpleImportDecl $ debuggerViewClassModName mss <- getAllLoadedModules GHC.setContext $ preludeImp @@ -264,6 +257,10 @@ debuggerLoggerAction h a b c d = do hSetEncoding h utf8 -- GHC output uses utf8 defaultLogActionWithHandles h h a b c d +-------------------------------------------------------------------------------- +-- * Finding Debugger View +-------------------------------------------------------------------------------- + -- | Fetch the @haskell-debugger-view@ unit-id from the environment. -- @Nothing@ means custom debugger views are disabled. getHsDebuggerViewUid :: Debugger (Maybe UnitId) @@ -295,31 +292,6 @@ findHsDebuggerViewUnitId mod_graph = do _ -> error "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!" --- | The fixed unit-id for when we load the haskell-debugger-view modules in memory -inMemoryHDVUid :: UnitId -inMemoryHDVUid = toUnitId $ stringToUnit "haskell-debugger-view-in-memory" - --- | Create a unit @haskell-debugger-view@ which uses in-memory files for the modules -makeInMemoryHDV :: DynFlags {- initial dynflags -} -> IO (DynFlags, [GHC.Target]) -makeInMemoryHDV initialDynFlags = do - let hdvDynFlags = initialDynFlags - { homeUnitId_ = inMemoryHDVUid - , importPaths = [] - , packageFlags = [] - } - time <- getCurrentTime - let buffer = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/Class.hs") - return - ( hdvDynFlags - , [ GHC.Target - { targetId = GHC.TargetFile "dummy-for-GHC.Debugger.View.Class" Nothing - , targetAllowObjCode = False - , GHC.targetUnitId = inMemoryHDVUid - , GHC.targetContents = Just (buffer, time) - } - ] - ) - -------------------------------------------------------------------------------- -- Variable references -------------------------------------------------------------------------------- @@ -365,44 +337,6 @@ leaveSuspendedState = do -- Utilities -------------------------------------------------------------------------------- -defaultDepth :: Int -defaultDepth = 2 -- the depth determines how much of the runtime structure is traversed. - -- @obtainTerm@ and friends handle fetching arbitrarily nested data structures - -- so we only depth enough to get to the next level of subterms. - --- | Evaluate a suspended Term to WHNF. --- --- Used in @'getVariables'@ to reply to a variable introspection request. -seqTerm :: 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} -> do - r <- GHCi.seqHValue interp unit_env val - () <- fromEvalResult r - let - forceThunks = False {- whether to force the thunk subterms -} - forceDepth = defaultDepth - cvObtainTerm hsc_env forceDepth forceThunks ty val - NewtypeWrap{wrapped_term} -> do - wrapped_term' <- seqTerm hsc_env wrapped_term - return term{wrapped_term=wrapped_term'} - _ -> return term - --- | Evaluate a Term to NF -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 hsc_env wrapped_term - return t{wrapped_term = wrapped_term'} - _ -> do seqTerm hsc_env t - -- | Generate a new unique 'Int' freshInt :: Debugger Int freshInt = do @@ -450,7 +384,50 @@ getAllLoadedModules = filterM (\ms -> GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms)) -------------------------------------------------------------------------------- --- Instances +-- * 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 + +-- | Evaluate a suspended Term to WHNF. +-- +-- Used in @'getVariables'@ to reply to a variable introspection request. +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} -> do + r <- GHCi.seqHValue interp unit_env val + () <- fromEvalResult r + let + forceThunks = False {- whether to force the thunk subterms -} + forceDepth = defaultDepth + cvObtainTerm hsc_env forceDepth forceThunks ty val + NewtypeWrap{wrapped_term} -> do + wrapped_term' <- seqTerm hsc_env wrapped_term + return term{wrapped_term=wrapped_term'} + _ -> return term + +-- | Evaluate a Term to NF +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 hsc_env wrapped_term + return t{wrapped_term = wrapped_term'} + _ -> do seqTerm hsc_env t + +-------------------------------------------------------------------------------- +-- * Instances -------------------------------------------------------------------------------- instance GHC.HasLogger Debugger where diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs index 1500283..539b08d 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -32,6 +32,7 @@ import GHC.Utils.Logger import GHCi.Message import GHC.Debugger.Monad +import GHC.Debugger.Session.Builtin import GHC.Debugger.View.Class -------------------------------------------------------------------------------- @@ -173,47 +174,9 @@ data DebugViewInstance = DebugViewInstance -- * Impl. to find instance and load instance methods applied to right dictionary -------------------------------------------------------------------------------- --- As long as the user depends on GHC.Debugger.View.Class somewhere in their full transitive closure, --- then we get haskell-debugger-view unit-id from the module graph; and all --- built-in instances are available because they're defined in that module. --- --- If it's NOT anywhere in the closure, we want to load it ourselves to bring --- the built-in instances into scope. - -{- -How to : -1. Make a unit id for this in memory package -2. Make a ModSummary for each of the modules in haskell-debugger-view - 2.1. Probably summariseFile with the StringBuffer argument - --- -3. Call 'compileOne' function on the ModSummary to know whether it will work or not -4. Get HomeModInfo then add it to the HUG/HPT ? --- -Alternatively: -If I knew it was going to compile, I could just load it into the interactive -context directly? --- -Main issue: how to setup the environment for the home package? -When I create the home package I have to pass some package flags -If I want to use e.g. containers for some modules I need to find the right -unit-id of containers that the user is using to pick the right one. - -I could just get the module graph from the user program and just use all of them since that's the "maximal" set - -If containers is not in the existing build plan then no need to try and compile that module -(If load to int. context did work) - --------------------------------------------------------------------------------- -Perhaps more easily: - -Just get the user module graph and inject the modules - -Add to the module graph a ModSummary node for all of the haskell-debugger-view -modules and try to load the module graph whole again. -Use | LoadDependenciesOf HomeUnitModule for 'load' --} - +-- | 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 @@ -222,7 +185,7 @@ findDebugViewInstance needle_ty = do mhdv_uid <- getHsDebuggerViewUid case mhdv_uid of Just hdv_uid -> liftIO $ do - let modl = mkModule (RealUnit (Definite hdv_uid)) (mkModuleName "GHC.Debugger.View.Class") + let modl = mkModule (RealUnit (Definite hdv_uid)) debuggerViewClassModName let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr) (err_msgs, res) <- runTcInteractive hsc_env $ do diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs new file mode 100644 index 0000000..7c68b6d --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Built-in units and modules +module GHC.Debugger.Session.Builtin where + +import Data.Time +import Data.FileEmbed + +import GHC +import GHC.Unit +import GHC.Data.StringBuffer + +-------------------------------------------------------------------------------- +-- * Built-in Module names +-------------------------------------------------------------------------------- + +-- | GHC.Debugger.View.Class +debuggerViewClassModName :: ModuleName +debuggerViewClassModName = mkModuleName "GHC.Debugger.View.Class" + +-------------------------------------------------------------------------------- +-- * 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 +makeInMemoryHsDebuggerViewUnit + :: DynFlags -- ^ Initial dynflags + -> IO (DynFlags, [GHC.Target]) -- ^ The dynflags and targets of the unit +makeInMemoryHsDebuggerViewUnit initialDynFlags = do + let hdvDynFlags = initialDynFlags + { homeUnitId_ = hsDebuggerViewInMemoryUnitId + , importPaths = [] + , packageFlags = [] + } + 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 + ( hdvDynFlags + , [ mkTarget debuggerViewClassModName debuggerViewClassContents + ] + ) + +-------------------------------------------------------------------------------- +-- * 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") diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 61bbd82..2f1cf36 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -125,7 +125,6 @@ initDebugger l supportsRunInTerminal , 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. From 8b5a4311d2410f3bdd41ef62108ea96a8629228f Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Tue, 11 Nov 2025 17:45:50 +0000 Subject: [PATCH 18/40] Accept tests with better variable expansion --- test/integration-tests/test/adapter.test.ts | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 4836df6..d7cfd5e 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -582,7 +582,7 @@ describe("Debug Adapter Tests", function () { const expected = { path: config.projectRoot + "/" + config.entryFile, line: 7 } await dc.hitBreakpoint(config, { path: config.entryFile, line: 7 }, expected, expected); - async function getMutVarValue() { + async function getMutVarValue(val) { let locals = await fetchLocalVars(); const rVar = await locals.get('r'); assert.strictEqual(rVar.value, "IORef (STRef (GHC.Prim.MutVar# _))") @@ -591,13 +591,13 @@ describe("Debug Adapter Tests", function () { assert.strictEqual(r_1_Var.value, 'STRef'); const r_1_Child = await expandVar(r_1_Var); const r_1_1_Var = await r_1_Child.get("_1"); // No force - assert.strictEqual(r_1_1_Var.value, 'GHC.Prim.MutVar# _'); + assert.strictEqual(r_1_1_Var.value, 'GHC.Prim.MutVar# '+val); const r_1_1_Child = await expandVar(r_1_1_Var); - const r_1_1_1_Var = await forceLazy(r_1_1_Child.get("_1")); // FORCE REFERENCE! + const r_1_1_1_Var = await r_1_1_Child.get("_1"); return r_1_1_1_Var } - const m1 = await getMutVarValue() + const m1 = await getMutVarValue("False") assert.strictEqual(m1.value, "False") await dc.nextRequest({ threadId: 0 }); await dc.nextRequest({ threadId: 0 }); @@ -605,7 +605,7 @@ describe("Debug Adapter Tests", function () { // Now we're at the start of the last line, where the ref should be True // Note how we get it from scratch, the content of the ref must be // forced again (the forceLazy call in getMutVarValue) - const m2 = await getMutVarValue() + const m2 = await getMutVarValue("True") assert.strictEqual(m2.value, "True") }) From eb5e4cab26283eb4c1c4d7ca7b90aa8a582ed1b6 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Tue, 11 Nov 2025 18:02:20 +0000 Subject: [PATCH 19/40] refactor: Simplify runDebugger --- haskell-debugger/GHC/Debugger/Monad.hs | 70 +++++++++++++------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 43eae96..7773f8f 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -200,42 +200,42 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb throwErrors (fmap GhcDriverMessage errs_base) #endif - mhdv_uid <- findHsDebuggerViewUnitId mod_graph_base - (hdv_uid, mod_graph) <- case mhdv_uid of - Nothing -> do - -- 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. - - -- Add in-memory haskell-debugger-view unit - inMemHDV <- liftIO . makeInMemoryHsDebuggerViewUnit =<< getDynFlags - -- Try again, with custom modules loaded - setupHomeUnitGraph (NonEmpty.toList flagsAndTargets ++ [inMemHDV]) - (errs, mod_graph) <- depanalE mkUnknownDiagnostic (Just msg) [] False - when (not $ isEmptyMessages errs) $ do + (hdv_uid, success) <- + findHsDebuggerViewUnitId mod_graph_base >>= \case + Nothing -> do + -- 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. + + -- Add in-memory haskell-debugger-view unit + in_mem_hdv <- liftIO . makeInMemoryHsDebuggerViewUnit =<< getDynFlags + -- Try again, with custom modules loaded + setupHomeUnitGraph (NonEmpty.toList flagsAndTargets ++ [in_mem_hdv]) + (errs, mod_graph) <- depanalE mkUnknownDiagnostic (Just msg) [] False + when (not $ isEmptyMessages errs) $ do #if MIN_VERSION_ghc(9,15,0) - sec <- initSourceErrorContext . hsc_dflags <$> getSession - throwErrors sec (fmap GhcDriverMessage errs) + sec <- initSourceErrorContext . hsc_dflags <$> getSession + throwErrors sec (fmap GhcDriverMessage errs) #else - throwErrors (fmap GhcDriverMessage errs) + throwErrors (fmap GhcDriverMessage errs) #endif - return (hsDebuggerViewInMemoryUnitId, mod_graph) - - Just uid -> - return (uid, mod_graph_base) - - (success, dbg_view_loaded) <- - -- Load only up to debugger-view modules - load' noIfaceCache (GHC.LoadUpTo [mkModule hdv_uid debuggerViewClassModName]) mkUnknownDiagnostic (Just msg) mod_graph - >>= \case - Failed -> (, False) <$> do - -- Failed to load debugger-view modules! Try again without the haskell-debugger-view modules - logger <- getLogger - liftIO $ logMsg logger MCInfo noSrcSpan $ - text "Failed to compile built-in DebugView modules! Ignoring custom debug views." - load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base - Succeeded -> (, True) <$> do - -- It worked! Now load everything else - load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph + + -- Load only up to debugger-view modules + load' noIfaceCache (GHC.LoadUpTo [mkModule hsDebuggerViewInMemoryUnitId debuggerViewClassModName]) + mkUnknownDiagnostic (Just msg) mod_graph >>= \case + Failed -> (Nothing,) <$> do + -- Failed to load debugger-view modules! Try again without the haskell-debugger-view modules + logger <- getLogger + liftIO $ logMsg logger MCInfo noSrcSpan $ + text "Failed to compile built-in DebugView modules! Ignoring custom debug views." + load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base + Succeeded -> (Just hsDebuggerViewInMemoryUnitId,) <$> do + -- It worked! Now load everything else + load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph + + Just hdv_uid -> (Just hdv_uid,) <$> + -- haskell-debug-view is in module graph already, so just load it all. + load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base + when (GHC.failed success) $ liftIO $ throwM DebuggerFailedToLoad @@ -246,10 +246,10 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb mss <- getAllLoadedModules GHC.setContext $ preludeImp - : (if dbg_view_loaded then [dbgViewImp] else []) + : (case hdv_uid of Just _ -> [dbgViewImp]; _ -> []) ++ map (GHC.IIModule . GHC.ms_mod) mss - runReaderT action =<< initialDebuggerState (if dbg_view_loaded then Just hdv_uid else Nothing) + runReaderT action =<< initialDebuggerState hdv_uid -- | The logger action used to log GHC output debuggerLoggerAction :: Handle -> LogAction From 45550ca0c2cbf75fc8ddfa330e73364d4daf0582 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 12 Nov 2025 14:28:35 +0000 Subject: [PATCH 20/40] fixes: Don't block on handle contents on exception if there's no data --- haskell-debugger/GHC/Debugger/Monad.hs | 20 +++++++++++++------- hdb/Development/Debug/Adapter/Exit.hs | 11 +++++++---- test/integration-tests/data/T47a/Main.hs | 5 +---- test/integration-tests/test/adapter.test.ts | 4 ++-- 4 files changed, 23 insertions(+), 17 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 7773f8f..17b3d73 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -17,6 +17,7 @@ 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 @@ -24,12 +25,15 @@ import qualified Data.IntMap as IM import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty +import GHC.Utils.Trace + import GHC import GHC.Driver.DynFlags as GHC import GHC.Driver.Env import GHC.Driver.Errors.Types +import GHC.Driver.Main import GHC.Driver.Make -import GHC.Driver.Messager +import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Loader as GHC @@ -241,13 +245,15 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- Set interactive context to import all loaded modules 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 dbgViewImp = GHC.IIDecl . GHC.simpleImportDecl $ debuggerViewClassModName + -- dbgView should always be available, either because we manually loaded it + -- or because it's in the transitive closure. + let dbgViewImp uid = (mkModule (RealUnit (Definite uid)) debuggerViewClassModName) mss <- getAllLoadedModules - GHC.setContext $ - preludeImp - : (case hdv_uid of Just _ -> [dbgViewImp]; _ -> []) - ++ map (GHC.IIModule . GHC.ms_mod) mss + + GHC.setContext + (preludeImp : + (case hdv_uid of Just uid -> [GHC.IIModule $ dbgViewImp uid]; _ -> []) ++ + map (GHC.IIModule . GHC.ms_mod) mss) runReaderT action =<< initialDebuggerState hdv_uid diff --git a/hdb/Development/Debug/Adapter/Exit.hs b/hdb/Development/Debug/Adapter/Exit.hs index edb7919..34f5574 100644 --- a/hdb/Development/Debug/Adapter/Exit.hs +++ b/hdb/Development/Debug/Adapter/Exit.hs @@ -25,6 +25,7 @@ module Development.Debug.Adapter.Exit where 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 @@ exitCleanupWithMsg -- 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 diff --git a/test/integration-tests/data/T47a/Main.hs b/test/integration-tests/data/T47a/Main.hs index d18ec2b..c408ef4 100644 --- a/test/integration-tests/data/T47a/Main.hs +++ b/test/integration-tests/data/T47a/Main.hs @@ -1,9 +1,6 @@ module Main where import GHC.Debugger.View.Class -import qualified Data.IntMap as IM -import qualified Data.Map as M - data X = X String deriving Show @@ -15,7 +12,7 @@ instance DebugView X where debugFields (X s) = VarFields [ ("field1", (VarFieldValue s)) , ("myfield2", (VarFieldValue (length s))) - , ("field4", (VarFieldValue 2345)) + , ("field4", (VarFieldValue (2345 :: Int))) , ("field5", (VarFieldValue (2345 :: Double))) -- important! test no-debug-view type inside of debug-view instance. this used to crash: , ("field3", (VarFieldValue (Y (show (length "inner Y"))))) diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index d7cfd5e..66c9d7e 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -640,8 +640,8 @@ describe("Debug Adapter Tests", function () { extraGhcArgs: [] }) - const expected = { path: config.projectRoot + "/" + config.entryFile, line: 29 } - await dc.hitBreakpoint(config, { path: config.entryFile, line: 29 }, expected, expected); + const expected = { path: config.projectRoot + "/" + config.entryFile, line: 26 } + await dc.hitBreakpoint(config, { path: config.entryFile, line: 26 }, expected, expected); let locals = await fetchLocalVars(); const tVar = await forceLazy(locals.get('action')); From 37fa2ffd0ad66772ad764e3dc0d8c616b20e4569 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 12 Nov 2025 15:27:39 +0000 Subject: [PATCH 21/40] fix: Qualify the unit-id of the GHC.Debugger.View.Class import --- haskell-debugger.cabal | 1 + .../GHC/Debugger/Interface/Messages.hs | 2 -- haskell-debugger/GHC/Debugger/Monad.hs | 21 ++++++++++++++----- haskell-debugger/GHC/Debugger/Session.hs | 3 --- 4 files changed, 17 insertions(+), 10 deletions(-) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index b748a7c..d88f692 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -72,6 +72,7 @@ library build-depends: base > 4.21 && < 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, diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs index cb99d2e..766d15a 100644 --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -10,8 +10,6 @@ module GHC.Debugger.Interface.Messages where import qualified GHC import qualified GHC.Utils.Outputable as GHC -import GHC.Unit.Types -import Language.Haskell.Syntax.Module.Name -------------------------------------------------------------------------------- -- Commands diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 17b3d73..4c783a8 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -25,9 +25,8 @@ import qualified Data.IntMap as IM import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty -import GHC.Utils.Trace - import GHC +import GHC.Data.FastString import GHC.Driver.DynFlags as GHC import GHC.Driver.Env import GHC.Driver.Errors.Types @@ -38,13 +37,16 @@ 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.Unit.Types import GHC.Utils.Logger as GHC import GHC.Utils.Outputable as GHC +import qualified GHC.LanguageExtensions as LangExt import GHC.Debugger.Interface.Messages import GHC.Debugger.Runtime.Term.Cache @@ -158,7 +160,8 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb , 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 @@ -247,12 +250,20 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb 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 dbgViewImp uid = (mkModule (RealUnit (Definite uid)) debuggerViewClassModName) + let dbgViewImp uid = GHC.IIDecl + (GHC.simpleImportDecl debuggerViewClassModName) + { ideclPkgQual = RawPkgQual + StringLiteral + { sl_st = NoSourceText + , sl_fs = mkFastString (unitIdString uid) + , sl_tc = Nothing + } + } mss <- getAllLoadedModules GHC.setContext (preludeImp : - (case hdv_uid of Just uid -> [GHC.IIModule $ dbgViewImp uid]; _ -> []) ++ + (case hdv_uid of Just uid -> [dbgViewImp uid]; _ -> []) ++ map (GHC.IIModule . GHC.ms_mod) mss) runReaderT action =<< initialDebuggerState hdv_uid diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index f7e06c1..ef7c56e 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -53,9 +53,6 @@ import qualified GHC.Unit.State as State import GHC.Driver.Env import GHC.Types.SrcLoc import Language.Haskell.Syntax.Module.Name -import GHC.Utils.Trace -import GHC.Utils.Outputable (ppr, ($$)) -import GHC.Data.FastString import qualified Data.Foldable as Foldable import qualified GHC.Unit.Home.Graph as HUG import Data.Maybe From 17db6a206f783f91ce1fcb0b302aa9a176b978f7 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 12 Nov 2025 15:36:53 +0000 Subject: [PATCH 22/40] fix: Use IIModule when the module is in in-memory home unit Otherwise the built-in class being loaded doesn't work. All tests now pass again at this point --- haskell-debugger/GHC/Debugger/Monad.hs | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 4c783a8..8a3b67e 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -250,15 +250,22 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb 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 dbgViewImp uid = GHC.IIDecl - (GHC.simpleImportDecl debuggerViewClassModName) - { ideclPkgQual = RawPkgQual - StringLiteral - { sl_st = NoSourceText - , sl_fs = mkFastString (unitIdString uid) - , sl_tc = Nothing - } - } + let dbgViewImp uid + -- Using in-memory hs-dbg-view. + -- It's a home-unit, so refer to it directly + | uid == hsDebuggerViewInMemoryUnitId + = GHC.IIModule (mkModule (RealUnit (Definite uid)) debuggerViewClassModName) + -- It's available in a unit in the transitive closure. + -- Resolve it. + | otherwise + = GHC.IIDecl (GHC.simpleImportDecl debuggerViewClassModName) + { ideclPkgQual = RawPkgQual + StringLiteral + { sl_st = NoSourceText + , sl_fs = mkFastString (unitIdString uid) + , sl_tc = Nothing + } + } mss <- getAllLoadedModules GHC.setContext From c406372649d6ccfe7f79b4fb8fda96a259793008 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 12 Nov 2025 17:16:06 +0000 Subject: [PATCH 23/40] hs-dbg-view: Guard all dependencies behind flags --- .../haskell-debugger-view.cabal | 36 +++++++++++++++---- 1 file changed, 29 insertions(+), 7 deletions(-) diff --git a/haskell-debugger-view/haskell-debugger-view.cabal b/haskell-debugger-view/haskell-debugger-view.cabal index d354186..b6f1cf7 100644 --- a/haskell-debugger-view/haskell-debugger-view.cabal +++ b/haskell-debugger-view/haskell-debugger-view.cabal @@ -10,18 +10,40 @@ extra-doc-files: CHANGELOG.md common warnings ghc-options: -Wall +flag containers + description: Depend and provide custom views for containers + manual: True + default: True + +flag text + description: Depend and provide custom views for text + manual: True + default: True + +flag bytestring + description: Depend and provide custom views for bytestring + manual: True + default: True + library import: warnings -- If you add a module here make sure to also add this module to the list -- of modules that we attempt to load when haskell-debug-view is not -- dependend upon transitively, in GHC.Debugger.Runtime.... exposed-modules: GHC.Debugger.View.Class - GHC.Debugger.View.Containers - GHC.Debugger.View.Text - GHC.Debugger.View.ByteString - build-depends: base, - containers >= 0.7 && < 0.9, - text >= 2.1 && < 2.3, - bytestring >= 0.12.1 && < 0.13, + if flag(containers) + exposed-modules: GHC.Debugger.View.Containers + build-depends: containers >= 0.7 && < 0.9, + cpp-options: -DHASKELL_DEBUGGER_VIEW_CONTAINERS + if flag(text) + exposed-modules: GHC.Debugger.View.Text + build-depends: text >= 2.1 && < 2.3, + cpp-options: -DHASKELL_DEBUGGER_VIEW_TEXT + if flag(bytestring) + exposed-modules: GHC.Debugger.View.ByteString + build-depends: bytestring >= 0.12.1 && < 0.13, + cpp-options: -DHASKELL_DEBUGGER_VIEW_BYTESTRING + + build-depends: base hs-source-dirs: src default-language: GHC2021 From cb09d770a3127907e905d4cc56a1961f945b3f6a Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 12 Nov 2025 17:16:10 +0000 Subject: [PATCH 24/40] Revert "hs-dbg-view: Guard all dependencies behind flags" This reverts commit c406372649d6ccfe7f79b4fb8fda96a259793008. In the future, we may want to guard all dependencies behind cabal flags that the user can tweak when depending on @haskell-debugger-view@. However, it seems that currently, hie-bios ignores the cabal flags given in the cabal.project. Therefore, it's hard to test so we'll postpone this a bit. --- .../haskell-debugger-view.cabal | 36 ++++--------------- 1 file changed, 7 insertions(+), 29 deletions(-) diff --git a/haskell-debugger-view/haskell-debugger-view.cabal b/haskell-debugger-view/haskell-debugger-view.cabal index b6f1cf7..d354186 100644 --- a/haskell-debugger-view/haskell-debugger-view.cabal +++ b/haskell-debugger-view/haskell-debugger-view.cabal @@ -10,40 +10,18 @@ extra-doc-files: CHANGELOG.md common warnings ghc-options: -Wall -flag containers - description: Depend and provide custom views for containers - manual: True - default: True - -flag text - description: Depend and provide custom views for text - manual: True - default: True - -flag bytestring - description: Depend and provide custom views for bytestring - manual: True - default: True - library import: warnings -- If you add a module here make sure to also add this module to the list -- of modules that we attempt to load when haskell-debug-view is not -- dependend upon transitively, in GHC.Debugger.Runtime.... exposed-modules: GHC.Debugger.View.Class - if flag(containers) - exposed-modules: GHC.Debugger.View.Containers - build-depends: containers >= 0.7 && < 0.9, - cpp-options: -DHASKELL_DEBUGGER_VIEW_CONTAINERS - if flag(text) - exposed-modules: GHC.Debugger.View.Text - build-depends: text >= 2.1 && < 2.3, - cpp-options: -DHASKELL_DEBUGGER_VIEW_TEXT - if flag(bytestring) - exposed-modules: GHC.Debugger.View.ByteString - build-depends: bytestring >= 0.12.1 && < 0.13, - cpp-options: -DHASKELL_DEBUGGER_VIEW_BYTESTRING - - build-depends: base + GHC.Debugger.View.Containers + GHC.Debugger.View.Text + GHC.Debugger.View.ByteString + build-depends: base, + containers >= 0.7 && < 0.9, + text >= 2.1 && < 2.3, + bytestring >= 0.12.1 && < 0.13, hs-source-dirs: src default-language: GHC2021 From 3aac64f3b2ceda7559620adf17ab4a69539d1551 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 12 Nov 2025 17:46:56 +0000 Subject: [PATCH 25/40] hs-dbg-view: Add support for containers for in-transitive-closure unit Ensures that we load the orphan instances for GHC.Debugger.View.Containers, but not yet for the in-memory case. --- .../haskell-debugger-view.cabal | 2 +- .../src/GHC/Debugger/View/Class.hs | 8 ----- haskell-debugger/GHC/Debugger/Monad.hs | 32 +++++++++++------- .../GHC/Debugger/Session/Builtin.hs | 15 +++++++++ test/integration-tests/data/T47c/Main.hs | 14 ++++++++ test/integration-tests/data/T47c/T47a.cabal | 19 +++++++++++ .../integration-tests/data/T47c/cabal.project | 1 + test/integration-tests/test/adapter.test.ts | 33 ++++++++++++++++++- 8 files changed, 103 insertions(+), 21 deletions(-) create mode 100644 test/integration-tests/data/T47c/Main.hs create mode 100644 test/integration-tests/data/T47c/T47a.cabal create mode 100644 test/integration-tests/data/T47c/cabal.project diff --git a/haskell-debugger-view/haskell-debugger-view.cabal b/haskell-debugger-view/haskell-debugger-view.cabal index d354186..1f2f424 100644 --- a/haskell-debugger-view/haskell-debugger-view.cabal +++ b/haskell-debugger-view/haskell-debugger-view.cabal @@ -14,7 +14,7 @@ library import: warnings -- If you add a module here make sure to also add this module to the list -- of modules that we attempt to load when haskell-debug-view is not - -- dependend upon transitively, in GHC.Debugger.Runtime.... + -- dependend upon transitively, in GHC.Debugger.Session.Builtin exposed-modules: GHC.Debugger.View.Class GHC.Debugger.View.Containers GHC.Debugger.View.Text diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs index 1947a76..7fff52f 100644 --- a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs @@ -1,14 +1,6 @@ {-# LANGUAGE DerivingVia, StandaloneDeriving, ViewPatterns, ImpredicativeTypes #-} module GHC.Debugger.View.Class where --- import qualified Data.ByteString as BS --- --- import qualified Data.Text as T --- import qualified Data.Text.Encoding as T --- --- import qualified Data.IntMap as IM --- import qualified Data.Map as M - -- | The representation of the value for some variable on the debugger data VarValue = VarValue { -- | The value to display inline for this variable diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 8a3b67e..56ba53d 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -207,7 +207,7 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb throwErrors (fmap GhcDriverMessage errs_base) #endif - (hdv_uid, success) <- + (hdv_uid, loadedBuiltinModNames, success) <- findHsDebuggerViewUnitId mod_graph_base >>= \case Nothing -> do -- Not imported by any module: no custom views. Therefore, the builtin @@ -229,19 +229,27 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- Load only up to debugger-view modules load' noIfaceCache (GHC.LoadUpTo [mkModule hsDebuggerViewInMemoryUnitId debuggerViewClassModName]) mkUnknownDiagnostic (Just msg) mod_graph >>= \case - Failed -> (Nothing,) <$> do + Failed -> (Nothing, [],) <$> do -- Failed to load debugger-view modules! Try again without the haskell-debugger-view modules logger <- getLogger liftIO $ logMsg logger MCInfo noSrcSpan $ text "Failed to compile built-in DebugView modules! Ignoring custom debug views." load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base - Succeeded -> (Just hsDebuggerViewInMemoryUnitId,) <$> do + Succeeded -> (Just hsDebuggerViewInMemoryUnitId, [debuggerViewClassModName],) <$> do -- It worked! Now load everything else load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph - Just hdv_uid -> (Just hdv_uid,) <$> - -- haskell-debug-view is in module graph already, so just load it all. - load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base + Just hdv_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 @debuggerViewBuiltinModNames@. + -- In the future, we may want to guard all dependencies behind cabal + -- flags that the user can tweak when depending on + -- @haskell-debugger-view@. + (Just hdv_uid, debuggerViewBuiltinModNames,) <$> + -- haskell-debug-view is in module graph already, so just load it all. + load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base when (GHC.failed success) $ liftIO $ throwM DebuggerFailedToLoad @@ -250,27 +258,29 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb 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 dbgViewImp uid + let dbgViewImps uid -- Using in-memory hs-dbg-view. -- It's a home-unit, so refer to it directly | uid == hsDebuggerViewInMemoryUnitId - = GHC.IIModule (mkModule (RealUnit (Definite uid)) debuggerViewClassModName) + = map (GHC.IIModule . mkModule (RealUnit (Definite uid))) loadedBuiltinModNames -- It's available in a unit in the transitive closure. -- Resolve it. | otherwise - = GHC.IIDecl (GHC.simpleImportDecl debuggerViewClassModName) + = map (\mn -> + GHC.IIDecl (GHC.simpleImportDecl mn) { ideclPkgQual = RawPkgQual StringLiteral { sl_st = NoSourceText , sl_fs = mkFastString (unitIdString uid) , sl_tc = Nothing } - } + }) loadedBuiltinModNames + mss <- getAllLoadedModules GHC.setContext (preludeImp : - (case hdv_uid of Just uid -> [dbgViewImp uid]; _ -> []) ++ + (case hdv_uid of Just uid -> dbgViewImps uid; _ -> []) ++ map (GHC.IIModule . GHC.ms_mod) mss) runReaderT action =<< initialDebuggerState hdv_uid diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs index 7c68b6d..9bbb5a4 100644 --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -14,10 +14,21 @@ import GHC.Data.StringBuffer -- * Built-in Module names -------------------------------------------------------------------------------- +-- | 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. +debuggerViewBuiltinModNames :: [ModuleName] +debuggerViewBuiltinModNames = [debuggerViewClassModName, debuggerViewContainersModName] + -- | GHC.Debugger.View.Class debuggerViewClassModName :: ModuleName debuggerViewClassModName = mkModuleName "GHC.Debugger.View.Class" +-- | GHC.Debugger.View.Containers +debuggerViewContainersModName :: ModuleName +debuggerViewContainersModName = mkModuleName "GHC.Debugger.View.Containers" + -------------------------------------------------------------------------------- -- * In memory haskell-debugger-view -------------------------------------------------------------------------------- @@ -56,3 +67,7 @@ makeInMemoryHsDebuggerViewUnit initialDynFlags = do -- | 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") diff --git a/test/integration-tests/data/T47c/Main.hs b/test/integration-tests/data/T47c/Main.hs new file mode 100644 index 0000000..6e47ffe --- /dev/null +++ b/test/integration-tests/data/T47c/Main.hs @@ -0,0 +1,14 @@ +module Main where +import GHC.Debugger.View.Class +-- Look! I don't have to import the orphan instances! +-- import GHC.Debugger.View.Containers + +import qualified Data.IntMap as IM + +main :: IO () +main = f (IM.fromList [(3,"one"), (2,"two")]) + +f :: Show a => a -> IO () +f action = do + print action + diff --git a/test/integration-tests/data/T47c/T47a.cabal b/test/integration-tests/data/T47c/T47a.cabal new file mode 100644 index 0000000..8ec4db6 --- /dev/null +++ b/test/integration-tests/data/T47c/T47a.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.14 +name: T47a +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable t47a + import: warnings + main-is: Main.hs + build-depends: base, containers + build-depends: haskell-debugger-view + hs-source-dirs: . + default-language: Haskell2010 + diff --git a/test/integration-tests/data/T47c/cabal.project b/test/integration-tests/data/T47c/cabal.project new file mode 100644 index 0000000..9d07da8 --- /dev/null +++ b/test/integration-tests/data/T47c/cabal.project @@ -0,0 +1 @@ +packages: . ./haskell-debugger-view/ diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 66c9d7e..3c4fdf5 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -662,7 +662,7 @@ describe("Debug Adapter Tests", function () { assert.strictEqual(_5Var.value, '2345.0'); }) - it('user-defined custom instance without haskell-debugger-view dependency (issue #47)', async () => { + it('built-in custom instance without haskell-debugger-view dependency (issue #47)', async () => { let config = mkConfig({ projectRoot: "/data/T47b", entryFile: "Main.hs", @@ -686,6 +686,37 @@ describe("Debug Adapter Tests", function () { const _3Var = await _1Child.get('snd'); assert.strictEqual(_3Var.value, '3456.0'); }) + + it('hdv dependency with containers module (issue #47)', async () => { + let config = mkConfig({ + projectRoot: "/data/T47c", + entryFile: "Main.hs", + entryPoint: "main", + entryArgs: [], + extraGhcArgs: [] + }) + + const expected = { path: config.projectRoot + "/" + config.entryFile, line: 13 } + await dc.hitBreakpoint(config, { path: config.entryFile, line: 13 }, expected, expected); + + // Check IntMap custom view + let locals = await fetchLocalVars(); + const tVar = await forceLazy(locals.get('action')); + assert.strictEqual(tVar.value, "IntMap") + const tChild = await expandVar(tVar); + const _1Var = await forceLazy(tChild.get('3')); + assert.strictEqual(_1Var.value, '"one"'); + const _2Var = await forceLazy(tChild.get('2')); + assert.strictEqual(_2Var.value, '"two"'); + }) + + // it('hdv in-memory with containers module (issue #47)', async () => { + // ... + // }) + // + // it('hdv in-memory without containers module (issue #47)', async () => { + // ... + // }) }) describe("Stepping out (step-out)", function () { From ab31319d7010c1a39d1bbf2c14a6d07fcdd448ac Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 13 Nov 2025 17:09:02 +0000 Subject: [PATCH 26/40] hs-dbg-view: Add initial support for other mods for in-memory unit Makes the debugger try to load all additional modules which provide orphan instances, even when the haskell-debugger-view package is not part of the transitive closure. We try to load every extra module independently, ignoring if it doesn't compile. --- haskell-debugger/GHC/Debugger/Monad.hs | 178 +++++++++++------- .../GHC/Debugger/Session/Builtin.hs | 85 +++++++-- 2 files changed, 179 insertions(+), 84 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 56ba53d..33ba945 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -11,6 +11,7 @@ module GHC.Debugger.Monad where +import Control.Concurrent import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class @@ -27,6 +28,7 @@ import qualified Data.List.NonEmpty as NonEmpty import GHC import GHC.Data.FastString +import GHC.Data.StringBuffer import GHC.Driver.DynFlags as GHC import GHC.Driver.Env import GHC.Driver.Errors.Types @@ -46,6 +48,7 @@ import GHC.Unit.Module.ModSummary as GHC import GHC.Unit.Types import GHC.Utils.Logger as GHC import GHC.Utils.Outputable as GHC +import GHC.Utils.Trace import qualified GHC.LanguageExtensions as LangExt import GHC.Debugger.Interface.Messages @@ -190,67 +193,57 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- Setup base HomeUnitGraph setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) -#if MIN_VERSION_ghc(9,15,0) - msg <- batchMultiMsg <$> getSession -#else - let msg = batchMultiMsg -#endif + if_cache <- Just <$> liftIO newIfaceCache - -- Get mod_graph for base HUG - (errs_base, mod_graph_base) <- depanalE mkUnknownDiagnostic (Just msg) [] False + -- Downsweep user-given modules first + mod_graph_base <- doDownsweep Nothing - when (not $ isEmptyMessages errs_base) $ do -#if MIN_VERSION_ghc(9,15,0) - sec <- initSourceErrorContext . hsc_dflags <$> getSession - throwErrors sec (fmap GhcDriverMessage errs_base) -#else - throwErrors (fmap GhcDriverMessage errs_base) -#endif + -- Try to find or load the built-in classes from `haskell-debugger-view` + (hdv_uid, loadedBuiltinModNames) <- findHsDebuggerViewUnitId mod_graph_base >>= \case + Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do - (hdv_uid, loadedBuiltinModNames, success) <- - findHsDebuggerViewUnitId mod_graph_base >>= \case - Nothing -> do - -- 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. - - -- Add in-memory haskell-debugger-view unit - in_mem_hdv <- liftIO . makeInMemoryHsDebuggerViewUnit =<< getDynFlags - -- Try again, with custom modules loaded - setupHomeUnitGraph (NonEmpty.toList flagsAndTargets ++ [in_mem_hdv]) - (errs, mod_graph) <- depanalE mkUnknownDiagnostic (Just msg) [] False - when (not $ isEmptyMessages errs) $ do -#if MIN_VERSION_ghc(9,15,0) - sec <- initSourceErrorContext . hsc_dflags <$> getSession - throwErrors sec (fmap GhcDriverMessage errs) -#else - throwErrors (fmap GhcDriverMessage errs) -#endif + -- 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. - -- Load only up to debugger-view modules - load' noIfaceCache (GHC.LoadUpTo [mkModule hsDebuggerViewInMemoryUnitId debuggerViewClassModName]) - mkUnknownDiagnostic (Just msg) mod_graph >>= \case - Failed -> (Nothing, [],) <$> do - -- Failed to load debugger-view modules! Try again without the haskell-debugger-view modules + -- Add the custom unit to the HUG + addInMemoryHsDebuggerViewUnit =<< getDynFlags + + tryLoadHsDebuggerViewModule if_cache (const False) debuggerViewClassModName debuggerViewClassContents + >>= \case + Failed -> do + -- Failed to load base debugger-view module! logger <- getLogger liftIO $ logMsg logger MCInfo noSrcSpan $ - text "Failed to compile built-in DebugView modules! Ignoring custom debug views." - load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base - Succeeded -> (Just hsDebuggerViewInMemoryUnitId, [debuggerViewClassModName],) <$> do - -- It worked! Now load everything else - load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph - - Just hdv_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 @debuggerViewBuiltinModNames@. - -- In the future, we may want to guard all dependencies behind cabal - -- flags that the user can tweak when depending on - -- @haskell-debugger-view@. - (Just hdv_uid, debuggerViewBuiltinModNames,) <$> - -- haskell-debug-view is in module graph already, so just load it all. - load' noIfaceCache GHC.LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph_base - + text "Failed to compile built-in DebugView class module! Ignoring custom debug views." + return [] + Succeeded -> (debuggerViewClassModName:) . concat <$> do + forM debuggerViewInstancesMods $ \(modName, modContent) -> do + tryLoadHsDebuggerViewModule if_cache + ((== hsDebuggerViewInMemoryUnitId) . GHC.targetUnitId) + modName modContent >>= \case + Failed -> do + logger <- getLogger + liftIO $ logMsg logger MCInfo noSrcSpan $ + text "Failed to compile built-in DebugView instances for" + <+> ppr modName + GHC.<> text "! Ignoring this module's instances." + return [] + Succeeded -> do + return [modName] + + 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) + success <- doLoad if_cache GHC.LoadAllTargets final_mod_graph when (GHC.failed success) $ liftIO $ throwM DebuggerFailedToLoad @@ -258,20 +251,18 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb 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 uid - -- Using in-memory hs-dbg-view. - -- It's a home-unit, so refer to it directly - | uid == hsDebuggerViewInMemoryUnitId - = map (GHC.IIModule . mkModule (RealUnit (Definite uid))) loadedBuiltinModNames - -- It's available in a unit in the transitive closure. - -- Resolve it. + 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 uid) + , sl_fs = mkFastString (unitIdString hdv_uid) , sl_tc = Nothing } }) loadedBuiltinModNames @@ -280,10 +271,10 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb GHC.setContext (preludeImp : - (case hdv_uid of Just uid -> dbgViewImps uid; _ -> []) ++ + dbgViewImps ++ map (GHC.IIModule . GHC.ms_mod) mss) - runReaderT action =<< initialDebuggerState hdv_uid + runReaderT action =<< initialDebuggerState (if loadedBuiltinModNames == [] then Nothing else Just hdv_uid) -- | The logger action used to log GHC output debuggerLoggerAction :: Handle -> LogAction @@ -291,6 +282,63 @@ debuggerLoggerAction h a b c d = do hSetEncoding h utf8 -- GHC output uses utf8 defaultLogActionWithHandles h h a b c d +-- | 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 + +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 + +-- | Returns @Just modName@ if the given module was successfully loaded +tryLoadHsDebuggerViewModule + :: GhcMonad m => 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 if_cache keepTarget modName modContents = do + -- Store existing targets to restore afterwards + -- We want to use as little targets as possible to keep downsweep minimal+fast + old_targets <- GHC.getTargets + + -- 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 + + -- And try to load it + result <- doLoad if_cache (GHC.LoadUpTo [mkModule hsDebuggerViewInMemoryUnitId modName]) dvc_mod_graph + + -- Restore targets plus new one if success + GHC.setTargets (old_targets ++ (if succeeded result then [dvcT] else [])) + return result + -------------------------------------------------------------------------------- -- * Finding Debugger View -------------------------------------------------------------------------------- diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs index 9bbb5a4..5473d50 100644 --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -1,25 +1,53 @@ {-# LANGUAGE TemplateHaskell #-} -- | Built-in units and modules -module GHC.Debugger.Session.Builtin where +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.Time import Data.FileEmbed +import Data.Function +import Data.Maybe +import Data.Time import GHC import GHC.Unit +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 GHC.Debugger.Session -------------------------------------------------------------------------------- --- * Built-in Module names +-- * 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. -debuggerViewBuiltinModNames :: [ModuleName] -debuggerViewBuiltinModNames = [debuggerViewClassModName, debuggerViewContainersModName] +debuggerViewBuiltinMods :: [(ModuleName, StringBuffer)] +debuggerViewBuiltinMods = (debuggerViewClassModName, debuggerViewClassContents):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)] +debuggerViewInstancesMods = [(debuggerViewContainersModName, debuggerViewContainersContents)] -- | GHC.Debugger.View.Class debuggerViewClassModName :: ModuleName @@ -38,15 +66,38 @@ hsDebuggerViewInMemoryUnitId :: UnitId hsDebuggerViewInMemoryUnitId = toUnitId $ stringToUnit "haskell-debugger-view-in-memory" -- | Create a unit @haskell-debugger-view@ which uses in-memory files for the modules -makeInMemoryHsDebuggerViewUnit - :: DynFlags -- ^ Initial dynflags - -> IO (DynFlags, [GHC.Target]) -- ^ The dynflags and targets of the unit -makeInMemoryHsDebuggerViewUnit initialDynFlags = do - let hdvDynFlags = initialDynFlags - { homeUnitId_ = hsDebuggerViewInMemoryUnitId - , importPaths = [] - , packageFlags = [] - } +-- and add it to the HUG +addInMemoryHsDebuggerViewUnit + :: GhcMonad m + => DynFlags -- ^ Initial dynflags + -> m () +addInMemoryHsDebuggerViewUnit initialDynFlags = do + let imhdv_dflags = initialDynFlags + { homeUnitId_ = hsDebuggerViewInMemoryUnitId + , importPaths = [] + , packageFlags = [] + } + emptyHpt <- liftIO HPT.emptyHomePackageTable + modifySession $ \env -> + env + -- Inserts the in-memory hdv unit + & hscUpdateHUG (\hug -> + let idebugger_hue = + fromJust $ HUG.unitEnv_lookup_maybe interactiveGhcDebuggerUnitId hug + hdv_hue = HUG.HomeUnitEnv + { HUG.homeUnitEnv_units = HUG.homeUnitEnv_units idebugger_hue + , HUG.homeUnitEnv_unit_dbs = Nothing + , HUG.homeUnitEnv_dflags = imhdv_dflags + , HUG.homeUnitEnv_hpt = emptyHpt + , HUG.homeUnitEnv_home_unit = Just (DefiniteHomeUnit hsDebuggerViewInMemoryUnitId Nothing) + } + 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 @@ -54,11 +105,7 @@ makeInMemoryHsDebuggerViewUnit initialDynFlags = do , GHC.targetUnitId = hsDebuggerViewInMemoryUnitId , GHC.targetContents = Just (contents, time) } - return - ( hdvDynFlags - , [ mkTarget debuggerViewClassModName debuggerViewClassContents - ] - ) + return $ mkTarget modName sb -------------------------------------------------------------------------------- -- * In memory module contents From 8903b1c0c0981fc189127c1396dfa21664a7913d Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 13 Nov 2025 17:43:02 +0000 Subject: [PATCH 27/40] magic: by Matthew Pickering And now it works both when containers is and isn't available. --- haskell-debugger/GHC/Debugger/Monad.hs | 5 ++- .../GHC/Debugger/Session/Builtin.hs | 33 +++++++++++++------ 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 33ba945..efdc319 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -206,7 +206,8 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- ones haven't been loaded. In this case, we will load the package ourselves. -- Add the custom unit to the HUG - addInMemoryHsDebuggerViewUnit =<< getDynFlags + let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base] + addInMemoryHsDebuggerViewUnit base_dep_uids =<< getDynFlags tryLoadHsDebuggerViewModule if_cache (const False) debuggerViewClassModName debuggerViewClassContents >>= \case @@ -217,6 +218,8 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb text "Failed to compile built-in DebugView class module! Ignoring custom debug views." return [] Succeeded -> (debuggerViewClassModName:) . concat <$> do + -- TODO: We could be a bit smarter and filter out if there isn't + -- a -package flag for the package we need for each module. forM debuggerViewInstancesMods $ \(modName, modContent) -> do tryLoadHsDebuggerViewModule if_cache ((== hsDebuggerViewInMemoryUnitId) . GHC.targetUnitId) diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs index 5473d50..df54b6d 100644 --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -25,11 +25,13 @@ 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 import GHC.Debugger.Session @@ -69,27 +71,38 @@ hsDebuggerViewInMemoryUnitId = toUnitId $ stringToUnit "haskell-debugger-view-in -- and add it to the HUG addInMemoryHsDebuggerViewUnit :: GhcMonad m - => DynFlags -- ^ Initial dynflags + => [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 initialDynFlags = do +addInMemoryHsDebuggerViewUnit base_uids initialDynFlags = do let imhdv_dflags = initialDynFlags { homeUnitId_ = hsDebuggerViewInMemoryUnitId , importPaths = [] - , packageFlags = [] + , 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 idebugger_hue = - fromJust $ HUG.unitEnv_lookup_maybe interactiveGhcDebuggerUnitId hug - hdv_hue = HUG.HomeUnitEnv - { HUG.homeUnitEnv_units = HUG.homeUnitEnv_units idebugger_hue - , HUG.homeUnitEnv_unit_dbs = Nothing - , HUG.homeUnitEnv_dflags = imhdv_dflags + 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 (DefiniteHomeUnit hsDebuggerViewInMemoryUnitId Nothing) + , HUG.homeUnitEnv_home_unit = Just home_unit } in HUG.unitEnv_insert hsDebuggerViewInMemoryUnitId hdv_hue hug ) From fb298451b29a5864e3579aa9dfaa8d041f0bd6c4 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 13 Nov 2025 17:56:51 +0000 Subject: [PATCH 28/40] Add test for #47 depends on containers but not on haskell-debugger-view And it still uses the custom display. Plus a few cleanups --- haskell-debugger/GHC/Debugger/Monad.hs | 4 +-- .../GHC/Debugger/Session/Builtin.hs | 7 ++--- test/integration-tests/data/T47d/Main.hs | 12 ++++++++ test/integration-tests/data/T47d/T47d.cabal | 18 ++++++++++++ test/integration-tests/test/adapter.test.ts | 28 ++++++++++++++++--- 5 files changed, 59 insertions(+), 10 deletions(-) create mode 100644 test/integration-tests/data/T47d/Main.hs create mode 100644 test/integration-tests/data/T47d/T47d.cabal diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index efdc319..2845654 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -11,7 +11,6 @@ module GHC.Debugger.Monad where -import Control.Concurrent import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class @@ -48,7 +47,6 @@ import GHC.Unit.Module.ModSummary as GHC import GHC.Unit.Types import GHC.Utils.Logger as GHC import GHC.Utils.Outputable as GHC -import GHC.Utils.Trace import qualified GHC.LanguageExtensions as LangExt import GHC.Debugger.Interface.Messages @@ -222,6 +220,7 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- a -package flag for the package we need for each module. forM debuggerViewInstancesMods $ \(modName, modContent) -> do tryLoadHsDebuggerViewModule if_cache + -- TODO: Better predicate, we only really need to keep the TargetFile "in-memory:"++debuggerViewClassModName ((== hsDebuggerViewInMemoryUnitId) . GHC.targetUnitId) modName modContent >>= \case Failed -> do @@ -306,6 +305,7 @@ doDownsweep reuse_mg = do #endif return mod_graph +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 diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs index df54b6d..874a50d 100644 --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -20,7 +20,6 @@ module GHC.Debugger.Session.Builtin import Data.FileEmbed import Data.Function -import Data.Maybe import Data.Time import GHC @@ -33,8 +32,6 @@ import qualified GHC.Unit.Home.Graph as HUG import qualified GHC.Unit.Home.PackageTable as HPT import qualified GHC.Unit.State as State -import GHC.Debugger.Session - -------------------------------------------------------------------------------- -- * Built-in Modules -------------------------------------------------------------------------------- @@ -49,7 +46,9 @@ debuggerViewBuiltinMods = (debuggerViewClassModName, debuggerViewClassContents): -- | 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)] -debuggerViewInstancesMods = [(debuggerViewContainersModName, debuggerViewContainersContents)] +debuggerViewInstancesMods = + [ (debuggerViewContainersModName, debuggerViewContainersContents) + ] -- | GHC.Debugger.View.Class debuggerViewClassModName :: ModuleName diff --git a/test/integration-tests/data/T47d/Main.hs b/test/integration-tests/data/T47d/Main.hs new file mode 100644 index 0000000..49a6bce --- /dev/null +++ b/test/integration-tests/data/T47d/Main.hs @@ -0,0 +1,12 @@ +module Main where +-- Look! No imports but still custom views for containers! + +import qualified Data.IntMap as IM + +main :: IO () +main = f (IM.fromList [(3,"one"), (2,"two")]) + +f :: Show a => a -> IO () +f action = do + print action + diff --git a/test/integration-tests/data/T47d/T47d.cabal b/test/integration-tests/data/T47d/T47d.cabal new file mode 100644 index 0000000..7a9f2e4 --- /dev/null +++ b/test/integration-tests/data/T47d/T47d.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: T47d +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple +extra-doc-files: CHANGELOG.md + +common warnings + ghc-options: -Wall + +executable T47d + import: warnings + main-is: Main.hs + build-depends: base, containers + hs-source-dirs: . + default-language: Haskell2010 diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 3c4fdf5..c1d7775 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -710,10 +710,30 @@ describe("Debug Adapter Tests", function () { assert.strictEqual(_2Var.value, '"two"'); }) - // it('hdv in-memory with containers module (issue #47)', async () => { - // ... - // }) - // + it('hdv in-memory with containers module (issue #47)', async () => { + let config = mkConfig({ + projectRoot: "/data/T47d", + entryFile: "Main.hs", + entryPoint: "main", + entryArgs: [], + extraGhcArgs: [] + }) + + const expected = { path: config.projectRoot + "/" + config.entryFile, line: 11 } + await dc.hitBreakpoint(config, { path: config.entryFile, line: 11 }, expected, expected); + + // Check IntMap custom view + let locals = await fetchLocalVars(); + const tVar = await forceLazy(locals.get('action')); + assert.strictEqual(tVar.value, "IntMap") + const tChild = await expandVar(tVar); + const _1Var = await forceLazy(tChild.get('3')); + assert.strictEqual(_1Var.value, '"one"'); + const _2Var = await forceLazy(tChild.get('2')); + assert.strictEqual(_2Var.value, '"two"'); + }) + + // Not needed! Tested in multiple places that this still works. // it('hdv in-memory without containers module (issue #47)', async () => { // ... // }) From a1d20e29358f651e4c5c2f669d44518b8de787c3 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 13 Nov 2025 18:13:04 +0000 Subject: [PATCH 29/40] feat: Add remaining custom views for Text and ByteString Plus a few cleanups and improvements. And fix the testsuite existing output. And a new test for `text` --- haskell-debugger/GHC/Debugger/Monad.hs | 7 ++- .../GHC/Debugger/Session/Builtin.hs | 27 +++++++++- test/integration-tests/data/T47e/Main.hs | 12 +++++ test/integration-tests/data/T47e/T47d.cabal | 18 +++++++ test/integration-tests/test/adapter.test.ts | 54 +++++++++++-------- 5 files changed, 92 insertions(+), 26 deletions(-) create mode 100644 test/integration-tests/data/T47e/Main.hs create mode 100644 test/integration-tests/data/T47e/T47d.cabal diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 2845654..951582a 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -220,8 +220,11 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb -- a -package flag for the package we need for each module. forM debuggerViewInstancesMods $ \(modName, modContent) -> do tryLoadHsDebuggerViewModule if_cache - -- TODO: Better predicate, we only really need to keep the TargetFile "in-memory:"++debuggerViewClassModName - ((== hsDebuggerViewInMemoryUnitId) . GHC.targetUnitId) + ((\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 logger <- getLogger diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs index 874a50d..ad7e11c 100644 --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -47,7 +47,15 @@ debuggerViewBuiltinMods = (debuggerViewClassModName, debuggerViewClassContents): -- We will try to load each of these modules separately. debuggerViewInstancesMods :: [(ModuleName, StringBuffer)] debuggerViewInstancesMods = - [ (debuggerViewContainersModName, debuggerViewContainersContents) + [ ( debuggerViewContainersModName + , debuggerViewContainersContents + ) + , ( debuggerViewTextModName + , debuggerViewTextContents + ) + , ( debuggerViewByteStringModName + , debuggerViewByteStringContents + ) ] -- | GHC.Debugger.View.Class @@ -58,6 +66,14 @@ debuggerViewClassModName = mkModuleName "GHC.Debugger.View.Class" 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 -------------------------------------------------------------------------------- @@ -130,3 +146,12 @@ debuggerViewClassContents = stringToStringBuffer $(embedStringFile "haskell-debu -- | 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") + diff --git a/test/integration-tests/data/T47e/Main.hs b/test/integration-tests/data/T47e/Main.hs new file mode 100644 index 0000000..2979b3d --- /dev/null +++ b/test/integration-tests/data/T47e/Main.hs @@ -0,0 +1,12 @@ +module Main where +-- Look! No imports but still custom views for text! + +import qualified Data.Text as T + +main :: IO () +main = f (T.pack "this should be displayed as a simple string") + +f :: Show a => a -> IO () +f action = do + print action + diff --git a/test/integration-tests/data/T47e/T47d.cabal b/test/integration-tests/data/T47e/T47d.cabal new file mode 100644 index 0000000..d15fa6f --- /dev/null +++ b/test/integration-tests/data/T47e/T47d.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: T47d +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple +extra-doc-files: CHANGELOG.md + +common warnings + ghc-options: -Wall + +executable T47d + import: warnings + main-is: Main.hs + build-depends: base, text + hs-source-dirs: . + default-language: Haskell2010 diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index c1d7775..84488cd 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -737,6 +737,24 @@ describe("Debug Adapter Tests", function () { // it('hdv in-memory without containers module (issue #47)', async () => { // ... // }) + + it('hdv in-memory with text module (issue #47)', async () => { + let config = mkConfig({ + projectRoot: "/data/T47e", + entryFile: "Main.hs", + entryPoint: "main", + entryArgs: [], + extraGhcArgs: [] + }) + + const expected = { path: config.projectRoot + "/" + config.entryFile, line: 11 } + await dc.hitBreakpoint(config, { path: config.entryFile, line: 11 }, expected, expected); + + // Check IntMap custom view + let locals = await fetchLocalVars(); + const tVar = await forceLazy(locals.get('action')); + assert.strictEqual(tVar.value, "\"this should be displayed as a simple string\"") + }) }) describe("Stepping out (step-out)", function () { @@ -890,16 +908,12 @@ describe("Debug Adapter Tests", function () { const variables = await fetchLocalVars() const imVar = variables.get('im'); - assert.strictEqual(imVar.value, 'Bin'); + assert.strictEqual(imVar.value, 'IntMap'); const imChild = await expandVar(imVar); - const _2Var = await imChild.get("_2"); - const _3Var = await imChild.get("_3"); - const _2Child = await expandVar(_2Var) - const _3Child = await expandVar(_3Var) - const _2_2Var = await _2Child.get("_2") - const _3_2Var = await _3Child.get("_2") - assert.strictEqual(_2_2Var.value, '2'); - assert.strictEqual(_3_2Var.value, '4'); + const _2Var = await imChild.get("0"); + const _3Var = await imChild.get("2"); + assert.strictEqual(_2Var.value, '2'); + assert.strictEqual(_3Var.value, '4'); // And doesn't stop again await dc.continueRequest({threadId: 0, singleThread: false}); @@ -944,16 +958,12 @@ describe("Debug Adapter Tests", function () { const variables = await fetchLocalVars() const imVar = await forceLazy(variables.get('im')); - assert.strictEqual(imVar.value, 'Bin'); + assert.strictEqual(imVar.value, 'IntMap'); const imChild = await expandVar(imVar); - const _2Var = await imChild.get("_2"); - const _3Var = await imChild.get("_3"); - const _2Child = await expandVar(_2Var) - const _3Child = await expandVar(_3Var) - const _2_2Var = await _2Child.get("_2") - const _3_2Var = await _3Child.get("_2") - assert.strictEqual(_2_2Var.value, '2'); - assert.strictEqual(_3_2Var.value, '4'); + const _2Var = await imChild.get("0"); + const _3Var = await imChild.get("2"); + assert.strictEqual(_2Var.value, '2'); + assert.strictEqual(_3Var.value, '4'); // Unlike conditional expression, we hit the breakpoint every time // after the ignore count, so run this twice @@ -984,12 +994,10 @@ describe("Debug Adapter Tests", function () { let resp = await dc.evaluateRequest({expression: "IM.delete 0 (IM.insert 0 'a' (IM.insert 1 'b' IM.empty))"} ) - assert.strictEqual(resp.body.result, 'Tip'); + assert.strictEqual(resp.body.result, 'IntMap'); const respChild = await expandVar({...resp.body, name: resp.body.result}) - const _1Var = await respChild.get("_1") - const _2Var = await respChild.get("_2") - assert.strictEqual(_1Var.value, '1'); - assert.strictEqual(_2Var.value, '\'b\''); + const _1Var = await respChild.get("1") + assert.strictEqual(_1Var.value, '\'b\''); }) }) }) From 8348ff7d925383b148d28daf8937b3c9fa70f4c3 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 13 Nov 2025 18:33:14 +0000 Subject: [PATCH 30/40] ci: Package and use haskell-debugger-view --- .github/workflows/debugger.yaml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/.github/workflows/debugger.yaml b/.github/workflows/debugger.yaml index 4b7e523..f0599f3 100644 --- a/.github/workflows/debugger.yaml +++ b/.github/workflows/debugger.yaml @@ -5,6 +5,10 @@ on: pull_request: {} workflow_call: {} +env: + haskellDebuggerViewVersion: 0.1.0.0 + haskellDebuggerVersion: 0.10.0.0 + name: Debugger CI jobs: build-vscode-extension: @@ -42,10 +46,14 @@ jobs: - name: Package hdb run: cabal sdist + - name: Package haskell-debugger-view + run: cabal sdist haskell-debugger-view + - name: Upload haskell-debugger source distribution uses: actions/upload-artifact@v4 with: name: Haskell Debugger Source Distribution + # This will catch both haskell-debugger and haskell-debugger-view path: dist-newstyle/sdist/haskell-debugger*.tar.gz # Building and testing are done on the distributed sdist: not on the full git repo. @@ -95,8 +103,10 @@ jobs: - name: Build and Run integration tests run: | echo "Running DAP Integration Testsuite now..." - (cd ${{ runner.temp }}/dist && tar xzf *.tar.gz && rm *.tar.gz && cd haskell-debugger-* && cabal build exe:hdb --enable-executable-dynamic --allow-newer=ghc-bignum,containers,time,ghc,base,template-haskell) - export DEBUGGER=$(cd ${{ runner.temp }}/dist/haskell-debugger-* && cabal list-bin exe:hdb --enable-executable-dynamic --allow-newer=ghc-bignum,containers,time,ghc,base,template-haskell) + (cd ${{ runner.temp }}/dist && for f in *.tar.gz; do tar xzf "$f"; done) + (cd ${{ runner.temp }}/dist && cd haskell-debugger-${{env.haskellDebuggerVersion}} && echo 'packages: . ../haskell-debugger-view-${{env.haskellDebuggerViewVersion}}' > cabal.project) + (cd ${{ runner.temp }}/dist && cd haskell-debugger-${{env.haskellDebuggerVersion}} && cabal build exe:hdb --enable-executable-dynamic --allow-newer=ghc-bignum,containers,time,ghc,base,template-haskell) + export DEBUGGER=$(cd ${{ runner.temp }}/dist/haskell-debugger-${{env.haskellDebuggerVersion}} && cabal list-bin exe:hdb --enable-executable-dynamic --allow-newer=ghc-bignum,containers,time,ghc,base,template-haskell) echo "DEBUGGER: $DEBUGGER" cd test/integration-tests/ make clean From d3d8471cedec9de15ebd2975b710475d70699a76 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 14 Nov 2025 16:20:32 +0000 Subject: [PATCH 31/40] Add haskell-debugger-view modules to extra-source-files This ensures that `cabal sdist` includes all files necessary for compilation in the tarball. Otherwise, these files try to be included by TH but wouldn't be available. --- haskell-debugger.cabal | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index d88f692..a87ccf9 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -31,6 +31,13 @@ category: Development 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 From bc308056bc92878ffa4b74acc61912aede7b9856 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 14 Nov 2025 16:50:39 +0000 Subject: [PATCH 32/40] cleanup: Use structured logging instead of GHC's logger This ensures we ignore certain logs according to the verbosity given by the user --- haskell-debugger/GHC/Debugger.hs | 1 + haskell-debugger/GHC/Debugger/Breakpoint.hs | 12 ++-- haskell-debugger/GHC/Debugger/Evaluation.hs | 8 +-- haskell-debugger/GHC/Debugger/Monad.hs | 66 ++++++++++++------- .../GHC/Debugger/Runtime/Instances.hs | 10 ++- hdb/Development/Debug/Adapter/Init.hs | 3 +- hdb/Development/Debug/Interactive.hs | 4 +- 7 files changed, 62 insertions(+), 42 deletions(-) diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs index e869d90..000e08a 100644 --- a/haskell-debugger/GHC/Debugger.hs +++ b/haskell-debugger/GHC/Debugger.hs @@ -45,3 +45,4 @@ data DebuggerLog instance Pretty DebuggerLog where pretty = \ case EvalLog msg -> pretty msg + diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs index f3585a1..d8e48b6 100644 --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -28,6 +28,7 @@ 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 @@ -57,7 +58,7 @@ getBreakpointsAt ModuleBreak{path, lineNum, columnNum} = do mmodl <- getModuleByPath path case mmodl of Left e -> do - displayWarnings [e] + logSDoc Logger.Warning e return Nothing Right modl -> do mbfnd <- findBreakpoint modl lineNum columnNum @@ -67,13 +68,14 @@ getBreakpointsAt _ = error "unexpected getbreakpoints without ModuleBreak" -- | Set a breakpoint in this session setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound setBreakpoint bp BreakpointAfterCountCond{} = do - displayWarnings [text $ "Setting a hit count condition on a conditional breakpoint is not yet supported. Ignoring breakpoint " ++ show bp] + 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 findBreakpoint modl lineNum columnNum >>= \case @@ -189,7 +191,7 @@ getActiveBreakpoints mfile = do -- assert: status is always > disabled ] Left e -> do - displayWarnings [e] + logSDoc Logger.Warning e return [] Nothing -> do return @@ -231,7 +233,7 @@ condBreakEnableStatus hitCount condition = do (Just i, Just c) -> BreakpointAfterCountCond i c -- | Get a 'ModSummary' of a loaded module given its 'FilePath' -getModuleByPath :: FilePath -> Debugger (Either Warning ModSummary) +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 diff --git a/haskell-debugger/GHC/Debugger/Evaluation.hs b/haskell-debugger/GHC/Debugger/Evaluation.hs index 900e767..c8b490a 100644 --- a/haskell-debugger/GHC/Debugger/Evaluation.hs +++ b/haskell-debugger/GHC/Debugger/Evaluation.hs @@ -41,7 +41,7 @@ import GHC.Debugger.Stopped.Variables 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 @@ -227,13 +227,13 @@ handleExecResult = \case else resume else do - displayWarnings [evalFailedMsg "\"expression resultType is != Bool\""] + logSDoc Logger.Warning (evalFailedMsg "\"expression resultType is != Bool\"") resume EvalException { resultVal } -> do - displayWarnings [evalFailedMsg resultVal] + logSDoc Logger.Warning (evalFailedMsg resultVal) resume EvalAbortedWith e -> do - displayWarnings [evalFailedMsg e] + logSDoc Logger.Warning (evalFailedMsg e) resume -- Unconditionally 'EvalStopped' in all other cases diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 951582a..ab9820c 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -33,6 +33,7 @@ import GHC.Driver.Env 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 @@ -50,6 +51,7 @@ import GHC.Utils.Outputable as GHC import qualified GHC.LanguageExtensions as LangExt import GHC.Debugger.Interface.Messages +import GHC.Debugger.Logger import GHC.Debugger.Runtime.Term.Cache import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Session @@ -105,6 +107,8 @@ data DebuggerState = DebuggerState -- 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 @@ -138,7 +142,8 @@ data RunDebuggerSettings = RunDebuggerSettings } -- | 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) @@ -148,7 +153,7 @@ runDebugger :: Handle -- ^ The handle to which GHC's output is logged. The d -> 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' mainFp conf (Debugger action) = do let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation' GHC.runGhc (Just libdir) $ do -- Workaround #4162 @@ -211,9 +216,7 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb >>= \case Failed -> do -- Failed to load base debugger-view module! - logger <- getLogger - liftIO $ logMsg logger MCInfo noSrcSpan $ - text "Failed to compile built-in DebugView class module! Ignoring custom debug views." + logWith l Debug $ LogFailedToCompileDebugViewModule debuggerViewClassModName return [] Succeeded -> (debuggerViewClassModName:) . concat <$> do -- TODO: We could be a bit smarter and filter out if there isn't @@ -227,11 +230,7 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb _ -> False) . GHC.targetId) modName modContent >>= \case Failed -> do - logger <- getLogger - liftIO $ logMsg logger MCInfo noSrcSpan $ - text "Failed to compile built-in DebugView instances for" - <+> ppr modName - GHC.<> text "! Ignoring this module's instances." + logWith l Info $ LogFailedToCompileDebugViewModule modName return [] Succeeded -> do return [modName] @@ -279,13 +278,9 @@ runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Deb dbgViewImps ++ map (GHC.IIModule . GHC.ms_mod) mss) - runReaderT action =<< initialDebuggerState (if loadedBuiltinModNames == [] then Nothing else Just hdv_uid) + 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 +-------------------------------------------------------------------------------- -- | Run downsweep on the currently set targets (see @hsc_targets@) doDownsweep :: GhcMonad m @@ -435,13 +430,14 @@ freshInt = do return i -- | Initialize a 'DebuggerState' -initialDebuggerState :: Maybe UnitId -> GHC.Ghc DebuggerState -initialDebuggerState hsDbgViewUid = +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 0) <*> pure hsDbgViewUid + <*> pure l -- | Lift a 'Ghc' action into a 'Debugger' one. liftGhc :: GHC.Ghc a -> Debugger a @@ -454,13 +450,6 @@ instance Show DebuggerFailedToLoad where -------------------------------------------------------------------------------- -type Warning = SDoc - -displayWarnings :: [Warning] -> Debugger () -displayWarnings ws = do - logger <- getLogger - liftIO $ logMsg logger MCInfo noSrcSpan (vcat ws) - -------------------------------------------------------------------------------- -- * Modules -------------------------------------------------------------------------------- @@ -525,3 +514,30 @@ instance GHC.GhcMonad Debugger where getSession = liftGhc GHC.getSession setSession s = liftGhc $ GHC.setSession s +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- + +-- | 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 + | 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." + LogSDoc dflags doc -> + pretty $ showSDoc dflags doc + +logSDoc :: GHC.Debugger.Logger.Severity -> SDoc -> Debugger () +logSDoc sev doc = do + dflags <- getDynFlags + l <- asks dbgLogger + logWith l sev (LogSDoc dflags doc) diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs index 539b08d..61ef7dc 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -27,13 +27,12 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.Type -import GHC.Types.Error -import GHC.Utils.Logger import GHCi.Message import GHC.Debugger.Monad import GHC.Debugger.Session.Builtin import GHC.Debugger.View.Class +import GHC.Debugger.Logger as Logger -------------------------------------------------------------------------------- -- * High level interface for 'DebugView' on 'Term's @@ -180,15 +179,14 @@ data DebugViewInstance = DebugViewInstance findDebugViewInstance :: Type -> Debugger (Maybe DebugViewInstance) findDebugViewInstance needle_ty = do hsc_env <- getSession - logger <- getLogger mhdv_uid <- getHsDebuggerViewUid case mhdv_uid of - Just hdv_uid -> liftIO $ do + Just hdv_uid -> do let modl = mkModule (RealUnit (Definite hdv_uid)) debuggerViewClassModName let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr) - (err_msgs, res) <- runTcInteractive hsc_env $ do + (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ do -- Types used by DebugView varValueIOTy <- fmap mkTyConTy . tcLookupTyCon @@ -239,7 +237,7 @@ findDebugViewInstance needle_ty = do case res of Nothing -> do - liftIO $ logMsg logger MCDump noSrcSpan $ + 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 diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 2f1cf36..a69c883 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -52,6 +52,7 @@ import Development.Debug.Session.Setup data InitLog = DebuggerLog Debugger.DebuggerLog + | DebuggerMonadLog Debugger.DebuggerMonadLog | FlagsLog FlagsLog instance Pretty InitLog where @@ -249,7 +250,7 @@ debuggerThread recorder finished_init writeDebuggerOutput workDir HieBiosFlags{. catches (do - Debugger.runDebugger writeDebuggerOutput rootDir componentDir libdir units finalGhcInvocation mainFp runConf $ do + Debugger.runDebugger (cmapWithSev DebuggerMonadLog recorder) writeDebuggerOutput rootDir componentDir libdir units finalGhcInvocation mainFp runConf $ do liftIO $ signalInitialized (Right ()) forever $ do req <- takeMVar requests & liftIO diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index ef5a468..25ffb20 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -27,6 +27,7 @@ type InteractiveDM a = InputT (RWST (FilePath{-entry file-},String{-entry point- data InteractiveLog = DebuggerLog DebuggerLog + | DebuggerMonadLog DebuggerMonadLog | FlagsLog FlagsLog instance Pretty InteractiveLog where @@ -60,8 +61,9 @@ runIDM logger entryPoint entryFile entryArgs extraGhcArgs act = do 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 finalGhcInvocation absEntryFile defaultRunConf $ fmap fst $ evalRWST (runInputT (setComplete noCompletion defaultSettings) act) (entryFile, entryPoint, entryArgs) Nothing From eab28e8afc075f10db4c4b217dd6b3eb23f2468e Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 14 Nov 2025 17:10:19 +0000 Subject: [PATCH 33/40] Use time Recorder as the GHC logger --- haskell-debugger/GHC/Debugger/Monad.hs | 28 +++++++++++++++++++++++--- hdb/Development/Debug/Adapter/Init.hs | 1 + hdb/Development/Debug/Interactive.hs | 1 + 3 files changed, 27 insertions(+), 3 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index ab9820c..7a3a69e 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -51,7 +51,7 @@ import GHC.Utils.Outputable as GHC import qualified GHC.LanguageExtensions as LangExt import GHC.Debugger.Interface.Messages -import GHC.Debugger.Logger +import GHC.Debugger.Logger as Logger import GHC.Debugger.Runtime.Term.Cache import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Session @@ -178,7 +178,8 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D GHC.modifyLogger $ -- Override the logger to output to the given handle - GHC.pushLogHook (const $ debuggerLoggerAction dbg_out) + GHC.pushLogHook $ const $ {- no longer: debuggerLoggerAction dbg_out -} + logAction l dflags1 -- Set the session dynflags now to initialise the hsc_interp. _ <- GHC.setSessionDynFlags dflags1 @@ -338,6 +339,7 @@ tryLoadHsDebuggerViewModule if_cache keepTarget modName modContents = do -- Restore targets plus new one if success GHC.setTargets (old_targets ++ (if succeeded result then [dvcT] else [])) + return result -------------------------------------------------------------------------------- @@ -536,8 +538,28 @@ instance Pretty DebuggerMonadLog where LogSDoc dflags doc -> pretty $ showSDoc dflags doc -logSDoc :: GHC.Debugger.Logger.Severity -> SDoc -> Debugger () +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 = do + return $ \ 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 diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index a69c883..a44675e 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -58,6 +58,7 @@ data InitLog instance Pretty InitLog where pretty = \ case DebuggerLog msg -> pretty msg + DebuggerMonadLog msg -> pretty msg FlagsLog msg -> pretty msg -------------------------------------------------------------------------------- diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index 25ffb20..6ad97d4 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -34,6 +34,7 @@ instance Pretty InteractiveLog where pretty = \ case DebuggerLog msg -> pretty msg FlagsLog msg -> pretty msg + DebuggerMonadLog msg -> pretty msg -- | Run it runIDM :: Recorder (WithSeverity InteractiveLog) From 0cd0e58e708a1c380c7ac7cdd21c1b1dcee24797 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 14 Nov 2025 17:12:21 +0000 Subject: [PATCH 34/40] revert: Use debuggerLogAction for GHC internal output. It turns out it was too noisy to prefix every GHC log (like [1 of 1] Compiling ...) with time and severity information from the `Recorder`. Let's keep it as was for now. --- haskell-debugger/GHC/Debugger/Monad.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 7a3a69e..7b35d10 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -178,8 +178,7 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D GHC.modifyLogger $ -- Override the logger to output to the given handle - GHC.pushLogHook $ const $ {- no longer: debuggerLoggerAction dbg_out -} - logAction l dflags1 + GHC.pushLogHook $ const $ debuggerLoggerAction dbg_out -- Set the session dynflags now to initialise the hsc_interp. _ <- GHC.setSessionDynFlags dflags1 From 32ca05e5694942e79be3f6da0c88780b8a3bac6d Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 14 Nov 2025 17:19:09 +0000 Subject: [PATCH 35/40] Omit in-memory compilation output We try to load GHC.Debugger.View.Class and all the orphan instances modules whenever the package is not part of the transitive closure. While doing this, we print a lot of compilation information which is irrelevant to the user. With this commit, we'll hide it by default. It is still printed out with -v3. --- haskell-debugger/GHC/Debugger/Monad.hs | 27 ++++++++++++++++++++------ test/golden/T61/T61.hdb-stdout | 3 ++- test/golden/T79/T79.hdb-stdout | 3 ++- test/golden/T83/T83.hdb-stdout | 3 ++- test/haskell/Test/DAP.hs | 2 +- test/haskell/Test/DAP/RunInTerminal.hs | 2 ++ 6 files changed, 30 insertions(+), 10 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 7b35d10..9eaec13 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -212,7 +212,7 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base] addInMemoryHsDebuggerViewUnit base_dep_uids =<< getDynFlags - tryLoadHsDebuggerViewModule if_cache (const False) debuggerViewClassModName debuggerViewClassContents + tryLoadHsDebuggerViewModule l if_cache (const False) debuggerViewClassModName debuggerViewClassContents >>= \case Failed -> do -- Failed to load base debugger-view module! @@ -222,7 +222,7 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D -- TODO: We could be a bit smarter and filter out if there isn't -- a -package flag for the package we need for each module. forM debuggerViewInstancesMods $ \(modName, modContent) -> do - tryLoadHsDebuggerViewModule if_cache + tryLoadHsDebuggerViewModule l if_cache ((\case -- Keep only "GHC.Debugger.View.Class", which is a dependency of all these. GHC.TargetFile f _ @@ -314,18 +314,29 @@ doLoad if_cache how_much mg = do -- | Returns @Just modName@ if the given module was successfully loaded tryLoadHsDebuggerViewModule - :: GhcMonad m => Maybe ModIfaceCache + :: 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 if_cache keepTarget modName modContents = do +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 + -- 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 + -- Make the target dvcT <- liftIO $ makeInMemoryHsDebuggerViewTarget modName modContents @@ -339,6 +350,11 @@ tryLoadHsDebuggerViewModule if_cache keepTarget modName modContents = do -- Restore targets plus new one if success GHC.setTargets (old_targets ++ (if succeeded result then [dvcT] else [])) + -- Restore logger + GHC.modifyLogger $ + GHC.pushLogHook (const $ putLogMsg restore_logger) + + return result -------------------------------------------------------------------------------- @@ -544,8 +560,7 @@ logSDoc sev doc = do logWith l sev (LogSDoc dflags doc) logAction :: Recorder (WithSeverity DebuggerMonadLog) -> DynFlags -> GHC.LogAction -logAction l dflags = do - return $ \ msg_class _ sdoc -> do +logAction l dflags = \_ msg_class _ sdoc -> do logWith l (msgClassSeverity msg_class) $ LogSDoc dflags sdoc msgClassSeverity :: MessageClass -> Logger.Severity diff --git a/test/golden/T61/T61.hdb-stdout b/test/golden/T61/T61.hdb-stdout index 06fb912..e71b3ad 100644 --- a/test/golden/T61/T61.hdb-stdout +++ b/test/golden/T61/T61.hdb-stdout @@ -1,4 +1,5 @@ -[1 of 2] Compiling Main ( /x/Main.hs, interpreted )[main] +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /x/Main.hs, interpreted )[main] (hdb) wrks EvalCompleted {resultVal = "()", resultType = "()", resultStructureRef = NoVariables} (hdb) Exiting... diff --git a/test/golden/T79/T79.hdb-stdout b/test/golden/T79/T79.hdb-stdout index 75a316b..41f07dd 100644 --- a/test/golden/T79/T79.hdb-stdout +++ b/test/golden/T79/T79.hdb-stdout @@ -7,7 +7,8 @@ [Warn] No synopsis given. You should edit the .cabal file and add one. [Info] You may want to edit the .cabal file and add a Description field. -[1 of 2] Compiling Main ( -tmp] +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( -tmp] (hdb) Hello, Haskell! EvalCompleted {resultVal = "()", resultType = "()", resultStructureRef = NoVariables} (hdb) \ No newline at end of file diff --git a/test/golden/T83/T83.hdb-stdout b/test/golden/T83/T83.hdb-stdout index ca0d958..484771f 100644 --- a/test/golden/T83/T83.hdb-stdout +++ b/test/golden/T83/T83.hdb-stdout @@ -1,4 +1,5 @@ -[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] (hdb) Heli EvalCompleted {resultVal = "()", resultType = "()", resultStructureRef = NoVariables} (hdb) Exiting... diff --git a/test/haskell/Test/DAP.hs b/test/haskell/Test/DAP.hs index bb31da4..cd293a2 100644 --- a/test/haskell/Test/DAP.hs +++ b/test/haskell/Test/DAP.hs @@ -118,5 +118,5 @@ shouldReceive h expected = do 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" diff --git a/test/haskell/Test/DAP/RunInTerminal.hs b/test/haskell/Test/DAP/RunInTerminal.hs index 804640b..518cc16 100644 --- a/test/haskell/Test/DAP/RunInTerminal.hs +++ b/test/haskell/Test/DAP/RunInTerminal.hs @@ -106,6 +106,8 @@ runInTerminal1 = do ["type" .= ("event" :: String), "event" .= ("output" :: String)] _ <- shouldReceive handle ["type" .= ("event" :: String), "event" .= ("output" :: String)] + _ <- shouldReceive handle + ["type" .= ("event" :: String), "event" .= ("output" :: String)] _ <- shouldReceive handle [ "command" .= ("launch" :: String) , "success" .= True] From 644d9f1141d04b5f4e0bffa7287ba74d2b306bf2 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 14 Nov 2025 18:09:02 +0000 Subject: [PATCH 36/40] test: Add simpler step-out test --- test/integration-tests/data/T6/MainC.hs | 10 ++++++++ test/integration-tests/test/adapter.test.ts | 27 +++++++++++++++------ 2 files changed, 30 insertions(+), 7 deletions(-) create mode 100644 test/integration-tests/data/T6/MainC.hs diff --git a/test/integration-tests/data/T6/MainC.hs b/test/integration-tests/data/T6/MainC.hs new file mode 100644 index 0000000..1e06895 --- /dev/null +++ b/test/integration-tests/data/T6/MainC.hs @@ -0,0 +1,10 @@ +module Main where + +main :: IO () +main = do + case foo False undefined of + 1 -> putStrLn "one" + 2 -> putStrLn "two" + +foo = \b x -> if b then 1 else 2 + diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 84488cd..1d3e036 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -758,10 +758,23 @@ describe("Debug Adapter Tests", function () { }) describe("Stepping out (step-out)", function () { - // TODO: Add simpler tests which don't rely on optimisations at all. - // E.g. just simply stepping out to a case expression + it('simple step-out to case', async () => { + let config = mkConfig({ + projectRoot: "/data/T6", + entryFile: "MainC.hs", + entryPoint: "main", + entryArgs: [], + extraGhcArgs: [] + }) + + const expected = (line) => ({ path: config.projectRoot + "/" + config.entryFile, line: line }); + + await dc.hitBreakpoint(config, { path: config.entryFile, line: 9 }, expected(9), expected(9)); + + await dc.stepOutRequest({threadId: 0}); + await dc.assertStoppedLocation('step', expected(5)); + }) - let step_out_broken = ghc_version < "9.14.0.20251007" // hasn't been merged yet, but let's use this bound; will probably only be in GHC 9.14.2 let need_opt = true // Currently we depend on this to work around the fact that >>= is in library code because base is not being interpreted // Mimics GHC's T26042b @@ -781,15 +794,15 @@ describe("Debug Adapter Tests", function () { // foo to bar await dc.stepOutRequest({threadId: 0}); - await dc.assertStoppedLocation('step', expected(step_out_broken ? 21 : 20)); + await dc.assertStoppedLocation('step', expected(20)); // bar back to foo await dc.stepOutRequest({threadId: 0}); - await dc.assertStoppedLocation('step', expected(step_out_broken ? 15 : 14)); + await dc.assertStoppedLocation('step', expected(14)); // back to main await dc.stepOutRequest({threadId: 0}); - await dc.assertStoppedLocation('step', expected(step_out_broken ? 6 : 5)); + await dc.assertStoppedLocation('step', expected(5)); // exit await dc.stepOutRequest({threadId: 0}); @@ -815,7 +828,7 @@ describe("Debug Adapter Tests", function () { // we go straight to `main`. await dc.stepOutRequest({threadId: 0}); - await dc.assertStoppedLocation('step', expected(step_out_broken ? 6 : 5)) + await dc.assertStoppedLocation('step', expected(5)) // stepping out again exits await dc.stepOutRequest({threadId: 0}); From af6e0a18a65cb3d79135b2db0ee7196ccf591fac Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 14 Nov 2025 18:51:20 +0000 Subject: [PATCH 37/40] refactor: Move one line down and comment other --- haskell-debugger/GHC/Debugger/Monad.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 9eaec13..2d994c0 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -195,12 +195,11 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D -- Setup base HomeUnitGraph setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) - - if_cache <- Just <$> liftIO newIfaceCache - -- Downsweep user-given modules first mod_graph_base <- doDownsweep Nothing + if_cache <- Just <$> liftIO newIfaceCache + -- Try to find or load the built-in classes from `haskell-debugger-view` (hdv_uid, loadedBuiltinModNames) <- findHsDebuggerViewUnitId mod_graph_base >>= \case Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do @@ -246,7 +245,7 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D -- 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) + 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 From 365645c8892984022c5bce188f32c2f613f01d62 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 17 Nov 2025 11:43:06 +0000 Subject: [PATCH 38/40] fix: Never strip interface pragmas & unfoldings Fixes the step-out test. Why was it broken? Step-out with do-notation relies on optimisations to inline the definition of >>= (at least for now). However, we now loading GHC.Debugger.View.Class in addition to the user program. Even if the user specified -O1 in their extra GHC args, we would load GHC.Debugger.View.Class without optimisations (since it didn't need them). The issue is that the module interface containing >>= would be stripped of all pragmas and unfoldings because GHC.Debugger.View.Class didn't want them. In turn, when the user Main module was loaded, >>= would not have the unfoldings the user desired. Thus, step-out didn't work. The fix is to include -fno-ignore-interface-pragmas to make sure we never discard the interface additional information, and also -fno-unoptimized-core-for-interpreter to guarantee this isn't undone by the interpreter not allowing optimisations by default. Co-authored-by: Matthew Pickering --- haskell-debugger/GHC/Debugger/Monad.hs | 9 +++++++++ test/integration-tests/test/adapter.test.ts | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 2d994c0..d9bd9d4 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -27,6 +27,7 @@ import qualified Data.List.NonEmpty as NonEmpty import GHC import GHC.Data.FastString +import GHC.Driver.Session import GHC.Data.StringBuffer import GHC.Driver.DynFlags as GHC import GHC.Driver.Env @@ -175,6 +176,14 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D `GHC.gopt_set` GHC.Opt_InsertBreakpoints & setBytecodeBackend & enableByteCodeGeneration + -- DO NOT strip out all unfoldings, inline pragmas, etc from + -- interfaces that we load. At the moment this is quite crucial since + -- step-out in Do-notation relies on optimisations (when the user + -- sets -O1), and we don't want to ignore that. + & unSetGeneralFlag' Opt_IgnoreInterfacePragmas + -- We need this one as well otherwise the above will be nullified, + -- since the interpreter is NO OPTS by default. + & unSetGeneralFlag' Opt_UnoptimizedCoreForInterpreter GHC.modifyLogger $ -- Override the logger to output to the given handle diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 1d3e036..130c4bd 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -785,7 +785,7 @@ describe("Debug Adapter Tests", function () { entryFile: "MainA.hs", entryPoint: "main", entryArgs: [], - extraGhcArgs: need_opt ? ["-O", "-fno-unoptimized-core-for-interpreter"] : [] + extraGhcArgs: need_opt ? ["-O"] : [] }) const expected = (line) => ({ path: config.projectRoot + "/" + config.entryFile, line: line }); @@ -816,7 +816,7 @@ describe("Debug Adapter Tests", function () { entryFile: "MainB.hs", entryPoint: "main", entryArgs: [], - extraGhcArgs: need_opt ? ["-O", "-fno-unoptimized-core-for-interpreter"] : [] + extraGhcArgs: need_opt ? ["-O"] : [] }) const expected = (line) => ({ path: config.projectRoot + "/" + config.entryFile, line: line }); From ef2a51c5e92e5093532b6d5c79b4a1fc58501b69 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 17 Nov 2025 14:22:25 +0000 Subject: [PATCH 39/40] Revert "fix: Never strip interface pragmas & unfoldings" This reverts commit 3093efa27468fb2d31a617f6a0e4ff67a90f6623. Unfortunately, setting `-fno-omit-interface-pragmas` changes the optimisation behavior of the program because, even if we use -O0, the existence of more unfoldings gets used by the compiler when simplifying. This makes debugging more brittle since, e.g., more newtype expressions get inlined and further away from the original program (breaking tests such as the one for newtype variable inspection) --- haskell-debugger/GHC/Debugger/Monad.hs | 9 --------- test/integration-tests/test/adapter.test.ts | 4 ++-- 2 files changed, 2 insertions(+), 11 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index d9bd9d4..2d994c0 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -27,7 +27,6 @@ import qualified Data.List.NonEmpty as NonEmpty import GHC import GHC.Data.FastString -import GHC.Driver.Session import GHC.Data.StringBuffer import GHC.Driver.DynFlags as GHC import GHC.Driver.Env @@ -176,14 +175,6 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D `GHC.gopt_set` GHC.Opt_InsertBreakpoints & setBytecodeBackend & enableByteCodeGeneration - -- DO NOT strip out all unfoldings, inline pragmas, etc from - -- interfaces that we load. At the moment this is quite crucial since - -- step-out in Do-notation relies on optimisations (when the user - -- sets -O1), and we don't want to ignore that. - & unSetGeneralFlag' Opt_IgnoreInterfacePragmas - -- We need this one as well otherwise the above will be nullified, - -- since the interpreter is NO OPTS by default. - & unSetGeneralFlag' Opt_UnoptimizedCoreForInterpreter GHC.modifyLogger $ -- Override the logger to output to the given handle diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 130c4bd..1d3e036 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -785,7 +785,7 @@ describe("Debug Adapter Tests", function () { entryFile: "MainA.hs", entryPoint: "main", entryArgs: [], - extraGhcArgs: need_opt ? ["-O"] : [] + extraGhcArgs: need_opt ? ["-O", "-fno-unoptimized-core-for-interpreter"] : [] }) const expected = (line) => ({ path: config.projectRoot + "/" + config.entryFile, line: line }); @@ -816,7 +816,7 @@ describe("Debug Adapter Tests", function () { entryFile: "MainB.hs", entryPoint: "main", entryArgs: [], - extraGhcArgs: need_opt ? ["-O"] : [] + extraGhcArgs: need_opt ? ["-O", "-fno-unoptimized-core-for-interpreter"] : [] }) const expected = (line) => ({ path: config.projectRoot + "/" + config.entryFile, line: line }); From 0d18ff4b4f7b0c1e580367aaa958f57611997143 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 17 Nov 2025 14:44:08 +0000 Subject: [PATCH 40/40] fix: Pass extraGhcArgs to ALL units Make sure to parse and use the extraGhcArgs as dynflags which are shared across all units. Failing to do this caused a bug with step-out where `>>=` from base was being loaded without interface pragmas because GHC.Debugger.View.Class was being compiled with -O0 while the user program was meant to be compiled with -O1 (extraGhcArgs = -O -fno-unoptimized-core-for-interpreter). We want to use the same optimization level across all units, and, for correctness, pass the extra args to all units. See also the two previous commits for an alternative way to fix this particular bug, but with downsides of their own and less principled. Co-authored-by: Matthew Pickering --- haskell-debugger/GHC/Debugger/Monad.hs | 26 +++++++++++++++++++++++--- hdb/Development/Debug/Adapter/Init.hs | 6 ++---- hdb/Development/Debug/Interactive.hs | 3 +-- 3 files changed, 26 insertions(+), 9 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 2d994c0..84a4ef4 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -28,8 +28,10 @@ import qualified Data.List.NonEmpty as NonEmpty import GHC 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 @@ -149,11 +151,12 @@ runDebugger :: Recorder (WithSeverity DebuggerMonadLog) -> 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 l 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 @@ -180,8 +183,25 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D -- Override the logger to output to the given handle GHC.pushLogHook $ const $ debuggerLoggerAction dbg_out + 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 dflags1 + _ <- GHC.setSessionDynFlags dflags2 -- Initialise plugins here because the plugin author might already expect this -- subsequent call to `getLogger` to be affected by a plugin. @@ -191,7 +211,7 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (D GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df) -- Discover the user-given flags and targets - flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags1 rootDir + flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir -- Setup base HomeUnitGraph setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index a44675e..7865b23 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -237,8 +237,6 @@ debuggerThread :: Recorder (WithSeverity InitLog) -> 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 @@ -247,11 +245,11 @@ debuggerThread recorder finished_init writeDebuggerOutput workDir HieBiosFlags{. Output.console $ T.pack $ "libdir: " <> libdir <> "\n" <> "units: " <> unwords units <> "\n" <> - "args: " <> unwords finalGhcInvocation + "args: " <> unwords (ghcInvocation ++ extraGhcArgs) catches (do - Debugger.runDebugger (cmapWithSev DebuggerMonadLog recorder) 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 diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index 6ad97d4..72da9b6 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -60,11 +60,10 @@ runIDM logger entryPoint entryFile entryArgs extraGhcArgs act = do , supportsANSIHyperlinks = False } - let finalGhcInvocation = ghcInvocation ++ extraGhcArgs let absEntryFile = normalise $ projectRoot entryFile let debugRec = cmapWithSev DebuggerMonadLog logger - runDebugger debugRec 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