diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for haskell-debugger +## 0.10.1.0 -- 2025-11-21 + +* Fixes critical bug which prevented debugger from being used with non-boot + dependencies! + ## 0.10.0.0 -- 2025-11-18 * Adds Custom Debug Visualisations! diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs --- a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs @@ -40,6 +40,9 @@ ) where +import Data.Int +import Data.Word + -- | Custom handling of debug terms (e.g. in the variables pane, or when -- inspecting a lazy variable) class DebugView a where @@ -112,7 +115,15 @@ debugFields _ = VarFields [] deriving via BoringTy Int instance DebugView Int +deriving via BoringTy Int8 instance DebugView Int8 +deriving via BoringTy Int16 instance DebugView Int16 +deriving via BoringTy Int32 instance DebugView Int32 +deriving via BoringTy Int64 instance DebugView Int64 deriving via BoringTy Word instance DebugView Word +deriving via BoringTy Word8 instance DebugView Word8 +deriving via BoringTy Word16 instance DebugView Word16 +deriving via BoringTy Word32 instance DebugView Word32 +deriving via BoringTy Word64 instance DebugView Word64 deriving via BoringTy Double instance DebugView Double deriving via BoringTy Float instance DebugView Float deriving via BoringTy Integer instance DebugView Integer diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -1,6 +1,6 @@ cabal-version: 3.12 name: haskell-debugger -version: 0.10.0.0 +version: 0.10.1.0 synopsis: A step-through debugger for GHC Haskell diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -1,38 +1,18 @@ {-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments #-} module GHC.Debugger.Runtime.Instances where -import Control.Exception import Control.Monad import Control.Monad.Reader import GHC -import GHC.Builtin.Names -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Driver.Config import GHC.Driver.Env -import GHC.Driver.Main -import GHC.HsToCore.Expr -import GHC.HsToCore.Monad import GHC.Plugins -import GHC.Rename.Env -import GHC.Rename.Expr import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect import GHC.Runtime.Interpreter as Interp -import GHC.Tc.Gen.Expr -import GHC.Tc.Solver -import GHC.Tc.Types.Evidence -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcType -import GHC.Tc.Zonk.Type -import GHCi.Message import GHC.Debugger.Monad -import GHC.Debugger.Session.Builtin import GHC.Debugger.View.Class -import GHC.Debugger.Logger as Logger import GHC.Debugger.Runtime.Instances.Discover diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -20,7 +20,9 @@ import Data.FileEmbed import Data.Function +import Data.Maybe import Data.Time +import qualified Data.Foldable as Foldable import GHC import GHC.Unit @@ -108,7 +110,8 @@ } & setGeneralFlag' Opt_HideAllPackages hsc_env <- getSession - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger hsc_env) imhdv_dflags Nothing mempty + let cached_unit_dbs = concat . catMaybes . fmap HUG.homeUnitEnv_unit_dbs $ Foldable.toList (hsc_HUG hsc_env) + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger hsc_env) imhdv_dflags (Just cached_unit_dbs) mempty updated_dflags <- liftIO $ updatePlatformConstants imhdv_dflags mconstants emptyHpt <- liftIO HPT.emptyHomePackageTable modifySession $ \env -> diff --git a/hdb/Development/Debug/Adapter/Breakpoints.hs b/hdb/Development/Debug/Adapter/Breakpoints.hs --- a/hdb/Development/Debug/Adapter/Breakpoints.hs +++ b/hdb/Development/Debug/Adapter/Breakpoints.hs @@ -81,7 +81,7 @@ breaks <- forM breaks_wanted $ \bp -> do DidSetBreakpoint bf <- sendSync $ SetBreakpoint - FunctionBreak { function = T.unpack $ fromJust {- not optional -} $ DAP.functionBreakpointName bp } + FunctionBreak { function = T.unpack $ fromJust {- not optional! -} $ DAP.functionBreakpointName bp } (readMaybe @Int =<< (T.unpack <$> DAP.functionBreakpointHitCondition bp)) (T.unpack <$> DAP.functionBreakpointCondition bp) registerBreakFound bf diff --git a/hdb/Development/Debug/Adapter/Exit.hs b/hdb/Development/Debug/Adapter/Exit.hs --- a/hdb/Development/Debug/Adapter/Exit.hs +++ b/hdb/Development/Debug/Adapter/Exit.hs @@ -45,7 +45,7 @@ -- DidTerminate <- sendInterleaved TerminateProcess sendTerminateResponse destroyDebugSession sendTerminateResponse - exitCleanly + exitCleanly Nothing -- | Command disconnect (1b) -- @@ -54,7 +54,7 @@ commandDisconnect = do destroyDebugSession sendDisconnectResponse - exitCleanly + exitCleanly Nothing --- Exit Cleanly --------------------------------------------------------------- @@ -86,17 +86,22 @@ exitWithMsg :: String -> DebugAdaptor a exitWithMsg msg = do Output.important (T.pack msg) - exitCleanly + exitCleanly (Just msg) -exitCleanly :: DebugAdaptor a -exitCleanly = do +exitCleanly :: Maybe String -> DebugAdaptor a +exitCleanly mm = do sendTerminatedEvent (TerminatedEvent False) -- We exit here to guarantee the process is killed when -- terminated. Important! We want a new server process per -- session, which means at the end we must kill the server. - liftIO $ throwIO TerminateServer + liftIO $ do + case mm of + Nothing -> throwIO TerminateServer + Just em -> do + hPutStrLn stderr em + throwIO TerminateServer --- Utils ---------------------------------------------------------------------- @@ -106,5 +111,4 @@ case displayExceptionContext (someExceptionContext ex) of "" -> displayException ex cx -> displayException ex ++ "\n\n" ++ cx - diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -186,8 +186,16 @@ writeChan syncErr $ T.encodeUtf8 (line <> "\n") -- Always output to Debug Console - withAdaptor $ Output.stderr line + catch + (withAdaptor $ Output.stderr line) + (\(_ :: SomeException) -> + throwIO (FailedToWriteToAdaptor line)) +newtype FailedToWriteToAdaptor = FailedToWriteToAdaptor T.Text +instance Show FailedToWriteToAdaptor where + show (FailedToWriteToAdaptor t) = "Failed to write to debug adapter: " ++ T.unpack t +instance Exception FailedToWriteToAdaptor + stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () stdinForwardThread runInTerminal syncIn _withAdaptor = do when runInTerminal $ do @@ -270,7 +278,7 @@ reply = liftIO . putMVar replies bad m = liftIO $ do hPutStrLn stderr m - putMVar replies (Aborted m) + putMVar replies (Aborted ("Aborted debugger thread: " ++ m)) -- | Reads from the read end of the handle to which the debugger writes compiler messages. -- Writes the compiler messages to the client console diff --git a/hdb/Development/Debug/Adapter/Interface.hs b/hdb/Development/Debug/Adapter/Interface.hs --- a/hdb/Development/Debug/Adapter/Interface.hs +++ b/hdb/Development/Debug/Adapter/Interface.hs @@ -9,6 +9,7 @@ import GHC.Debugger.Interface.Messages as D import Development.Debug.Adapter +import Development.Debug.Adapter.Exit import qualified Development.Debug.Adapter.Output as Output -- | Synchronously send a command to the debugger and await a response @@ -29,7 +30,6 @@ handleAbort :: Response -> DebugAdaptor Response handleAbort (Aborted e) = do Output.console (T.pack e) - sendTerminatedEvent defaultTerminatedEvent - return (Aborted e) -- will TerminatedEvent terminate this session before this happens? + exitCleanly (Just e) handleAbort r = return r diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -69,7 +69,7 @@ (entryFile, entryPoint, entryArgs) Nothing where exitWithMsg txt = do - putStrLn txt + hPutStrLn stderr txt exitWith (ExitFailure 33) -- completeF = completeWordWithPrev Nothing filenameWordBreakChars $ diff --git a/hdb/Main.hs b/hdb/Main.hs --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -9,6 +9,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Except +import Control.Exception.Backtrace import DAP @@ -42,6 +43,10 @@ main :: IO () main = do + setBacktraceMechanismState CostCentreBacktrace False + setBacktraceMechanismState HasCallStackBacktrace True + setBacktraceMechanismState IPEBacktrace True + hdbOpts <- parseHdbOptions let timeStampLogger = cmapIO renderWithTimestamp . fromCologAction @@ -205,11 +210,11 @@ Left (InitFailed err) -> do sendErrorResponse (ErrorMessage (T.pack err)) Nothing - exitCleanly + exitCleanly Nothing -------------------------------------------------------------------------------- CommandAttach -> do sendErrorResponse (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing - exitCleanly + exitCleanly Nothing -------------------------------------------------------------------------------- CommandBreakpointLocations -> commandBreakpointLocations CommandSetBreakpoints -> commandSetBreakpoints @@ -256,7 +261,7 @@ pure () other -> do sendErrorResponse (ErrorMessage (T.pack ("Unsupported command: " <> show other))) Nothing - exitCleanly + exitCleanly Nothing ---------------------------------------------------------------------------- -- talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd) ----------------------------------------------------------------------------