haskell-debugger 0.13.1.0 → 0.14.0.0
raw patch · 194 files changed
+6283/−3694 lines, 194 filesdep +monad-controldep +rtsdep ~aesondep ~asyncdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: monad-control, rts
Dependency ranges changed: aeson, async, base, bytestring, containers, dap, directory, exceptions, filepath, ghc, ghc-boot, ghc-boot-th, ghc-experimental, ghc-heap, ghci, haskell-debugger-view, hie-bios, mtl, network, network-run, process, time
API changes (from Hackage documentation)
- GHC.Debugger.Monad: DebuggerLog :: Severity -> DebuggerMessage -> DebuggerLog
- GHC.Debugger.Monad: GHCLog :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> DebuggerLog
- GHC.Debugger.Monad: LogDebuggeeErr :: Text -> DebuggerLog
- GHC.Debugger.Monad: LogDebuggeeOut :: Text -> DebuggerLog
- GHC.Debugger.Monad: LogFailedToCompileDebugViewModule :: ModuleName -> DebuggerMessage
- GHC.Debugger.Monad: LogSDoc :: DynFlags -> SDoc -> DebuggerMessage
- GHC.Debugger.Monad: LogSkippingViewModuleNoPkg :: ModuleName -> String -> [String] -> DebuggerMessage
- GHC.Debugger.Monad: [externalInterpreterCustomProc] :: RunDebuggerSettings -> Either StdStream PortNumber
- GHC.Debugger.Monad: [preferInternalInterpreter] :: RunDebuggerSettings -> Bool
- GHC.Debugger.Monad: data DebuggerLog
- GHC.Debugger.Monad: data DebuggerMessage
- GHC.Debugger.Monad: extInterpFromTerminalProcess :: PortNumber -> IO Interp
- GHC.Debugger.Monad: ghcLogAction :: LogAction IO DebuggerLog -> LogAction
- GHC.Debugger.Monad: instance GHC.Internal.Show.Show GHC.Debugger.Monad.DebuggerMessage
- GHC.Debugger.Monad: msgClassSeverity :: MessageClass -> Severity
- GHC.Debugger.Monad: openListener :: PortNumber -> IO Socket
- GHC.Debugger.Monad: socketAddressFromPort :: PortNumber -> IO AddrInfo
- GHC.Debugger.Monad: tryLoadHsDebuggerViewModule :: GhcMonad m => LogAction IO DebuggerLog -> Maybe ModIfaceCache -> (Target -> Bool) -> ModuleName -> StringBuffer -> m SuccessFlag
- GHC.Debugger.Monad: withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a
- GHC.Debugger.Run: withCurrentBreakExtensions :: Debugger a -> Debugger a
- GHC.Debugger.Runtime.Interpreter.Custom: StackFrameAnnotation :: Maybe SrcLoc -> String -> StackFrameInfo
- GHC.Debugger.Runtime.Interpreter.Custom: StackFrameBreakpointInfo :: InternalBreakpointId -> StackFrameInfo
- GHC.Debugger.Runtime.Interpreter.Custom: StackFrameIPEInfo :: InfoProv -> StackFrameInfo
- GHC.Debugger.Runtime.Interpreter.Custom: ThreadInfo :: ref ThreadId -> Maybe String -> ThreadStatus -> ThreadInfo (ref :: Type -> Type)
- GHC.Debugger.Runtime.Interpreter.Custom: [CollectExceptionInfo] :: RemoteRef SomeException -> DbgInterpCmd ExceptionInfo
- GHC.Debugger.Runtime.Interpreter.Custom: [DecodeThreadStack] :: RemoteRef ThreadId -> DbgInterpCmd [StackFrameInfo]
- GHC.Debugger.Runtime.Interpreter.Custom: [ListThreads] :: DbgInterpCmd [ThreadInfo RemoteRef]
- GHC.Debugger.Runtime.Interpreter.Custom: [Some] :: forall {k} (c :: k -> Constraint) (a :: k) (f :: k -> Type). c a => f a -> Some c f
- GHC.Debugger.Runtime.Interpreter.Custom: [threadInfoLabel] :: ThreadInfo (ref :: Type -> Type) -> Maybe String
- GHC.Debugger.Runtime.Interpreter.Custom: [threadInfoRef] :: ThreadInfo (ref :: Type -> Type) -> ref ThreadId
- GHC.Debugger.Runtime.Interpreter.Custom: [threadInfoStatus] :: ThreadInfo (ref :: Type -> Type) -> ThreadStatus
- GHC.Debugger.Runtime.Interpreter.Custom: data DbgInterpCmd a
- GHC.Debugger.Runtime.Interpreter.Custom: data Some (c :: k -> Constraint) (f :: k -> Type)
- GHC.Debugger.Runtime.Interpreter.Custom: data StackFrameInfo
- GHC.Debugger.Runtime.Interpreter.Custom: data ThreadInfo (ref :: Type -> Type)
- GHC.Debugger.Runtime.Interpreter.Custom: dbgInterpCmdHandler :: Word8 -> ByteString -> IO (Maybe ByteString)
- GHC.Debugger.Runtime.Interpreter.Custom: dbgInterpCmdTag :: Word8
- GHC.Debugger.Runtime.Interpreter.Custom: decodePayload :: Binary a => ByteString -> Either String a
- GHC.Debugger.Runtime.Interpreter.Custom: encodePayload :: Binary a => a -> ByteString
- GHC.Debugger.Runtime.Interpreter.Custom: exceptionInfo :: SomeException -> ExceptionInfo
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary (GHC.Debugger.Runtime.Interpreter.Custom.Some Data.Binary.Class.Binary GHC.Debugger.Runtime.Interpreter.Custom.DbgInterpCmd)
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary (GHC.Debugger.Runtime.Interpreter.Custom.ThreadInfo GHCi.RemoteTypes.RemoteRef)
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary GHC.ByteCode.Breakpoints.InternalBreakpointId
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary GHC.Debugger.Interface.Messages.ExceptionInfo
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary GHC.Debugger.Interface.Messages.SourceSpan
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary GHC.Debugger.Runtime.Interpreter.Custom.StackFrameInfo
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary GHC.Internal.Conc.Sync.BlockReason
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary GHC.Internal.Conc.Sync.ThreadStatus
- GHC.Debugger.Runtime.Interpreter.Custom: instance Data.Binary.Class.Binary GHC.Internal.Stack.Types.SrcLoc
- GHC.Debugger.Runtime.Interpreter.Custom: instance GHC.Internal.Generics.Generic (GHC.Debugger.Runtime.Interpreter.Custom.ThreadInfo ref)
- GHC.Debugger.Runtime.Interpreter.Custom: instance GHC.Internal.Generics.Generic GHC.Debugger.Runtime.Interpreter.Custom.StackFrameInfo
- GHC.Debugger.Runtime.Interpreter.Custom: lookupBCOBreakpoint :: GenClosure Box -> IO (Maybe InternalBreakpointId)
- GHC.Debugger.Runtime.Interpreter.Custom: runDbgInterpCmd :: DbgInterpCmd a -> IO a
- GHC.Debugger.Runtime.Interpreter.Custom: stackFrameInfo :: (StackFrame, Maybe InfoProv) -> IO (Maybe StackFrameInfo)
- GHC.Debugger.Runtime.Interpreter.Custom: threadInfo :: ThreadId -> IO (ThreadInfo RemoteRef)
- GHC.Debugger.Runtime.Thread.Stack: instance GHC.Internal.Show.Show GHC.Debugger.Runtime.Thread.Stack.BCOBreakPointInfo
- GHC.Debugger.Session: graphUnits :: ModuleGraph -> [UnitId]
- GHC.Debugger.Session: setExposedInUnit :: UnitId -> [UnitId] -> Ghc ()
- GHC.Debugger.Session.Builtin: makeInMemoryHsDebuggerViewTarget :: ModuleName -> StringBuffer -> IO Target
- GHC.Debugger.Session.Interactive: execStmtNoOccEnv :: GhcMonad m => GhciLStmt GhcPs -> m (Maybe ExecResult)
- GHC.Debugger.Session.Interactive: extendInteractiveContextWithIdsNoOccEnv :: InteractiveContext -> [Id] -> InteractiveContext
- GHC.Debugger.Session.Interactive: handleCompleted :: GhcMonad m => (InteractiveContext -> [Id] -> InteractiveContext) -> [Id] -> EvalStatus_ [ForeignHValue] [HValueRef] -> m (Maybe ExecResult)
+ GHC.Debugger.Debuggee: DebuggerLog :: Severity -> DebuggerMessage -> DebuggerLog
+ GHC.Debugger.Debuggee: DebuggerSessionLog :: Severity -> Text -> DebuggerLog
+ GHC.Debugger.Debuggee: GHCLog :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> DebuggerLog
+ GHC.Debugger.Debuggee: InconsistentInterpreterFlags :: String -> InconsistentInterpreterFlags
+ GHC.Debugger.Debuggee: InterpreterSettings :: (DynFlags -> DynFlags) -> (forall a. () => LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a) -> InterpreterSettings
+ GHC.Debugger.Debuggee: LogFailedToCompileBuiltinModule :: ModuleName -> DebuggerMessage
+ GHC.Debugger.Debuggee: LogSDoc :: DynFlags -> SDoc -> DebuggerMessage
+ GHC.Debugger.Debuggee: LogSkippingViewModuleNoPkg :: ModuleName -> String -> [String] -> DebuggerMessage
+ GHC.Debugger.Debuggee: [interpreterFlags] :: InterpreterSettings -> DynFlags -> DynFlags
+ GHC.Debugger.Debuggee: [interpreterSetup] :: InterpreterSettings -> forall a. () => LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
+ GHC.Debugger.Debuggee: data DebuggerLog
+ GHC.Debugger.Debuggee: data DebuggerMessage
+ GHC.Debugger.Debuggee: data InterpreterSettings
+ GHC.Debugger.Debuggee: extInterpFromListeningSocket :: Socket -> IO Interp
+ GHC.Debugger.Debuggee: ghcLogAction :: LogAction IO DebuggerLog -> LogAction
+ GHC.Debugger.Debuggee: instance GHC.Internal.Exception.Type.Exception GHC.Debugger.Debuggee.InconsistentInterpreterFlags
+ GHC.Debugger.Debuggee: instance GHC.Internal.Show.Show GHC.Debugger.Debuggee.DebuggerMessage
+ GHC.Debugger.Debuggee: instance GHC.Internal.Show.Show GHC.Debugger.Debuggee.InconsistentInterpreterFlags
+ GHC.Debugger.Debuggee: mkCliInterpreterSettings :: Bool -> Maybe FilePath -> IO InterpreterSettings
+ GHC.Debugger.Debuggee: mkExternalInterpreterFlags :: String -> DynFlags -> DynFlags
+ GHC.Debugger.Debuggee: mkExternalInterpreterFromIOSetup :: IO Interp -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
+ GHC.Debugger.Debuggee: mkExternalInterpreterSubProcessSetup :: StdStream -> StdStream -> StdStream -> (CreatedProcess -> IO ()) -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
+ GHC.Debugger.Debuggee: mkInternalInterpreterFlags :: DynFlags -> DynFlags
+ GHC.Debugger.Debuggee: mkInternalInterpreterSetup :: LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
+ GHC.Debugger.Debuggee: msgClassSeverity :: MessageClass -> Severity
+ GHC.Debugger.Debuggee: newtype InconsistentInterpreterFlags
+ GHC.Debugger.Debuggee: type CreatedProcess = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+ GHC.Debugger.Interface.Messages: (/>) :: AbsFilePath -> FilePath -> AbsFilePath
+ GHC.Debugger.Interface.Messages: DbgStackFrameBCOArgs :: NoShow (ref [StackField]) -> Maybe Word -> DbgStackFrameBCOArgs (ref :: Type -> Type)
+ GHC.Debugger.Interface.Messages: MkAbsFilePath :: FilePath -> AbsFilePath
+ GHC.Debugger.Interface.Messages: NoShow :: a -> NoShow a
+ GHC.Debugger.Interface.Messages: NonFatalError :: String -> Response
+ GHC.Debugger.Interface.Messages: [args] :: DbgStackFrame -> Maybe (DbgStackFrameBCOArgs ForeignRef)
+ GHC.Debugger.Interface.Messages: [bcoArgsOffset] :: DbgStackFrameBCOArgs (ref :: Type -> Type) -> Maybe Word
+ GHC.Debugger.Interface.Messages: [bcoArgs] :: DbgStackFrameBCOArgs (ref :: Type -> Type) -> NoShow (ref [StackField])
+ GHC.Debugger.Interface.Messages: [unAbs] :: AbsFilePath -> FilePath
+ GHC.Debugger.Interface.Messages: data DbgStackFrameBCOArgs (ref :: Type -> Type)
+ GHC.Debugger.Interface.Messages: instance GHC.Internal.Classes.Eq GHC.Debugger.Interface.Messages.AbsFilePath
+ GHC.Debugger.Interface.Messages: instance GHC.Internal.Generics.Generic (GHC.Debugger.Interface.Messages.DbgStackFrameBCOArgs ref)
+ GHC.Debugger.Interface.Messages: instance GHC.Internal.Show.Show (GHC.Debugger.Interface.Messages.DbgStackFrameBCOArgs ref)
+ GHC.Debugger.Interface.Messages: instance GHC.Internal.Show.Show (GHC.Debugger.Interface.Messages.NoShow a)
+ GHC.Debugger.Interface.Messages: instance GHC.Internal.Show.Show GHC.Debugger.Interface.Messages.AbsFilePath
+ GHC.Debugger.Interface.Messages: mkAbsolute :: FilePath -> AbsFilePath
+ GHC.Debugger.Interface.Messages: newtype AbsFilePath
+ GHC.Debugger.Interface.Messages: newtype NoShow a
+ GHC.Debugger.Monad: FailedToLoadFFIInspectModule :: FailedToLoadFFIInspectModule
+ GHC.Debugger.Monad: NonFatalException :: String -> String -> NonFatalException
+ GHC.Debugger.Monad: ProjectDebugSpec :: FilePath -> FilePath -> FilePath -> [String] -> [String] -> FilePath -> [String] -> ProjectDebugSpec
+ GHC.Debugger.Monad: [absEntryFile] :: ProjectDebugSpec -> FilePath
+ GHC.Debugger.Monad: [componentDir] :: ProjectDebugSpec -> FilePath
+ GHC.Debugger.Monad: [debugMessage] :: NonFatalException -> String
+ GHC.Debugger.Monad: [extraGhcArgs] :: ProjectDebugSpec -> [String]
+ GHC.Debugger.Monad: [ghcInvocation] :: ProjectDebugSpec -> [String]
+ GHC.Debugger.Monad: [interpreterSettings] :: RunDebuggerSettings -> InterpreterSettings
+ GHC.Debugger.Monad: [libdir] :: ProjectDebugSpec -> FilePath
+ GHC.Debugger.Monad: [rootDir] :: ProjectDebugSpec -> FilePath
+ GHC.Debugger.Monad: [units] :: ProjectDebugSpec -> [String]
+ GHC.Debugger.Monad: [userMessage] :: NonFatalException -> String
+ GHC.Debugger.Monad: data FailedToLoadFFIInspectModule
+ GHC.Debugger.Monad: data NonFatalException
+ GHC.Debugger.Monad: data ProjectDebugSpec
+ GHC.Debugger.Monad: findOrLoadHaskellDebuggerView :: LogAction IO DebuggerLog -> Ways -> Ghc (UnitId, [ModuleName])
+ GHC.Debugger.Monad: getAllLoadedModulesWithPaths :: GhcMonad m => m [(AbsFilePath, ModuleNodeInfo)]
+ GHC.Debugger.Monad: instance GHC.Internal.Exception.Type.Exception GHC.Debugger.Monad.FailedToLoadFFIInspectModule
+ GHC.Debugger.Monad: instance GHC.Internal.Exception.Type.Exception GHC.Debugger.Monad.NonFatalException
+ GHC.Debugger.Monad: instance GHC.Internal.Show.Show GHC.Debugger.Monad.FailedToLoadFFIInspectModule
+ GHC.Debugger.Monad: instance GHC.Internal.Show.Show GHC.Debugger.Monad.NonFatalException
+ GHC.Debugger.Monad: loadFFIInspect :: LogAction IO DebuggerLog -> Ways -> Ghc ()
+ GHC.Debugger.Monad: loadInMemoryModules :: LogAction IO DebuggerLog -> UnitId -> [(ModuleName, StringBuffer)] -> Ghc [SuccessFlag]
+ GHC.Debugger.Monad: loadInternal :: LogAction IO DebuggerLog -> Ways -> Ghc ()
+ GHC.Debugger.Monad: preservingThreadLabel :: HasCallStack => Ghc a -> Ghc a
+ GHC.Debugger.Monad: runDebuggerAction :: LogAction IO DebuggerLog -> FilePath -> [String] -> RunDebuggerSettings -> Ghc () -> Debugger a -> Ghc a
+ GHC.Debugger.Monad: type DebugRunner (m :: Type -> Type) a = DebugSession m a -> IO a
+ GHC.Debugger.Monad: type DebugSession (m :: Type -> Type) a = FilePath -> [String] -> m () -> Ghc a
+ GHC.Debugger.Monad: withProjectDebugSession :: GhcMonad m => ProjectDebugSpec -> DebugRunner m a
+ GHC.Debugger.Run: withCurrentBreakEnv :: Debugger a -> Debugger a
+ GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin: displayStackAnnotationShort :: RemoteExpr SomeStackAnnotation -> RemoteExpr String
+ GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin: fst :: RemoteExpr ((a, b) -> a)
+ GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin: pair :: RemoteExpr (a -> b -> (a, b))
+ GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin: snd :: RemoteExpr ((a, b) -> b)
+ GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin: stackAnnotationSourceLocation :: RemoteExpr SomeStackAnnotation -> RemoteExpr (Maybe SrcLoc)
+ GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin: unpackStackFields :: RemoteExpr ([StackField] -> Maybe [Int] -> IO [HValue])
+ GHC.Debugger.Runtime.FFIInspect: bcoArgsOffset :: StackSnapshot -> Int -> Maybe Word
+ GHC.Debugger.Runtime.FFIInspect: bco_args_offset :: StackSnapshot# -> Word -> Int
+ GHC.Debugger.Runtime.FFIInspect: stack_bco_frame_selftest :: IO Bool
+ GHC.Debugger.Runtime.Internal: concat :: Foldable t => t [a] -> [a]
+ GHC.Debugger.Runtime.Internal: cons :: a -> [a] -> [a]
+ GHC.Debugger.Runtime.Internal: evalWrapper :: String -> [String] -> IO a -> IO a
+ GHC.Debugger.Runtime.Internal: nil :: [a]
+ GHC.Debugger.Runtime.Internal: noPrintConstant :: a -> IO ()
+ GHC.Debugger.Runtime.Internal: putStrLn :: String -> IO ()
+ GHC.Debugger.Runtime.Internal: setLineBuffering :: IO ()
+ GHC.Debugger.Runtime.Internal: unpackStackField :: StackField -> IO HValue
+ GHC.Debugger.Runtime.Internal: unpackStackFields :: [StackField] -> Maybe [Int] -> IO [HValue]
+ GHC.Debugger.Runtime.Interpreter.Legacy: collectExceptionInfo :: ForeignRef SomeException -> Debugger (Maybe ExceptionInfo)
+ GHC.Debugger.Runtime.Interpreter.Legacy: decodeThreadStack :: ForeignRef ThreadId -> Debugger [StackFrameInfo ForeignRef]
+ GHC.Debugger.Runtime.Interpreter.Legacy: instance GHC.Internal.Show.Show GHC.Debugger.Runtime.Interpreter.Legacy.BCOBreakPointInfo
+ GHC.Debugger.Runtime.Interpreter.Legacy: listThreads :: Debugger [ThreadInfo ForeignRef]
+ GHC.Debugger.Runtime.Interpreter.Legacy: unpackStackFields :: ForeignRef [StackField] -> Maybe [Int] -> Debugger [ForeignHValue]
+ GHC.Debugger.Runtime.Interpreter.Types: StackFrameAnnotation :: Maybe SrcLoc -> String -> StackFrameInfo (ref :: Type -> Type)
+ GHC.Debugger.Runtime.Interpreter.Types: StackFrameBreakpointInfo :: InternalBreakpointId -> DbgStackFrameBCOArgs ref -> StackFrameInfo (ref :: Type -> Type)
+ GHC.Debugger.Runtime.Interpreter.Types: StackFrameIPEInfo :: InfoProv -> StackFrameInfo (ref :: Type -> Type)
+ GHC.Debugger.Runtime.Interpreter.Types: ThreadInfo :: ref ThreadId -> Maybe String -> ThreadStatus -> ThreadInfo (ref :: Type -> Type)
+ GHC.Debugger.Runtime.Interpreter.Types: [threadInfoLabel] :: ThreadInfo (ref :: Type -> Type) -> Maybe String
+ GHC.Debugger.Runtime.Interpreter.Types: [threadInfoRef] :: ThreadInfo (ref :: Type -> Type) -> ref ThreadId
+ GHC.Debugger.Runtime.Interpreter.Types: [threadInfoStatus] :: ThreadInfo (ref :: Type -> Type) -> ThreadStatus
+ GHC.Debugger.Runtime.Interpreter.Types: data StackFrameInfo (ref :: Type -> Type)
+ GHC.Debugger.Runtime.Interpreter.Types: data ThreadInfo (ref :: Type -> Type)
+ GHC.Debugger.Runtime.Interpreter.Types: instance GHC.Internal.Generics.Generic (GHC.Debugger.Runtime.Interpreter.Types.StackFrameInfo ref)
+ GHC.Debugger.Runtime.Interpreter.Types: instance GHC.Internal.Generics.Generic (GHC.Debugger.Runtime.Interpreter.Types.ThreadInfo ref)
+ GHC.Debugger.Runtime.Interpreter.Types: instance GHC.Internal.Show.Show (GHC.Debugger.Runtime.Interpreter.Types.StackFrameInfo ref)
+ GHC.Debugger.Runtime.Term.Parser: intPrimParser :: TermParser Int
+ GHC.Debugger.Runtime.Term.Parser: liftDebuggerOrFail :: Show e => Debugger (Either e a) -> TermParser a
+ GHC.Debugger.Runtime.Term.Parser: wordPrimParser :: TermParser Word
+ GHC.Debugger.Session: annotateCallStackGhc :: HasCallStack => Ghc a -> Ghc a
+ GHC.Debugger.Session: compileModuleWithDepsInHpt :: Target -> Ghc (Maybe SourceError)
+ GHC.Debugger.Session: exposeModGraphUnitsInInteractiveGhcDebuggerUnit :: Ghc ()
+ GHC.Debugger.Session: fixHomeUnitsDynFlagsForIIDecl :: Ghc ()
+ GHC.Debugger.Session: getPgmI :: DynFlags -> String
+ GHC.Debugger.Session: graphsUnits :: HscEnv -> [UnitId]
+ GHC.Debugger.Session: home_unit_dflags :: HscEnv -> UnitId -> Maybe DynFlags
+ GHC.Debugger.Session: initUniqSupplyIO :: IO ()
+ GHC.Debugger.Session: instance GHC.Internal.Classes.Ord GHC.Driver.DynFlags.PackageDBFlag
+ GHC.Debugger.Session: instance GHC.Internal.Classes.Ord GHC.Driver.DynFlags.PkgDbRef
+ GHC.Debugger.Session: lookupUnitPackageQualifier :: HscEnv -> UnitId -> Maybe PackageQualifier
+ GHC.Debugger.Session: packageImportDecl :: PackageQualifier -> ModuleName -> ImportDecl GhcPs
+ GHC.Debugger.Session: withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a
+ GHC.Debugger.Session.Builtin: addInMemoryDebuggerInternalUnit :: (MonadFail m, GhcMonad m) => DynFlags -> m ()
+ GHC.Debugger.Session.Builtin: addInMemoryFFIInspectUnit :: GhcMonad m => [UnitId] -> DynFlags -> m UnitId
+ GHC.Debugger.Session.Builtin: debuggerInternalUnitId :: UnitId
+ GHC.Debugger.Session.Builtin: debuggerRuntimeFFIInspectContents :: StringBuffer
+ GHC.Debugger.Session.Builtin: debuggerRuntimeFFIInspectModName :: ModuleName
+ GHC.Debugger.Session.Builtin: debuggerRuntimeInternalContents :: StringBuffer
+ GHC.Debugger.Session.Builtin: debuggerRuntimeInternalModName :: ModuleName
+ GHC.Debugger.Session.Builtin: debuggerRuntimeInternalModule :: Module
+ GHC.Debugger.Session.Builtin: debuggerRuntimeInternalUnit :: Unit
+ GHC.Debugger.Session.Builtin: hsDebuggerFFIInspectUnitId :: UnitId
+ GHC.Debugger.Session.Builtin: makeInMemoryTarget :: UnitId -> ModuleName -> StringBuffer -> IO Target
+ GHC.Debugger.Session.Builtin: runInternal :: GhcMonad m => m a -> m a
+ GHC.Debugger.Stopped.Frames: addIdsToInteractiveContext :: HscEnv -> [Id] -> IO HscEnv
+ GHC.Debugger.Stopped.Frames: getStackFrameBindings :: DbgStackFrame -> Debugger [Id]
+ GHC.Debugger.Utils.Orphans: instance GHC.Debugger.View.Class.DebugView GHC.Unit.Types.UnitId
+ GHC.Debugger.Utils.Orphans: instance GHC.Debugger.View.Class.DebugView Language.Haskell.Syntax.Module.Name.ModuleName
- GHC.Debugger.Breakpoint: clearBreakpoints :: Maybe FilePath -> Debugger ()
+ GHC.Debugger.Breakpoint: clearBreakpoints :: Maybe AbsFilePath -> Debugger ()
- GHC.Debugger.Breakpoint: findBreakpoint :: ModSummary -> Int -> Maybe Int -> Debugger (Maybe (Int, RealSrcSpan))
+ GHC.Debugger.Breakpoint: findBreakpoint :: Module -> Int -> Maybe Int -> Debugger (Maybe (Int, RealSrcSpan))
- GHC.Debugger.Breakpoint: getActiveBreakpoints :: Maybe FilePath -> Debugger [InternalBreakpointId]
+ GHC.Debugger.Breakpoint: getActiveBreakpoints :: Maybe AbsFilePath -> Debugger [InternalBreakpointId]
- GHC.Debugger.Breakpoint: getModuleByPath :: FilePath -> Debugger (Either SDoc ModSummary)
+ GHC.Debugger.Breakpoint: getModuleByPath :: AbsFilePath -> Debugger (Either SDoc ModuleNodeInfo)
- GHC.Debugger.Interface.Messages: ClearModBreakpoints :: FilePath -> Command
+ GHC.Debugger.Interface.Messages: ClearModBreakpoints :: AbsFilePath -> Command
- GHC.Debugger.Interface.Messages: DbgStackFrame :: String -> SourceSpan -> Maybe InternalBreakpointId -> DbgStackFrame
+ GHC.Debugger.Interface.Messages: DbgStackFrame :: String -> SourceSpan -> Maybe InternalBreakpointId -> Maybe (DbgStackFrameBCOArgs ForeignRef) -> DbgStackFrame
- GHC.Debugger.Interface.Messages: DebugExecution :: EntryPoint -> FilePath -> [String] -> Command
+ GHC.Debugger.Interface.Messages: DebugExecution :: EntryPoint -> AbsFilePath -> [String] -> Command
- GHC.Debugger.Interface.Messages: ModuleBreak :: FilePath -> Int -> Maybe Int -> Breakpoint
+ GHC.Debugger.Interface.Messages: ModuleBreak :: AbsFilePath -> Int -> Maybe Int -> Breakpoint
- GHC.Debugger.Interface.Messages: SourceSpan :: FilePath -> Int -> Int -> Int -> Int -> SourceSpan
+ GHC.Debugger.Interface.Messages: SourceSpan :: AbsFilePath -> Int -> Int -> Int -> Int -> SourceSpan
- GHC.Debugger.Interface.Messages: [entryFile] :: Command -> FilePath
+ GHC.Debugger.Interface.Messages: [entryFile] :: Command -> AbsFilePath
- GHC.Debugger.Interface.Messages: [file] :: SourceSpan -> FilePath
+ GHC.Debugger.Interface.Messages: [file] :: SourceSpan -> AbsFilePath
- GHC.Debugger.Interface.Messages: [path] :: Breakpoint -> FilePath
+ GHC.Debugger.Interface.Messages: [path] :: Breakpoint -> AbsFilePath
- GHC.Debugger.Interface.Messages: srcLocToSourceSpan :: SrcLoc -> SourceSpan
+ GHC.Debugger.Interface.Messages: srcLocToSourceSpan :: AbsFilePath -> SrcLoc -> SourceSpan
- GHC.Debugger.Monad: RunDebuggerSettings :: Bool -> Bool -> Bool -> Either StdStream PortNumber -> RunDebuggerSettings
+ GHC.Debugger.Monad: RunDebuggerSettings :: Bool -> Bool -> InterpreterSettings -> RunDebuggerSettings
- GHC.Debugger.Monad: findHsDebuggerViewUnitId :: ModuleGraph -> Ghc (Maybe UnitId)
+ GHC.Debugger.Monad: findHsDebuggerViewUnitId :: Ghc (Maybe UnitId)
- GHC.Debugger.Monad: getAllLoadedModules :: GhcMonad m => m [ModSummary]
+ GHC.Debugger.Monad: getAllLoadedModules :: GhcMonad m => m [ModuleNodeInfo]
- GHC.Debugger.Monad: runDebugger :: LogAction IO DebuggerLog -> FilePath -> FilePath -> FilePath -> [String] -> [String] -> [String] -> FilePath -> RunDebuggerSettings -> Debugger a -> IO a
+ GHC.Debugger.Monad: runDebugger :: LogAction IO DebuggerLog -> DebugRunner Ghc a -> RunDebuggerSettings -> Debugger a -> IO a
- GHC.Debugger.Run: debugExecution :: FilePath -> EntryPoint -> [String] -> Debugger EvalResult
+ GHC.Debugger.Run: debugExecution :: AbsFilePath -> EntryPoint -> [String] -> Debugger EvalResult
- GHC.Debugger.Runtime.Thread.Stack: StackFrameAnnotation :: Maybe SrcLoc -> String -> StackFrameInfo
+ GHC.Debugger.Runtime.Thread.Stack: StackFrameAnnotation :: Maybe SrcLoc -> String -> StackFrameInfo (ref :: Type -> Type)
- GHC.Debugger.Runtime.Thread.Stack: StackFrameBreakpointInfo :: InternalBreakpointId -> StackFrameInfo
+ GHC.Debugger.Runtime.Thread.Stack: StackFrameBreakpointInfo :: InternalBreakpointId -> DbgStackFrameBCOArgs ref -> StackFrameInfo (ref :: Type -> Type)
- GHC.Debugger.Runtime.Thread.Stack: StackFrameIPEInfo :: InfoProv -> StackFrameInfo
+ GHC.Debugger.Runtime.Thread.Stack: StackFrameIPEInfo :: InfoProv -> StackFrameInfo (ref :: Type -> Type)
- GHC.Debugger.Runtime.Thread.Stack: data StackFrameInfo
+ GHC.Debugger.Runtime.Thread.Stack: data StackFrameInfo (ref :: Type -> Type)
- GHC.Debugger.Runtime.Thread.Stack: getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [StackFrameInfo]
+ GHC.Debugger.Runtime.Thread.Stack: getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [StackFrameInfo ForeignRef]
- GHC.Debugger.Session: validateUnitsWays :: NonEmpty (DynFlags, [Target]) -> IO Ways
+ GHC.Debugger.Session: validateUnitsWays :: NonEmpty DynFlags -> IO Ways
- GHC.Debugger.Utils: realSrcSpanToSourceSpan :: RealSrcSpan -> SourceSpan
+ GHC.Debugger.Utils: realSrcSpanToSourceSpan :: AbsFilePath -> RealSrcSpan -> SourceSpan
- GHC.Debugger.Utils: srcSpanStringToSourceSpan :: String -> Either String SourceSpan
+ GHC.Debugger.Utils: srcSpanStringToSourceSpan :: AbsFilePath -> String -> Either String SourceSpan
Files
- CHANGELOG.md +13/−0
- README.md +25/−14
- cbits/stack.c +312/−0
- cbits/stack.h +2/−0
- haskell-debugger.cabal +87/−23
- haskell-debugger/GHC/Debugger/Breakpoint.hs +33/−31
- haskell-debugger/GHC/Debugger/Debuggee.hs +247/−0
- haskell-debugger/GHC/Debugger/Interface/Messages.hs +61/−10
- haskell-debugger/GHC/Debugger/Monad.hs +424/−446
- haskell-debugger/GHC/Debugger/Run.hs +46/−49
- haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs +25/−2
- haskell-debugger/GHC/Debugger/Runtime/FFIInspect.hs +17/−0
- haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs +22/−4
- haskell-debugger/GHC/Debugger/Runtime/Internal.hs +55/−0
- haskell-debugger/GHC/Debugger/Runtime/Interpreter.hs +18/−3
- haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs +52/−44
- haskell-debugger/GHC/Debugger/Runtime/Interpreter/Legacy.hs +465/−0
- haskell-debugger/GHC/Debugger/Runtime/Interpreter/Types.hs +31/−0
- haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs +12/−1
- haskell-debugger/GHC/Debugger/Runtime/Thread.hs +7/−79
- haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs +5/−204
- haskell-debugger/GHC/Debugger/Session.hs +301/−77
- haskell-debugger/GHC/Debugger/Session/Builtin.hs +206/−13
- haskell-debugger/GHC/Debugger/Session/Interactive.hs +6/−85
- haskell-debugger/GHC/Debugger/Stopped.hs +22/−9
- haskell-debugger/GHC/Debugger/Stopped/Exception.hs +3/−119
- haskell-debugger/GHC/Debugger/Stopped/Frames.hs +236/−0
- haskell-debugger/GHC/Debugger/Stopped/Variables.hs +7/−1
- haskell-debugger/GHC/Debugger/Utils.hs +8/−6
- haskell-debugger/GHC/Debugger/Utils/Orphans.hs +8/−0
- hdb-dap/Development/Debug/Adapter.hs +79/−0
- hdb-dap/Development/Debug/Adapter/Breakpoints.hs +163/−0
- hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs +236/−0
- hdb-dap/Development/Debug/Adapter/Evaluation.hs +134/−0
- hdb-dap/Development/Debug/Adapter/ExceptionInfo.hs +65/−0
- hdb-dap/Development/Debug/Adapter/Exit.hs +45/−0
- hdb-dap/Development/Debug/Adapter/Exit/Helpers.hs +47/−0
- hdb-dap/Development/Debug/Adapter/Handles.hs +136/−0
- hdb-dap/Development/Debug/Adapter/Init.hs +296/−0
- hdb-dap/Development/Debug/Adapter/Interface.hs +40/−0
- hdb-dap/Development/Debug/Adapter/Output.hs +55/−0
- hdb-dap/Development/Debug/Adapter/Proxy.hs +216/−0
- hdb-dap/Development/Debug/Adapter/Server.hs +331/−0
- hdb-dap/Development/Debug/Adapter/Stepping.hs +45/−0
- hdb-dap/Development/Debug/Adapter/Stopped.hs +181/−0
- hdb-dap/Development/Debug/Session/Setup.hs +404/−0
- hdb/Development/Debug/Adapter.hs +0/−123
- hdb/Development/Debug/Adapter/Breakpoints.hs +0/−164
- hdb/Development/Debug/Adapter/Evaluation.hs +0/−134
- hdb/Development/Debug/Adapter/ExceptionInfo.hs +0/−65
- hdb/Development/Debug/Adapter/Exit.hs +0/−47
- hdb/Development/Debug/Adapter/Exit/Helpers.hs +0/−47
- hdb/Development/Debug/Adapter/Handles.hs +0/−136
- hdb/Development/Debug/Adapter/Init.hs +0/−431
- hdb/Development/Debug/Adapter/Interface.hs +0/−36
- hdb/Development/Debug/Adapter/Output.hs +0/−55
- hdb/Development/Debug/Adapter/Proxy.hs +0/−201
- hdb/Development/Debug/Adapter/Stepping.hs +0/−45
- hdb/Development/Debug/Adapter/Stopped.hs +0/−181
- hdb/Development/Debug/Interactive.hs +23/−19
- hdb/Development/Debug/Options.hs +3/−0
- hdb/Development/Debug/Options/Parser.hs +8/−0
- hdb/Development/Debug/Session/Setup.hs +0/−357
- hdb/Main.hs +42/−286
- test/golden/T130/T130.ghc-1001.hdb-stdout +1/−0
- test/golden/T130/T130.ghc-914.hdb-stdout +0/−1
- test/golden/T130/T130.hdb-test +1/−1
- test/golden/T130b/T130b.ghc-1001.hdb-stdout +5/−0
- test/golden/T130b/T130b.ghc-914.hdb-stdout +2/−1
- test/golden/T130c/T130c.ghc-1001.hdb-stdout +7/−0
- test/golden/T135/T135.ghc-1001.hdb-stdout +12/−0
- test/golden/T135/T135.ghc-914.hdb-stdout +1/−2
- test/golden/T135/hie.yaml +1/−2
- test/golden/T154/T154.external.ghc-1001.hdb-stdout +4/−0
- test/golden/T154/T154.external.ghc-914.hdb-stdout +4/−0
- test/golden/T154/T154.external.ghc-915.hdb-stdout +5/−0
- test/golden/T154/T154.external.hdb-test +3/−0
- test/golden/T154/T154.ghc-914.hdb-stdout +0/−5
- test/golden/T154/T154.ghc-915.hdb-stdout +0/−5
- test/golden/T154/T154.hdb-test +0/−3
- test/golden/T159/T159.ghc-1001.hdb-stdout +5/−0
- test/golden/T159/T159.ghc-914.hdb-stdout +2/−3
- test/golden/T159b/T159b.ghc-1001.hdb-stdout +5/−0
- test/golden/T159b/T159b.ghc-914.hdb-stdout +5/−0
- test/golden/T159b/T159b.ghc-915.hdb-stdout +6/−0
- test/golden/T159b/T159b.hdb-stdin +3/−0
- test/golden/T159b/T159b.hdb-test +3/−0
- test/golden/T159b/T159b.hs +12/−0
- test/golden/T159b/hie.yaml +8/−0
- test/golden/T164/T164.ghc-1001.hdb-stdout +24/−0
- test/golden/T164/T164.ghc-914.hdb-stdout +1/−2
- test/golden/T166/T166.ghc-1001.hdb-stdout +16/−0
- test/golden/T166/T166.ghc-914.hdb-stdout +3/−4
- test/golden/T169/T169.ghc-914.hdb-stdout +0/−5
- test/golden/T169/T169.ghc-915.hdb-stdout +0/−5
- test/golden/T169/T169.hdb-test +0/−3
- test/golden/T169/T169.internal.ghc-1001.hdb-stdout +4/−0
- test/golden/T169/T169.internal.ghc-914.hdb-stdout +4/−0
- test/golden/T169/T169.internal.ghc-915.hdb-stdout +5/−0
- test/golden/T169/T169.internal.hdb-test +3/−0
- test/golden/T169/T169b.ghc-1001.hdb-stdout +7/−0
- test/golden/T169/T169b.ghc-914.hdb-stdout +1/−4
- test/golden/T169/T169b.hdb-stdin +1/−1
- test/golden/T169/T169b.hdb-test +3/−1
- test/golden/T169/T169c.external.ghc-1001.hdb-stdout +4/−0
- test/golden/T169/T169c.external.ghc-914.hdb-stdout +1/−2
- test/golden/T169/T169c.internal.ghc-1001.hdb-stdout +4/−0
- test/golden/T169/T169c.internal.ghc-914.hdb-stdout +1/−2
- test/golden/T217/T217.ghc-1001.hdb-stdout +11/−0
- test/golden/T217/T217.ghc-914.hdb-stdout +3/−4
- test/golden/T218/T218.ghc-1001.hdb-stdout +11/−0
- test/golden/T218/T218.ghc-914.hdb-stdout +1/−2
- test/golden/T225/T225.ghc-1001.hdb-stdout +5/−0
- test/golden/T225/T225.ghc-914.hdb-stdout +1/−2
- test/golden/T225b/T225b.ghc-1001.hdb-stdout +7/−0
- test/golden/T225b/T225b.ghc-914.hdb-stdout +3/−5
- test/golden/T234/T234.ghc-1001.hdb-stdout +7/−0
- test/golden/T234b/T234b.ghc-1001.hdb-stdout +7/−0
- test/golden/T237/T237.ghc-1001.hdb-stdout +16/−0
- test/golden/T237/hie.yaml +5/−0
- test/golden/T237b/T237.cabal +24/−0
- test/golden/T237b/T237.ghc-1001.hdb-stdout +16/−0
- test/golden/T237b/T237.ghc-914.hdb-stdout +16/−0
- test/golden/T237b/T237.hdb-stdin +3/−0
- test/golden/T237b/T237b.ghc-1001.hdb-stdout +17/−0
- test/golden/T237b/T237b.ghc-914.hdb-stdout +17/−0
- test/golden/T237b/T237b.hdb-test +1/−0
- test/golden/T237b/app/Main.hs +15/−0
- test/golden/T237b/hie.yaml +3/−0
- test/golden/T237b/lib/MyType.hs +11/−0
- test/golden/T239/T239.fails-239.ghc-1001.hdb-stdout +10/−0
- test/golden/T239/T239.ghc-1001.hdb-stdout +11/−0
- test/golden/T242/T242.ghc-1001.hdb-stdout +13/−0
- test/golden/T242/T242.ghc-914.hdb-stdout +1/−2
- test/golden/T283/T283.ghc-1001.hdb-stdout +9/−0
- test/golden/T283/T283.ghc-914.hdb-stdout +1/−2
- test/golden/T358/T358.ghc-1001.hdb-stdout +1/−0
- test/golden/T358/T358.ghc-914.hdb-stdout +1/−0
- test/golden/T358/T358.hdb-test +5/−0
- test/golden/T61/T61.ghc-1001.hdb-stdout +4/−0
- test/golden/T61/T61.ghc-914.hdb-stdout +1/−2
- test/golden/T79/T79.ghc-1001.hdb-stdout +6/−0
- test/golden/T79/T79.ghc-914.hdb-stdout +2/−10
- test/golden/T79/T79.ghc-915.hdb-stdout +1/−8
- test/golden/T79/T79.hdb-test +3/−1
- test/golden/T83/T83.ghc-1001.hdb-stdout +4/−0
- test/golden/T83/T83.ghc-914.hdb-stdout +1/−2
- test/golden/exceptions-multiple/exceptions-multiple.ghc-1001.hdb-stdout +22/−0
- test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout +1/−2
- test/golden/exceptions-uncaught/exceptions-uncaught.ghc-1001.hdb-stdout +26/−0
- test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout +1/−2
- test/golden/exceptions/exceptions.ghc-1001.hdb-stdout +12/−0
- test/golden/exceptions/exceptions.ghc-914.hdb-stdout +1/−2
- test/golden/self-debug-cli/cabal.project +1/−0
- test/golden/self-debug-cli/debuggee.cabal +20/−0
- test/golden/self-debug-cli/hie.yaml +3/−0
- test/golden/self-debug-cli/self-debug-cli.hdb-stdin +2/−1
- test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-1001.hdb-stdout +5/−0
- test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-914.hdb-stdout +1/−0
- test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test +10/−4
- test/golden/standalone-multi-module/standalone-multi-module.ghc-1001.hdb-stdout +8/−0
- test/golden/standalone-multi-module/standalone-multi-module.ghc-914.hdb-stdout +3/−4
- test/haskell/Main.hs +6/−2
- test/haskell/Test/DAP.hs +10/−2
- test/haskell/Test/Integration/Basic.hs +2/−1
- test/haskell/Test/Integration/Evaluate.hs +5/−3
- test/haskell/Test/Integration/MultiHomeUnit.hs +14/−12
- test/haskell/Test/Integration/SelfDebug.hs +5/−3
- test/haskell/Test/Integration/StackTrace.hs +3/−3
- test/haskell/Test/Integration/Variables.hs +75/−0
- test/haskell/Test/Utils.hs +36/−10
- test/integration/T107a/hie.yaml +1/−1
- test/integration/T159/T159.cabal +0/−1
- test/integration/T160/Main.hs +29/−0
- test/integration/T160/T160-tmp.cabal +19/−0
- test/integration/T160/X.hs +31/−0
- test/integration/T160/cabal.project +1/−0
- test/integration/T160/hie.yaml +1/−0
- test/integration/T365/GHC/Exts/Heap.hs +3/−0
- test/integration/T365/Main.hs +29/−0
- test/integration/T365/T160-tmp.cabal +19/−0
- test/integration/T365/X.hs +31/−0
- test/integration/T365/cabal.project +1/−0
- test/integration/T365/hie.yaml +1/−0
- test/integration/T38/bar/app/Main.hs +9/−0
- test/integration/T38/bar/bar.cabal +20/−0
- test/integration/T38/bar/src/Bar.hs +10/−0
- test/integration/T38/cabal.project +3/−0
- test/integration/T38/foo/foo.cabal +10/−0
- test/integration/T38/foo/src/Foo.hs +6/−0
- test/integration/T47f/Main.hs +12/−0
- test/integration/T47f/T47f.cabal +17/−0
- test/integration/cabal1/app/Main.hs +1/−1
- test/integration/simple/Main.hs +1/−1
CHANGELOG.md view
@@ -1,5 +1,18 @@ # Revision history for haskell-debugger +## 0.14.0.0 -- 2026-09-17++* Added binary distributions intended for on Linux and macOS.+* Made debug session survive errors in non-essential operations.+* Added support to visualize variables bound in earlier stack frames.+* Improved reporting of session loading and other errors.+* Switched to loading all components from cradle, from `hie-bios-0.20+`+* Added support for Stack annotations with optional source locations.+* Added support for GHC 10.1+* Removed outdated 'install using stack' README section.+* Fixed unintended loudness of `hdb server -v0`.+* Restricted debug console to inner scope of module stopped at.+ ## 0.13.1.0 -- 2026-04-28 * Fix critical bug which caused certain breakpoints to be overwritten by or
README.md view
@@ -1,3 +1,7 @@+<p align="center">+ <img src="logo.svg" alt="Haskell Debugger logo" width="320" />+</p>+ # Haskell Debugger We are working on a first class debugger for Haskell!@@ -27,6 +31,27 @@ PATH=/path/to/ghc-dir:$PATH code /path/to/proj ``` +## Prebuilt release binaries++The `hdb-<version>-<arch>.tar.gz` bindists attached to [GitHub+Releases](https://github.com/well-typed/haskell-debugger/releases) unpack into+a self-contained folder:++```+hdb-<version>-<arch>/+ hdb # wrapper script -- put THIS on PATH, not bin/hdb+ bin/hdb # the real executable+ lib/* # bundled dynamic dependencies+```++The top-level `hdb` is a wrapper (modeled on+[`haskell-language-server`'s](https://github.com/haskell/haskell-language-server/blob/master/bindist/wrapper.in))+that locates a GHC installation on your machine matching the version and boot+library ABIs `hdb` was built against, sets up the library search path, and+then execs the real binary in `bin/`. If it can't find a matching GHC it will+print an error explaining how to install one (e.g. via `ghcup install ghc+<version> --set`); set `HDB_WRAPPER_DEBUG=1` for more detail.+ # Usage To use the debugger in VSCode, select the debugger tab, select Haskell Debugger,@@ -156,20 +181,6 @@ ``` cabal build -w /path/to/ghc-9.14 exe:hdb-```--## Build and install `hdb` (using Stack)--On non-Windows operating systems:--```-stack install haskell-debugger-```--On Windows:--```-stack -w stack-windows.yaml install haskell-debugger ``` ## Build VS Code extension (using Nix)
+ cbits/stack.c view
@@ -0,0 +1,312 @@+/* -----------------------------------------------------------------------------+ *+ * Memory layout of continuation frames vs. AP_STACK closures.+ *+ * ---------------------------------------------------------------------------*/++#include "Rts.h"+#include <stddef.h>+#include <string.h>++/*+Note [Ask the RTS for memory layout of AP_STACK]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The bytecode compiler in ghc currently assigns to each breakpoint captured variable+an offset(free_var_i_AP_STACK_offset) to read that variable off of a pointer into+an AP_STACK constructed when we stop at that breakpoint.++However, when we want to read the variables of frames from breakpoints of other+frames on the stack, that offset can't be used to index other frame's free variables,+because it is meant specifically as an offset into the AP_STACK constructed when+we stop at a breakpoint.++While ghc doesn't provide more information regarding a variable offset into a frame's+free vars on the stack, rather than into the stopped-at-breakpoint-AP_STACK, we+reverse engineer the offset of the frame's payload into AP_STACK (bco_args_1_AP_STACK_offset)+so that on the Haskell side we can calculate the i-th free var index by+`(free_var_i_AP_STACK_offset - bco_args_1_AP_STACK_offset)`.++There are two main cases we need to cover to reverse engineer the offset into+a frame's variables correctly:++ - The frame is a function or case continuation (type: RET_BCO),+ then the offset we want is fixed.+ - The frame is a case continuation for an unboxed tuple-scrutinee+ (type: RET_BCO, header == &stg_ctoi_t[N]_info), then the offset we want+ depends on the tuple size which is available from the frame.++In both cases we manage to rely on the RTS to do most size calculations for us.++## RET_BCO frames reminder++RET_BCO frames all have the same general shape+```+bco_arg_M+...+bco_arg_2+bco_arg_1+&bco+&stg_$name_info+```+where the `bco_arg_i` words are generally referred as the `bitmap`+because their size and pointerness is described by a bitmap object inside `bco`.+The bitmap allows GC and other code to process them uniformly.++## Plan+What we do is:+ 1. Identify which RET_BCO frame we are dealing with by the InfoTable pointer in it.+ 2. Predict which kind of return frame it would have if we stop there.+ 3. Call `stack_frame_sizeW` on a stub of that frame.+ - Here we rely on `stack_frame_sizeW` only looking at the first two words.+ 4. Add 2 to account for the offset of the bitmap words into the continuation frame itself.++## Complications++### `stg_apply_interp`++This is the "apply BCO as function" frame.++In this case we skip step 3 because there is+no return frame stored for this frame.++### `stg_ctoi_t[N]`++These are the case continuation frames for unboxed tuples,+note the `N` is not the size of the tuple.++Their shape is+```+.. free vars ..+&tuple_bco+call_info -- bco_arg_0+&bco+&stg_ctoi_t[N]_info+```+with return frames of shape+```+tuple_data_M+...+tuple_data_2+tuple_data_1+call_info+&tuple_bco+&stg_ret_t[N]_info+```+these are RET_BCO frames too, so their size is given+by the bitmap info in the tuple_bco object, which+we then need to include in the stub we create in step 3.+As shown above though, &tuple_bco is stored in the+stg_ctoi_t[N] frame we started with, so we have all we need.++Note that in the `ctoi` frames both call_info and &tuple_bco+are part of the frame's bitmap like everything above them,+so those words do not affect offset calculations.++*/++#define BCO_FRAME_NOT_BCO 0+#define BCO_FRAME_UNKNOWN 1+#define BCO_FRAME_APPLY_INTERP 2+#define BCO_FRAME_CTOI_R1P 3+#define BCO_FRAME_CTOI_R1N 4+#define BCO_FRAME_CTOI_F1 5+#define BCO_FRAME_CTOI_D1 6+#define BCO_FRAME_CTOI_L1 7+#define BCO_FRAME_CTOI_V 8+#define BCO_FRAME_CTOI_T 9++#define BCO_FRAME_CTOI_TN_BASE 100+#define BCO_FRAME_CTOI_TN_MAX 62 /* stg_ctoi_t62 is the last in 9.14 */+#define BCO_FRAME_CTOI_TN(n) (BCO_FRAME_CTOI_TN_BASE + (n))++#define BCO_FRAME_IS_CTOI_TN(k) \+ ((k) >= BCO_FRAME_CTOI_TN_BASE && \+ (k) <= BCO_FRAME_CTOI_TN_BASE + BCO_FRAME_CTOI_TN_MAX)++// BcoFrameEntry represents continuation/apply frames we care about.+typedef struct {+ const void *info; // the stg_$name_info pointer of the frame.+ StgWord kind; // enum tag, only used for error reporting atm.+ const char *name; // readable name for debugging+ const void *return_info; // expected return frame info pointer (e.g. stg_ret_v_info, stg_ret_t_info)+ StgWord return_bco_offset; // If the return frame is of type RET_BCO as well, where to find its (StgBCO*) in this frame. 0 otherwise. e.g. tells you where `tuple_bco` is in `stg_ctoi_t[N]` frames.+} BcoFrameEntry;+++#define ENT_BCO(sym, k, r, o) { &sym##_info, (k), #sym, r, o },+#define ENT(sym, k, r) ENT_BCO(sym, k, r, 0)+#define ENT_T(n) { &stg_ctoi_t##n##_info, BCO_FRAME_CTOI_TN(n), "stg_ctoi_t" #n, &stg_ret_t_info, 3 },++// Mapping from continuation/apply frame to its return frame (info pointers) and other metadata.+static const BcoFrameEntry bco_frame_table[] = {+ ENT(stg_apply_interp, BCO_FRAME_APPLY_INTERP, NULL) //frame used to suspend run_BCO, not to wait for a return.+ ENT(stg_ctoi_R1p, BCO_FRAME_CTOI_R1P, &stg_ret_p_info)+ ENT(stg_ctoi_R1n, BCO_FRAME_CTOI_R1N, &stg_ret_n_info)+ ENT(stg_ctoi_F1, BCO_FRAME_CTOI_F1, &stg_ret_f_info)+ ENT(stg_ctoi_D1, BCO_FRAME_CTOI_D1, &stg_ret_d_info)+ ENT(stg_ctoi_L1, BCO_FRAME_CTOI_L1, &stg_ret_l_info)+ ENT(stg_ctoi_V, BCO_FRAME_CTOI_V, &stg_ret_v_info)+ ENT_T(0) ENT_T(1) ENT_T(2) ENT_T(3) ENT_T(4)+ ENT_T(5) ENT_T(6) ENT_T(7) ENT_T(8)+#if FEW_TUPLE_FRAMES+ ENT_BCO(stg_ctoi_t, BCO_FRAME_CTOI_T, &stg_ret_t_info, 3)+#else+ ENT_T(9)+ ENT_T(10) ENT_T(11) ENT_T(12) ENT_T(13) ENT_T(14)+ ENT_T(15) ENT_T(16) ENT_T(17) ENT_T(18) ENT_T(19)+ ENT_T(20) ENT_T(21) ENT_T(22) ENT_T(23) ENT_T(24)+ ENT_T(25) ENT_T(26) ENT_T(27) ENT_T(28) ENT_T(29)+ ENT_T(30) ENT_T(31) ENT_T(32) ENT_T(33) ENT_T(34)+ ENT_T(35) ENT_T(36) ENT_T(37) ENT_T(38) ENT_T(39)+ ENT_T(40) ENT_T(41) ENT_T(42) ENT_T(43) ENT_T(44)+ ENT_T(45) ENT_T(46) ENT_T(47) ENT_T(48) ENT_T(49)+ ENT_T(50) ENT_T(51) ENT_T(52) ENT_T(53) ENT_T(54)+ ENT_T(55) ENT_T(56) ENT_T(57) ENT_T(58) ENT_T(59)+ ENT_T(60) ENT_T(61) ENT_T(62)+#endif+};++#undef ENT_T+#undef ENT++#define BCO_FRAME_TABLE_LEN \+ (sizeof(bco_frame_table) / sizeof(bco_frame_table[0]))++// Checks the frames listed are actually RET_BCO and other consistency properties.+bool stack_bco_frame_selftest(void)+{+ bool flag = true;+ for (size_t i = 0; i < BCO_FRAME_TABLE_LEN; i++) {+ const StgInfoTable *it =+ INFO_PTR_TO_STRUCT((const StgInfoTable *)bco_frame_table[i].info);+ if (it->type != RET_BCO) {+ errorBelch("stack_bco_frame_selftest: %s has closure type %d, not RET_BCO\n",+ bco_frame_table[i].name, (int)it->type);+ flag = false;+ }++ if (bco_frame_table[i].return_info == NULL && bco_frame_table[i].return_bco_offset != 0) {+ errorBelch("stack_bco_frame_selftest: return frame of %s is NULL, but offset is %d not 0\n",+ bco_frame_table[i].name, (int)bco_frame_table[i].return_bco_offset);+ flag = false;++ } else if (bco_frame_table[i].return_info != NULL){+ const StgInfoTable *return_it =+ INFO_PTR_TO_STRUCT((const StgInfoTable *)bco_frame_table[i].return_info);++ if (return_it->type == RET_BCO &&+ bco_frame_table[i].return_bco_offset == 0) {+ errorBelch("stack_bco_frame_selftest: return frame of %s has closure type RET_BCO but offset 0\n",+ bco_frame_table[i].name);+ flag = false;++ } else if (return_it->type != RET_BCO &&+ bco_frame_table[i].return_bco_offset != 0) {+ errorBelch("stack_bco_frame_selftest: return frame of %s has closure type %d, not RET_BCO, but offset %d instead of 0\n",+ bco_frame_table[i].name, (int)return_it->type,+ (int)bco_frame_table[i].return_bco_offset);+ flag = false;+ }}+ for (size_t j = 0; j < i; j++) {+ if (bco_frame_table[i].info == bco_frame_table[j].info) {+ errorBelch("stack_bco_frame_selftest: %s and %s alias\n",+ bco_frame_table[i].name, bco_frame_table[j].name);+ flag = false;+ }+ }+ }+ return flag;+}++// Returns BcoFrameEntry for given stack frame.+// In can be of the entries in bco_frame_table or one of the BCO_FRAME_NOT_BCO, BCO_FRAME_UNKNOWN kinds.+BcoFrameEntry stack_bco_frame_entry(const StgClosure *frame)+{+ const StgInfoTable *info = frame->header.info;++ if (get_itbl(frame)->type != RET_BCO) {+ return (BcoFrameEntry){NULL, BCO_FRAME_NOT_BCO, "not_bco", NULL, 0};+ }++ for (size_t i = 0; i < BCO_FRAME_TABLE_LEN; i++) {+ if ((const void *)info == bco_frame_table[i].info) {+ IF_DEBUG(sanity,debugBelch("%s\n",bco_frame_table[i].name););+ return bco_frame_table[i];+ }+ }+ return (BcoFrameEntry){NULL, BCO_FRAME_UNKNOWN, "unknown", NULL, 0};+}++// Returns offset to bco_args_0 in the expected AP_STACK closure,+// or -1 if the stack frame cannot be identified.+//+// See Note [Ask the RTS for memory layout of AP_STACK].+StgInt bco_frame_args_offset(StgClosure * frame)+{+ BcoFrameEntry frame_entry = stack_bco_frame_entry(frame);++ switch (frame_entry.kind){+ case BCO_FRAME_NOT_BCO:+ case BCO_FRAME_UNKNOWN:+ return -1;+ default: {+ const void * return_frame_info = frame_entry.return_info;+ if (return_frame_info == NULL){+ // No return frame used (e.g. stg_apply_interp), so constant offset.+ return 2;+ } else {+ StgBCO * return_bco;++ if(frame_entry.return_bco_offset > 0){+ return_bco = (StgBCO *)((StgPtr)frame)[frame_entry.return_bco_offset];+ }+ else{+ return_bco = NULL;+ }+ // We create a mocked return frame `stub` that contains the right header.+ // The second word is only relevant if the return frame is RET_BCO too (i.e. stg_ret_t[N] ones), and will be ignored for the others.+ StgWord stub[2] = { (StgWord)return_frame_info, (StgWord)return_bco };+ return (StgInt)stack_frame_sizeW((StgClosure *)stub) + 2;+ }+ }+ }++}+++StgInt bco_args_offset(StgStack* stack, StgWord frame_index){+ IF_DEBUG(sanity,+ debugBelch("ENTERED bco_args_offset=%" FMT_Word "\n", index);+ stack_bco_frame_selftest();+ );+ StgPtr sp = stack->sp;+ StgPtr spBottom = stack->stack + stack->stack_size;++ StgWord i = 0;+ for (;i < frame_index && sp < spBottom;i++) {+ ASSERT(sp >= stack->stack && sp < spBottom);+ const StgInfoTable *info = get_itbl((StgClosure *)sp);+ IF_DEBUG(sanity,+ debugBelch("i=%" FMT_Word " sp=%p bottom=%p type=%d size=%lu\n",+ i, sp, spBottom, (int)info->type,+ (unsigned long)stack_frame_sizeW((StgClosure *)sp));+ );+ if (info->type == UNDERFLOW_FRAME) {+ stack = ((StgUnderflowFrame *)sp)->next_chunk;+ sp = stack->sp;+ spBottom = stack->stack + stack->stack_size;+ continue; /* or restructure as a do/while */+ }+ if (info->type == STOP_FRAME) break;+ sp += stack_frame_sizeW((StgClosure *)sp);+ }++ if(i != frame_index){+ IF_DEBUG(sanity,debugBelch("bco_args_offset: bottomed out i=%" FMT_Word "index=%" FMT_Word "\n",i,index););+ return -1;+ } else {+ IF_DEBUG(sanity,debugBelch("bco_args_offset: found frame\n"););+ return bco_frame_args_offset((StgClosure *)sp);+ }+}
+ cbits/stack.h view
@@ -0,0 +1,2 @@++int stack_test_ffi(int arg);
haskell-debugger.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.12 name: haskell-debugger-version: 0.13.1.0+version: 0.14.0.0 synopsis: A step-through debugger for GHC Haskell @@ -72,6 +72,16 @@ -- base >= 4.21 && < 5, -- Cabal-hooks >= 3.14 && < 3.18, +Flag hdb-dep+ description: Include hdb as build-tool-dependency of haskell-debugger-test. To be disabled by HLS so the project can get setup even when exe:hdb's build is broken.+ default: True+ manual: True++Flag testing+ description: Includes extra checks useful when running tests.+ default: False+ manual: True+ library import: warnings exposed-modules: GHC.Debugger,@@ -80,6 +90,7 @@ GHC.Debugger.Run, GHC.Debugger.Stopped, GHC.Debugger.Stopped.Exception,+ GHC.Debugger.Stopped.Frames, GHC.Debugger.Stopped.Variables, GHC.Debugger.Runtime,@@ -94,6 +105,8 @@ GHC.Debugger.Runtime.Compile, GHC.Debugger.Runtime.Compile.Cache, + GHC.Debugger.Runtime.FFIInspect,+ GHC.Debugger.Runtime.Term.Parser, GHC.Debugger.Runtime.Term.Key, @@ -101,29 +114,35 @@ GHC.Debugger.Runtime.Thread.Stack, GHC.Debugger.Runtime.Thread.Map, - GHC.Debugger.Runtime.Interpreter.Custom,+ GHC.Debugger.Runtime.Interpreter.Types, GHC.Debugger.Monad,+ GHC.Debugger.Debuggee, GHC.Debugger.Utils, GHC.Debugger.Utils.Orphans, GHC.Debugger.Session, GHC.Debugger.Session.Builtin, GHC.Debugger.Session.Interactive,- GHC.Debugger.Interface.Messages+ GHC.Debugger.Interface.Messages,+ GHC.Debugger.Runtime.Internal - if impl(ghc >= 9.15)+ if impl(ghc >= 9.14.2) exposed-modules:- GHC.Debugger.Runtime.Interpreter+ GHC.Debugger.Runtime.Interpreter,+ GHC.Debugger.Runtime.Interpreter.Custom + if impl(ghc < 9.14.2)+ exposed-modules:+ GHC.Debugger.Runtime.Interpreter.Legacy default-extensions: CPP build-depends: base >= 4.22 && < 5,- ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16,- ghc-boot-th >= 9.14 && < 9.16,- ghc-boot >= 9.14 && < 9.16,- ghc-experimental >= 9.1401 && < 9.1600,- ghc-heap >= 9.14 && < 9.16,+ ghc >= 9.14 && < 10.2, ghci >= 9.14 && < 10.2,+ ghc-boot-th >= 9.14 && < 10.2,+ ghc-boot >= 9.14 && < 10.2,+ ghc-experimental >= 9.1401 && < 10.2000,+ ghc-heap >= 9.14 && < 10.2, array >= 0.5.8 && < 0.6, containers >= 0.7 && < 0.9, mtl >= 2.3 && < 3,@@ -134,11 +153,11 @@ exceptions >= 0.10.9 && < 0.11, bytestring >= 0.12.1 && < 0.13, async >= 2.2.6 && < 2.3,- network >= 3.2.8,+ network >= 3.2.8 && < 3.3, cryptohash-sha1 >= 0.11.101.0 && < 0.12, base16-bytestring >= 1.0.2.0 && < 1.1, aeson >= 2.2.3 && < 2.3,- hie-bios >= 0.15 && < 0.20,+ hie-bios >= 0.15 && < 0.22, file-embed >= 0.0.16 && < 0.1, attoparsec >= 0.13 && < 0.15, time >= 1.14 && < 2,@@ -146,37 +165,81 @@ retry >= 0.9 && < 1, co-log-core >= 0.3.2.5 && < 0.4, - haskell-debugger-view >= 0.2 && < 1.0,+ haskell-debugger-view >= 0.2 && < 1, ghc-stack-annotations >=0.1 && <0.2,+ rts >= 1 && < 2, if !os(windows) build-depends: unix >= 2.8.6 && < 2.9,+ if impl(ghc>=10.1)+ -- from 10.1, we have much fewer stg_ctoi_t<N>_info hardcoded frames+ cc-options: -DFEW_TUPLE_FRAMES+ if flag(testing)+ cpp-options: -DTESTING hs-source-dirs: haskell-debugger+ include-dirs: cbits+ c-sources: cbits/stack.c+ install-includes: stack.h default-language: GHC2021 -executable hdb+library dap-server import: warnings- main-is: Main.hs- other-modules: Development.Debug.Adapter.Breakpoints,+ visibility: public+ exposed-modules: Development.Debug.Adapter.Breakpoints, Development.Debug.Adapter.Stepping, Development.Debug.Adapter.Stopped, Development.Debug.Adapter.Evaluation, Development.Debug.Adapter.ExceptionInfo,+ Development.Debug.Adapter.DAPDebuggee, Development.Debug.Adapter.Init, Development.Debug.Adapter.Interface, Development.Debug.Adapter.Output, Development.Debug.Adapter.Exit, Development.Debug.Adapter.Exit.Helpers, Development.Debug.Adapter.Handles,+ Development.Debug.Adapter.Server, Development.Debug.Adapter, Development.Debug.Adapter.Proxy, - Development.Debug.Interactive,- Development.Debug.Session.Setup,+ hs-source-dirs: hdb-dap+ default-language: GHC2021+ default-extensions: CPP+ build-depends:+ base, ghc, ghci,+ exceptions, aeson, bytestring,+ containers, filepath,+ process, mtl,+ unordered-containers >= 0.2.19 && < 0.3, + haskell-debugger,+ hie-bios >= 0.20 && < 0.22,+ prettyprinter ^>= 1.7.0,+ co-log-core >= 0.3.2.5 && < 0.4,+ implicit-hie ^>=0.1.4.0,+ transformers >= 0.6 && < 0.7,+ time,++ directory >= 1.3.9 && < 1.4,+ network >= 3.2.8 && < 3.3,+ network-run >= 0.4.4 && < 0.5,+ async >= 2.2.5 && < 2.3,+ text >= 2.1 && < 2.3,+ dap >= 0.7 && < 0.8,++ haskeline >= 0.8 && < 1,+ optparse-applicative >= 0.18 && < 0.20,+ uuid >= 1.3 && < 1.4,+ ghc-stack-annotations >=0.1 && <0.2,+ monad-control >= 1.0 && < 1.1,++executable hdb+ import: warnings+ main-is: Main.hs+ other-modules: Development.Debug.Interactive,+ Development.Debug.Options, Development.Debug.Options.Parser, @@ -190,6 +253,7 @@ unordered-containers >= 0.2.19 && < 0.3, haskell-debugger,+ haskell-debugger:dap-server, hie-bios, prettyprinter ^>= 1.7.0, co-log-core >= 0.3.2.5 && < 0.4,@@ -198,11 +262,11 @@ time, directory >= 1.3.9 && < 1.4,- network >= 3.2.8,- network-run >= 0.4.4,+ network >= 3.2.8 && < 3.3,+ network-run >= 0.4.4 && < 0.5, async >= 2.2.5 && < 2.3, text >= 2.1 && < 2.3,- dap >= 0.5 && < 0.6,+ dap >= 0.7 && < 0.8, haskeline >= 0.8 && < 1, optparse-applicative >= 0.18 && < 0.20,@@ -270,8 +334,8 @@ exceptions, retry, stm >= 2.5.3.1,-- build-tool-depends: haskell-debugger:hdb+ if flag(hdb-dep)+ build-tool-depends: haskell-debugger:hdb ghc-options: -threaded -- TODO: Investigate apparent race condition on windows if !os(windows)
haskell-debugger/GHC/Debugger/Breakpoint.hs view
@@ -9,10 +9,7 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bits (xor)-import Data.List (intercalate) import Data.IORef-import System.Directory-import System.FilePath import qualified Colog.Core as Logger import GHC@@ -21,9 +18,9 @@ import GHC.Driver.DynFlags as GHC import GHC.Driver.Env import GHC.Driver.Ppr as GHC+import GHC.Unit.Module.Graph 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@@ -34,6 +31,8 @@ import GHC.Debugger.Interface.Messages import qualified GHC.Debugger.Breakpoint.Map as BM import Data.Function+import System.Directory (getCurrentDirectory)+import GHC.Debugger.Session.Builtin (debuggerRuntimeInternalModName) -------------------------------------------------------------------------------- -- * Breakpoints@@ -42,7 +41,7 @@ -- | Remove all module breakpoints set on the given loaded module by path -- -- If the argument is @Nothing@, clear all function breakpoints instead.-clearBreakpoints :: Maybe FilePath -> Debugger ()+clearBreakpoints :: Maybe AbsFilePath -> Debugger () clearBreakpoints mfile = do -- It would be simpler to go to all loaded modules and disable all -- breakpoints for that module rather than keeping track,@@ -63,8 +62,9 @@ logSDoc Logger.Warning e return Nothing Right modl -> do- mbfnd <- findBreakpoint modl lineNum columnNum- return $ realSrcSpanToSourceSpan . snd <$> mbfnd+ mbfnd <- findBreakpoint (GHC.moduleNodeInfoModule modl) lineNum columnNum+ cwd <- mkAbsolute <$> liftIO getCurrentDirectory+ return $ realSrcSpanToSourceSpan cwd . snd <$> mbfnd getBreakpointsAt _ = error "unexpected getbreakpoints without ModuleBreak" -- | Set a breakpoint in this session@@ -80,19 +80,20 @@ logSDoc Logger.Warning e return BreakNotFound Right modl -> do- findBreakpoint modl lineNum columnNum >>= \case+ findBreakpoint (GHC.moduleNodeInfoModule modl) lineNum columnNum >>= \case Nothing -> return BreakNotFound Just (bix, spn) -> do- let bid = BreakpointId { bi_tick_mod = ms_mod modl+ let bid = BreakpointId { bi_tick_mod = GHC.moduleNodeInfoModule modl , bi_tick_index = bix } binfo = BreakpointInfo { bpInfoStatus = bp_status , bpInfoKind = ModuleBreakpointKind , bpInfoAction = action} (changed, ibis) <- registerBreakpoint bid binfo+ cwd <- mkAbsolute <$> liftIO getCurrentDirectory return $ BreakFound { changed = changed- , sourceSpan = realSrcSpanToSourceSpan spn+ , sourceSpan = realSrcSpanToSourceSpan cwd spn , breakId = ibis } setBreakpoint FunctionBreak{function} bp_status action = do@@ -112,9 +113,10 @@ , bpInfoKind = FunctionBreakpointKind , bpInfoAction = action} (changed, ibis) <- registerBreakpoint bid binfo+ cwd <- mkAbsolute <$> liftIO getCurrentDirectory return $ BreakFound { changed = changed- , sourceSpan = realSrcSpanToSourceSpan spn+ , sourceSpan = realSrcSpanToSourceSpan cwd spn , breakId = ibis } case maybe [] (findBreakForBind fun_str . imodBreaks_modBreaks) modBreaks of@@ -185,7 +187,7 @@ -- | 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 :: Maybe AbsFilePath -> Debugger [GHC.InternalBreakpointId] getActiveBreakpoints mfile = do bm <- asks activeBreakpoints >>= liftIO . readIORef case mfile of@@ -199,7 +201,7 @@ map fst <$> filterM (\(ibi, info) -> do ibi_occ_mod <- getBreakSourceMod ibi <$> readIModBreaks hug ibi & liftIO assert (bpInfoStatus info /= BreakpointDisabled) $- return (ibi_occ_mod == ms_mod ms)+ return (ibi_occ_mod == GHC.moduleNodeInfoModule ms) ) (BM.toList bm) Left e -> do logSDoc Logger.Warning e@@ -249,13 +251,14 @@ -- Braces are preserved if escaped with a backslash. Some unescaped braces are -- fine: opening braces in antiquotations and closing braces outside of them. logMessageExpression :: String -> String-logMessageExpression tmpl = apply "Prelude.putStrLn" $ apply "Prelude.concat" $ parts+logMessageExpression tmpl = apply (internal "putStrLn") [ apply (internal "concat") [ parts ]] where- apply f x = f ++ " ( " ++ x ++ " ) "- parts = listOf $ map renderPart (parseQC [] tmpl)- listOf xs = intercalate ": " . (++ ["[]"]) $ xs+ parts = mkList $ map renderPart (parseQC [] tmpl) renderPart (Literal s) = show s- renderPart (AntiQuote e) = apply "" e+ renderPart (AntiQuote e) = e+ mkList ys = foldr (\ x xs -> apply (internal "cons") [x,xs]) (internal "nil") ys+ internal x = GHC.moduleNameString debuggerRuntimeInternalModName ++ "." ++ x+ apply f xs = unwords $ f : map (\x -> "(" ++ x ++ ")") xs -- Taken from interpolatedstring-perl6 package data StringPart = Literal String | AntiQuote String deriving Show@@ -275,30 +278,29 @@ parseQC a ('{':xs) = Literal (reverse a) : unQC [] xs parseQC a (x:xs) = parseQC (x:a) xs - -- | Get a 'ModSummary' of a loaded module given its 'FilePath'-getModuleByPath :: FilePath -> Debugger (Either SDoc ModSummary)+getModuleByPath :: AbsFilePath -> Debugger (Either SDoc GHC.ModuleNodeInfo) 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 "."+ -- TODO (bytecode libraries): getAllLoadedModules skips any ModuleNodeFixed, and only includes modules from home units.+ -- get all loaded modules every time as the loaded modules may have changed+ lms <- getAllLoadedModulesWithPaths++ return $ case filter ((== unAbs path) . unAbs . fst) lms of+ [x] -> Right (snd x)+ [] -> Left $ text "No module matched" <+> text (unAbs path) <> text "." $$ text "Loaded modules:"- $$ vcat (map (text . msHsFilePath) lms)+ $$ vcat (map (text . unAbs . fst) 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+ xs -> Left $ text "Too many modules (" <> ppr (map (GHC.moduleNodeInfoModule . snd) xs) <> text ") matched" <+> text (unAbs 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 :: Module {-^ 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)+ mticks <- makeModuleLineMap modl let mbid = do ticks <- mticks case columnNum of
+ haskell-debugger/GHC/Debugger/Debuggee.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultilineStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NondecreasingIndentation #-}+module GHC.Debugger.Debuggee where++import System.Process+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Data.Function+import Data.Maybe+import Prelude hiding (mod)+import Network.Socket hiding (Debug)+import System.Process.Internals (mkProcessHandle)+import Text.Read (readMaybe)+import System.Environment (getExecutablePath)+import Data.Text (Text)++import GHC+import GHC.Driver.Env as GHC+import GHC.Driver.Monad+import GHC.Driver.Hooks+import GHC.Driver.Ppr+import GHC.Runtime.Interpreter as GHCi+import GHC.Types.Error+import qualified GHC.Utils.Logger as GHC++import GHC.Debugger.Session++import Colog.Core as Logger++import GHCi.Message (mkPipeFromHandles)+import System.IO (hGetLine, IOMode(..), openFile, Handle)+import qualified GHC.Linker.Loader as Loader+import GHC.Stack.Annotation+import GHC.Platform.Ways+#if MIN_VERSION_ghc(9,15,0)+import GHC.Data.FastString.Env (emptyFsEnv)+#endif+import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger`++data InterpreterSettings = InterpreterSettings+ { interpreterFlags :: DynFlags -> DynFlags+ , interpreterSetup :: forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a+ }++mkInternalInterpreterFlags :: DynFlags -> DynFlags+mkExternalInterpreterFlags :: String -> DynFlags -> DynFlags+(mkInternalInterpreterFlags, mkExternalInterpreterFlags) = (mkInterpreterFlags True "", mkInterpreterFlags False)+ where+ mkInterpreterFlags :: Bool -> String -> DynFlags -> DynFlags+ mkInterpreterFlags preferInternalInterpreter externalInterpreterProg df = df+ -- Enable the external interpreter by default! See #169+ -- See Note [Custom external interpreter]+ & enableExternalInterpreter preferInternalInterpreter+ -- Ext interp is the same program as this, with "--external-interpreter"+ -- (this is ignored on GHC 9.14, see Note [Custom external interpreter])+ & setPgmI externalInterpreterProg+ -- ideally, we'd set "external-interpreter" *before* the file+ -- descriptors. since there's no way to do that yet, we just have+ -- some logic in main to detect [writefd, readfd, --external-interpreter]+ & addOptI "--external-interpreter"+++mkInternalInterpreterSetup :: LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a+mkInternalInterpreterSetup _ dflags mainGhcThread = do+ when (gopt Opt_ExternalInterpreter dflags) $ do+ throw $ InconsistentInterpreterFlags $ "Used ghc flag -fexternal-interpreter together with --internal-interpreter haskell-debugger flag."+ mainGhcThread++newtype InconsistentInterpreterFlags = InconsistentInterpreterFlags String+instance Show InconsistentInterpreterFlags where+ show (InconsistentInterpreterFlags t) = "Interpreter flags are inconsistent: " ++ t+instance Exception InconsistentInterpreterFlags+++mkExternalInterpreterFromIOSetup :: IO Interp -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a+mkExternalInterpreterFromIOSetup m _l dflags mainGhcThread = do+ unless (gopt Opt_ExternalInterpreter dflags) $ do+ throw $ InconsistentInterpreterFlags $ "Used ghc flag -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag."+ extInterp <- liftIO m+ modifySession $ \h -> h+ { hsc_interp = Just extInterp -- set it directly!+ }++ mainGhcThread++type CreatedProcess = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)++-- | Takes @std_in, std_out, std_err@ fields for @createProcess@ and a callback for the result.+mkExternalInterpreterSubProcessSetup+ :: StdStream -> StdStream -> StdStream+ -> (CreatedProcess -> IO ())+ -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a+mkExternalInterpreterSubProcessSetup std_in std_out std_err putHandles _l dflags mainGhcThread = do+ unless (gopt Opt_ExternalInterpreter dflags) $ do+ throw $ InconsistentInterpreterFlags $ "Used ghc flag -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag."++ modifySession $ \h -> h+ { hsc_hooks = (hsc_hooks h)+ { createIservProcessHook = Just $ \cp -> do+ -- See Note [External interpreter buffering]+ p@(_, _, _, ph) <-+ createProcess cp+ { std_in+ , std_out+ , std_err+ -- Override executable path+ -- See Note [Custom external interpreter]+#if MIN_VERSION_ghc(9,15,0)+#else+ , cmdspec = case cmdspec cp of+ ShellCommand (words -> ws) -> ShellCommand $ unwords $ getPgmI dflags : drop 1 ws+ RawCommand _fp args -> RawCommand (getPgmI dflags) args+#endif+ }+ putHandles p+ return ph+ }+ }+ mainGhcThread++-- | Make an 'ExtInterpInstance' based on an external interpreter process+-- running as 'hdb external-interpreter --port $port'.+--+-- The process is expected to connect to '$port' and send its own PID as the+-- first line on the socket before the GHCi wire protocol begins.+--+-- The given 'Socket' should be listening on '$port'.+--+-- Note: no attempt is made to capture the standard input/output/error.+extInterpFromListeningSocket :: Socket -> IO Interp+extInterpFromListeningSocket sock0 = do+ port <- socketPort sock0+ putStrLn $ "Connected to " ++ show port+ Control.Exception.bracketOnError+ (accept sock0)+ (\ (sock,_) -> close sock0 >> close sock)+ (\ (sock,_) -> do+ bi_h <- socketToHandle sock ReadWriteMode++ pidLine <- annotateCallStackIO $ hGetLine bi_h++ pid <- case readMaybe pidLine :: Maybe Int of+ Just pid -> pure pid+ Nothing -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine+ ph <- mkProcessHandle (fromIntegral pid) False+ interpPipe <- mkPipeFromHandles bi_h bi_h+ lock <- newMVar ()+ let process = InterpProcess+ { interpHandle = ph+ , interpPipe+ , interpLock = lock+ }++ pending_frees <- newMVar []+ let inst = ExtInterpInstance+ { instProcess = process+ , instPendingFrees = pending_frees+ , instExtra = ()+ }+ conf = IServConfig+ { iservConfProgram = "the process is already running, we should never need to run it again"+ , iservConfOpts = []+ -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger]+ , iservConfDynamic = hostIsDynamic+ , iservConfProfiled = hostIsProfiled+ , iservConfHook = Nothing -- it's already running!+ , iservConfTrace = pure ()+ }++ lookup_cache <- mkInterpSymbolCache+ s <- newMVar $ InterpRunning inst+ loader <- Loader.uninitializedLoader+#if MIN_VERSION_ghc(9,15,0)+ fs_cache <- newMVar emptyFsEnv+ return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache)+#else+ return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)+#endif+ )++mkCliInterpreterSettings :: Bool -> Maybe FilePath -> IO InterpreterSettings+mkCliInterpreterSettings internalInterpreter debuggeeStdin = do+ if internalInterpreter then pure $ InterpreterSettings { interpreterFlags = mkInternalInterpreterFlags+ , interpreterSetup = mkInternalInterpreterSetup } else do+ stdinStream <- case debuggeeStdin of+ Just fp -> UseHandle <$> System.IO.openFile fp ReadMode+ Nothing -> pure Inherit+ -- the same program invoked with `external-interpreter` serves as the external interpreter+ thisProg <- getExecutablePath+ pure InterpreterSettings { interpreterFlags = mkExternalInterpreterFlags thisProg+ , interpreterSetup = mkExternalInterpreterSubProcessSetup stdinStream Inherit Inherit (const $ pure ())+ }++--------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------++-- | A debugger log. May include debuggee ouput.+data DebuggerLog+ = DebuggerLog !Logger.Severity !DebuggerMessage+ | GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc+ | DebuggerSessionLog !Logger.Severity !Text++-- | A debugger log message+data DebuggerMessage+ = LogSDoc !DynFlags !SDoc+ | LogFailedToCompileBuiltinModule !GHC.ModuleName+ | LogSkippingViewModuleNoPkg !GHC.ModuleName String [String]++instance Show DebuggerMessage where+ show = \ case+ LogFailedToCompileBuiltinModule mn ->+ "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views."+ LogSkippingViewModuleNoPkg mn pkg uids ->+ "Skipping compilation of built-in " ++ moduleNameString mn ++ " module because package "+ ++ show pkg ++ " wasn't found in dependencies " ++ show uids+ LogSDoc dflags doc -> showSDoc dflags doc+++ghcLogAction :: LogAction IO DebuggerLog -> GHC.LogAction+ghcLogAction l = \logflags mclass srcSpan sdoc -> do+ liftLogIO l <& GHCLog logflags mclass srcSpan sdoc++msgClassSeverity :: MessageClass -> Logger.Severity+msgClassSeverity = \case+ MCOutput -> Info+ MCFatal -> Logger.Error+ MCInteractive -> Info+ MCDump -> Debug+ MCInfo -> Info+ MCDiagnostic SevIgnore _ _ -> Debug -- ?+ MCDiagnostic SevWarning _ _ -> Logger.Warning+ MCDiagnostic SevError _ _ -> Logger.Error
haskell-debugger/GHC/Debugger/Interface/Messages.hs view
@@ -6,17 +6,48 @@ DuplicateRecordFields, TypeApplications #-}+{-# LANGUAGE DerivingStrategies #-} -- | Types for sending and receiving messages to/from haskell-debugger module GHC.Debugger.Interface.Messages where import qualified GHC import qualified GHC.Utils.Outputable as GHC+import GHCi.RemoteTypes (ForeignRef) import GHC.Debugger.Runtime.Term.Key import Data.Binary (Binary) import qualified GHC.Stack as Stack+import System.FilePath (isAbsolute, (</>), normalise)+import Control.Exception (assert)+import qualified GHC.Exts.Heap.Closures as Heap+import GHC.Generics +{-+Note [Paths should be made absolute at the source]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We get `FilePath`s from a few different sources, and those sources do not always agree on what the paths should be relative to.++To avoid mistakes in interpreting relative paths, they should be made absolute as soon as we get them.++At the time of writing (25/07/2026), we handle paths from:+- CLI: relative to getCurrentDirectory.+- GHC: relative to getCurrentDirectory.+- DAP: relative to projectRoot.+- HIE: relative to projectRoot/workingDir, these are made absolute when creating DynFlags.+-}++-- | See Note [Paths should be made absolute at the source]+newtype AbsFilePath = MkAbsFilePath {unAbs :: FilePath}+ deriving newtype (Eq,Show)++mkAbsolute :: FilePath -> AbsFilePath+mkAbsolute fp = assert (null fp || isAbsolute fp) $ MkAbsFilePath fp++(/>) :: AbsFilePath -> FilePath -> AbsFilePath+MkAbsFilePath fp /> fp' = MkAbsFilePath $ normalise $ fp </> fp'+ -------------------------------------------------------------------------------- -- Commands --------------------------------------------------------------------------------@@ -42,7 +73,7 @@ -- | Clear all breakpoints in the specified file. -- This is useful because DAP's `setBreakpoints` re-sets all breakpoints from zero for a source rather than incrementally.- | ClearModBreakpoints { file :: FilePath }+ | ClearModBreakpoints { file :: AbsFilePath } -- | Clear all function breakpoints | ClearFunctionBreakpoints@@ -87,7 +118,7 @@ -- When the @'EntryPoint'@ is @'Main'@, @'runArgs'@ are set as process -- invocation arguments (as in @argv@) rather than passed directly as a -- Haskell function arguments.- | DebugExecution { entryPoint :: EntryPoint, entryFile :: FilePath, runArgs :: [String] }+ | DebugExecution { entryPoint :: EntryPoint, entryFile :: AbsFilePath, runArgs :: [String] } -- | An entry point for program execution. data EntryPoint = MainEntry { mainName :: Maybe String } | FunctionEntry { fnName :: String }@@ -96,7 +127,7 @@ -- | A breakpoint can be set/removed on functions by name, or in modules by -- line number. And, globally, for all exceptions, or just uncaught exceptions. data Breakpoint- = ModuleBreak { path :: FilePath, lineNum :: Int, columnNum :: Maybe Int }+ = ModuleBreak { path :: AbsFilePath, lineNum :: Int, columnNum :: Maybe Int } | FunctionBreak { function :: String } | OnExceptionsBreak | OnUncaughtExceptionsBreak@@ -185,8 +216,9 @@ -- | A source span type for the interface. Like 'RealSrcSpan'. data SourceSpan = SourceSpan- { file :: !FilePath- -- ^ Path to file where this span is located+ { file :: !AbsFilePath+ -- ^ Path to file where this span is located.+ -- See Note [Paths should be made absolute at the source] , startLine :: {-# UNPACK #-} !Int -- ^ RealSrcSpan start line , endLine :: {-# UNPACK #-} !Int@@ -205,17 +237,18 @@ -- Use this only as a last resort if no other source span can be provided. unhelpfulSourceSpan :: SourceSpan unhelpfulSourceSpan = SourceSpan- { file = ""+ { file = mkAbsolute "" , startLine = 0 , endLine = 0 , startCol = 0 , endCol = 0 } -srcLocToSourceSpan :: Stack.SrcLoc -> SourceSpan-srcLocToSourceSpan srcLoc =+-- | See Note [Paths should be made absolute at the source]+srcLocToSourceSpan :: AbsFilePath -> Stack.SrcLoc -> SourceSpan+srcLocToSourceSpan prefix srcLoc = SourceSpan- { file = Stack.srcLocFile srcLoc+ { file = prefix /> Stack.srcLocFile srcLoc , startLine = Stack.srcLocStartLine srcLoc , endLine = Stack.srcLocEndLine srcLoc , startCol = Stack.srcLocStartCol srcLoc@@ -242,6 +275,7 @@ | GotVariables VariableResult | GotExceptionInfo ExceptionInfo | Aborted String+ | NonFatalError String | Initialised data BreakFound@@ -304,15 +338,27 @@ } deriving (Show) ++data DbgStackFrameBCOArgs ref+ = DbgStackFrameBCOArgs+ { bcoArgs :: NoShow (ref [Heap.StackField])+ -- ^ payload of the frame, c.f. @Heap.RetBCO@.+ , bcoArgsOffset :: Maybe Word+ -- ^ offset of bcoArgs in an hypotethical AP_STACK closure,+ -- see Note [Ask the RTS for memory layout of AP_STACK].+ }+ deriving (Generic, Show)+ data DbgStackFrame = DbgStackFrame { name :: String -- ^ Title of stack frame , sourceSpan :: SourceSpan -- ^ Source span for this stack frame- , breakId :: Maybe GHC.InternalBreakpointId+ , breakId :: Maybe (GHC.InternalBreakpointId) -- ^ Is this a BCO continuation frame with a breakpoint? -- If yes, we can leverage the breakpoint info to report scopes.+ , args :: Maybe (DbgStackFrameBCOArgs ForeignRef) } deriving (Show) @@ -332,3 +378,8 @@ instance Show GHC.InternalBreakpointId where show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix++newtype NoShow a = NoShow a++instance Show (NoShow a) where+ show _ = "<noshow>"
haskell-debugger/GHC/Debugger/Monad.hs view
@@ -10,20 +10,19 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NondecreasingIndentation #-} module GHC.Debugger.Monad where -import System.Environment-import System.Process import Control.Concurrent-import Control.Concurrent.Async import Control.Exception+import qualified Data.Foldable as Foldable import Control.Monad import Control.Monad.Catch as MC import Control.Monad.IO.Class import Control.Monad.Reader import Data.Function-import Data.Functor.Contravariant import Data.IORef import Data.Maybe import qualified Data.Set as Set@@ -32,22 +31,17 @@ #ifdef MIN_VERSION_unix import System.Posix.Signals #endif-import Data.Text (Text) import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty-import Network.Socket hiding (Debug)-import System.Process.Internals (mkProcessHandle)-import Text.Read (readMaybe)+import qualified GHC.Conc.Sync as C import GHC-import GHC.Data.FastString import GHC.Data.StringBuffer import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Logger import GHC.Driver.DynFlags as GHC-import GHC.Driver.Env+import GHC.Driver.Env as GHC import GHC.Driver.Monad-import GHC.Driver.Hooks import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Main@@ -60,13 +54,9 @@ import GHC.Runtime.Loader as GHC import GHC.Runtime.Context as GHCi 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.State-import GHC.Unit.Module.ModSummary as GHC import GHC.Unit.Types import qualified GHC.Utils.Logger as GHC import GHC.Utils.Outputable as GHC@@ -77,23 +67,21 @@ import GHC.Debugger.Session.Builtin import GHC.Debugger.Session.Interactive import GHC.Debugger.Runtime.Compile.Cache-import GHC.Debugger.Utils import qualified GHC.Debugger.Breakpoint.Map as BM import qualified GHC.Debugger.Runtime.Thread.Map as TM import Colog.Core as Logger import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache)-import GHCi.Message (mkPipeFromHandles)-import System.IO (hGetLine, IOMode(..))-import qualified GHC.Linker.Loader as Loader import GHC.Stack.Annotation import GHC.Platform.Ways-#if MIN_VERSION_ghc(9,15,0)-import GHC.Data.FastString.Env (emptyFsEnv)-#endif import GHC.Unit.Home.Graph import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger`+import System.Directory (getCurrentDirectory)+import GHC.Debugger.Debuggee+import GHC.Plugins (HasCallStack)+import Data.Bifunctor+import qualified GHC.Unit.Module.Graph as GHC -- | A debugger action. newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a }@@ -195,293 +183,351 @@ data RunDebuggerSettings = RunDebuggerSettings { supportsANSIStyling :: Bool , supportsANSIHyperlinks :: Bool- , preferInternalInterpreter :: Bool- , externalInterpreterCustomProc :: Either StdStream PortNumber- -- ^ Right: use a custom given existing process for the external- -- interpreter listening at given port. (This is used when we want to- -- launch the external interpreter attached to a user's terminal).- --- -- Left: we launch our own external interpreter process through- -- GHC's spawnIServ using the given StdStream as the stdin.+ , interpreterSettings :: InterpreterSettings } --- | Run a 'Debugger' action on a session constructed from a given GHC invocation.-runDebugger :: forall a- . LogAction IO DebuggerLog- -> FilePath -- ^ Cradle root directory- -> FilePath -- ^ Component root directory- -> FilePath -- ^ The libdir (given with -B as an arg)- -> [String] -- ^ The list of units included in the invocation- -> [String] -- ^ The full ghc invocation (as constructed by hie-bios flags)- -> [String] -- ^ The extra GHC arguments (as given by the user in @extraGhcArgs@)- -> FilePath -- ^ Path to the main function- -> RunDebuggerSettings -- ^ Other debugger run settings- -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation- -> IO a-runDebugger l rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = annotateCallStackIO $ do- let ghcLog = liftLogIO l :: LogAction Ghc DebuggerLog- let dbgLog = liftLogIO l :: LogAction Debugger DebuggerLog- thisProg <- getExecutablePath- let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation'- GHC.runGhc (Just libdir) $- flip MC.finally cleanupInterp $ -- See Note [Shutting down the external interpreter]- do+-- | Run a 'Debugger' action on a session constructed by a 'DebugRunner'+--+-- INVARIANT: The initUniqSupply has already been initialized.+--+-- Users of hdb-as-a-library will have to call `initUniqSupply` at their leisure,+-- special care needed if they supply any loaded units/modules to us via the DebugRunner,+-- as those will contain `Unique`s.+--+-- See Note [UniqueSupply is process global].+runDebugger :: LogAction IO DebuggerLog -> DebugRunner Ghc a -> RunDebuggerSettings -> Debugger a -> IO a+runDebugger l debugRunner conf action = annotateCallStackIO $ do+ debugRunner $ \ rootDir extraGhcArgs loadHomeUnit -> runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit action++type DebugSession m a+ = FilePath -- ^ project root dir+ -> [String] -- ^ extra ghc args+ -> m () -- ^ action to load debugee home units+ -> Ghc a++type DebugRunner m a = DebugSession m a -> IO a++data ProjectDebugSpec = ProjectDebugSpec+ { rootDir :: FilePath+ -- ^ Project root directory+ , componentDir :: FilePath+ -- ^ Root dir of the loaded 'ComponentOptions'.+ -- Important for multi-package cabal projects, as packages are not in the+ -- root of the cradle, but in some sub-directory.+ , libdir :: FilePath+ -- ^ The libdir (given with -B as an arg)+ , units :: [String]+ -- ^ The list of units included in the invocation+ , ghcInvocation :: [String]+ -- ^ The full ghc invocation (as constructed by hie-bios flags)+ , absEntryFile :: FilePath+ -- ^ Path to the main function+ , extraGhcArgs :: [String]+ }++-- | Construct a session from paths and flags inferred from the debugee's project.+withProjectDebugSession+ :: GhcMonad m+ => ProjectDebugSpec+ -> DebugRunner m a+withProjectDebugSession ProjectDebugSpec{ghcInvocation = ghcI, ..} k = do+ let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcI+ GHC.runGhc (Just libdir) $ do #ifdef MIN_VERSION_unix- -- Workaround #4162- -- FIXME: setup reasonable handlers to run cleanupSession for every debugger thread, because runGhc's `withSignalHandlers` is not it.+ -- Workaround #4162+ -- FIXME: setup reasonable handlers to run cleanupSession for every debugger thread, because runGhc's `withSignalHandlers` is not it. _ <- liftIO $ installHandler sigINT Default Nothing _ <- liftIO $ installHandler sigQUIT Default Nothing _ <- liftIO $ installHandler sigTERM Default Nothing _ <- liftIO $ installHandler sigHUP Default Nothing #endif- dflags0 <- GHC.getSessionDynFlags- let dflags1 = dflags0- { GHC.ghcMode = GHC.CompManager- , GHC.ghcLink = GHC.LinkInMemory- , GHC.verbosity = 1- , GHC.canUseColor = conf.supportsANSIStyling- , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks- }- -- Default debugger settings- `GHC.xopt_set` LangExt.TypeApplications- `GHC.xopt_set` LangExt.PackageImports- `GHC.xopt_set` LangExt.MagicHash -- needed for some of the expressions we compile- `GHC.gopt_set` GHC.Opt_ImplicitImportQualified- `GHC.gopt_set` GHC.Opt_IgnoreOptimChanges- `GHC.gopt_set` GHC.Opt_IgnoreHpcChanges- `GHC.gopt_set` GHC.Opt_UseBytecodeRatherThanObjects- `GHC.gopt_set` GHC.Opt_InsertBreakpoints+ k rootDir extraGhcArgs $ do+ dflags2 <- getSessionDynFlags - -- Enable the external interpreter by default! See #169- -- See Note [Custom external interpreter]- & enableExternalInterpreter conf.preferInternalInterpreter- -- Ext interp is the same program as this, with "--external-interpreter"- -- (this is ignored on GHC 9.14, see Note [Custom external interpreter])- & setPgmI thisProg- -- ideally, we'd set "external-interpreter" *before* the file- -- descriptors. since there's no way to do that yet, we just have- -- some logic in main to detect [writefd, readfd, --external-interpreter]- & addOptI "--external-interpreter"+ -- Discover the user-given flags and targets+ flagsAndTargets <- parseHomeUnitArguments absEntryFile componentDir units ghcInvocation dflags2 rootDir - -- Really important to force -dynamic if host is dynamic- -- See Note [Dynamic Debuggee for dynamic debugger]- & enableDynamicDebuggee - & setBytecodeBackend- & enableByteCodeGeneration+ let setVerbosity dflags = dflags {verbosity = verbosity dflags2}+ -- Setup HomeUnitGraph with debugee and interactiveGhcDebugger units+ setupHomeUnitGraph (map (first setVerbosity) $ NonEmpty.toList flagsAndTargets) - GHC.modifyLogger $- -- Override the logger to output to the given handle- GHC.pushLogHook $ const $ ghcLogAction l+ debugee_mod_graph <- doDownsweep Nothing - 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)- <- parseDynamicFlagsWithRootDir rootDir logger dflags1 (map noLoc extraGhcArgs)- liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)- forM_ fileish_args $ \fish_arg -> liftIO $ do- GHC.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+ if_cache <- Just <$> liftIO newIfaceCache+ success <- doLoad if_cache GHC.LoadAllTargets debugee_mod_graph - -- Make sure to override the function which creates the external- -- interpreter, because we need to keep track of the standard handles- iserv_handles <- liftIO newEmptyMVar- case conf.externalInterpreterCustomProc of- -- Left: GHC will launch the external interpreter itself on demand if- -- using external interpreter, and we just provide the stdin stream- Left givenStdStream ->- modifySession $ \h -> h- { hsc_hooks = (hsc_hooks h)- { createIservProcessHook = Just $ \cp -> do- -- See Note [External interpreter buffering]- (_, Just o, Just e, ph) <-- createProcess cp- { std_in = givenStdStream- , std_out = CreatePipe- , std_err = CreatePipe- -- Override executable path- -- See Note [Custom external interpreter]-#if MIN_VERSION_ghc(9,15,0)+ when (GHC.failed success) $ liftIO $+ throwM DebuggerFailedToLoad++runDebuggerAction :: forall a. LogAction IO DebuggerLog+ -> FilePath -- ^ rootDir+ -> [String] -- ^ extraGhcArgs+ -> RunDebuggerSettings+ -> Ghc () -- ^ load home units action+ -> Debugger a+ -> Ghc a+runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action)+ = flip MC.finally cleanupInterp $+ -- See Note [Shutting down the external interpreter]+ do+ dflags0 <- GHC.getSessionDynFlags+ let dflags1 = dflags0+ { GHC.ghcMode = GHC.CompManager+ , GHC.ghcLink = GHC.LinkInMemory+ , GHC.verbosity = 1+ , GHC.canUseColor = conf.supportsANSIStyling+ , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks+ }+ -- Default debugger settings+ `GHC.xopt_set` LangExt.TypeApplications+ `GHC.xopt_set` LangExt.PackageImports+ `GHC.xopt_set` LangExt.MagicHash -- needed for some of the expressions we compile+ `GHC.gopt_set` GHC.Opt_ImplicitImportQualified+ `GHC.gopt_set` GHC.Opt_IgnoreOptimChanges+ `GHC.gopt_set` GHC.Opt_IgnoreHpcChanges+ `GHC.gopt_set` GHC.Opt_UseBytecodeRatherThanObjects+ `GHC.gopt_set` GHC.Opt_InsertBreakpoints++ & interpreterFlags conf.interpreterSettings+ -- Really important to force -dynamic if host is dynamic+ -- See Note [Dynamic Debuggee for dynamic debugger]+ & enableDynamicDebuggee++ & setBytecodeBackend+ & enableByteCodeGeneration++ GHC.modifyLogger $+ -- Override the logger to output to the given handle+ GHC.pushLogHook $ const $ ghcLogAction l++ 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)+ <- parseDynamicFlagsWithRootDir rootDir logger dflags1 (map noLoc extraGhcArgs)+ liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)+ forM_ fileish_args $ \fish_arg -> liftIO $ do+ GHC.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++ interpreterSetup conf.interpreterSettings l dflags2 $ do+ -- Initializes interpreter!+ _ <- GHC.setSessionDynFlags dflags2++ -- Initialise plugins here because the plugin author might already expect this+ -- subsequent call to `getLogger` to be affected by a plugin.+ GHC.initializeSessionPlugins++ preservingThreadLabel loadHomeUnit++ fixHomeUnitsDynFlagsForIIDecl+++ -- Ensure all the home units are built with same Ways and return them.+ buildWays <- do+ hug_dflags <- fmap homeUnitEnv_dflags . Foldable.toList . hsc_HUG <$> getSession+ liftIO $ validateUnitsWays $ case hug_dflags of+ [] -> error "No units"+ (x:xs) -> x NonEmpty.:| xs++#ifndef DEBUG_WITH_GHC+ -- Find haskell-debugger-view in (deps of) home units, or load one from+ -- in-memory sources.+ (hdv_uid, loadedBuiltinModNames) <- do+ preservingThreadLabel $+ findOrLoadHaskellDebuggerView l buildWays #else- , cmdspec = case cmdspec cp of- ShellCommand (words -> ws) -> ShellCommand $ unwords $ thisProg : drop 1 ws- RawCommand _fp args -> RawCommand thisProg args+ let hdv_uid = hsDebuggerViewInMemoryUnitId+ let loadedBuiltinModNames = [] :: [ModuleName] #endif- }- putMVar iserv_handles (o, e)- return ph- }- } - -- Right: we supply our custom external interpreter process, which is- -- already running and connected to the user's terminal.- Right port -> do- extInterp <- liftIO- $ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process"- $ extInterpFromTerminalProcess port- modifySession $ \h -> h- { hsc_interp = Just extInterp -- set it directly!- }+#if !MIN_VERSION_ghc(9,14,2)+ loadFFIInspect l buildWays+#endif - let- externalInterpFwdThread :: IO ()- externalInterpFwdThread = when (GHC.gopt GHC.Opt_ExternalInterpreter dflags2) $ do- -- The external interpreter is spawned lazily, so we block waiting for- -- the handles to be available in a new thread.- withAsync (takeMVar iserv_handles) $ \async_handles -> do- (serv_out, serv_err) <- wait async_handles- concurrently_- (forwardHandleToLogger serv_err (contramap LogDebuggeeErr l))- (forwardHandleToLogger serv_out (contramap LogDebuggeeOut l))+ -- Loaded later so it can depend on FFIInspect if needed.+ loadInternal l buildWays - mainGhcThread :: Ghc a- mainGhcThread = do- -- Initializes interpreter!- _ <- GHC.setSessionDynFlags dflags2 - -- Initialise plugins here because the plugin author might already expect this- -- subsequent call to `getLogger` to be affected by a plugin.- GHC.initializeSessionPlugins+ -- See Note [Must explicitly expose module graph units]+ exposeModGraphUnitsInInteractiveGhcDebuggerUnit - GHC.getSessionDynFlags >>= \df -> liftIO $- GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df)+ -- Set interactive context to import all loaded modules+ let preludeImp = GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" - -- Discover the user-given flags and targets- flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir- buildWays <- liftIO $ validateUnitsWays flagsAndTargets+ hsc_env_new <- getSession - -- Setup base HomeUnitGraph- setupHomeUnitGraph (NonEmpty.toList flagsAndTargets)- -- Downsweep user-given modules first- mod_graph_base <- doDownsweep Nothing+ -- dbgView should always be available, either because we manually loaded it+ -- or because it's in the transitive closure.+ let dbgViewImps+ = map (packageImportDecl hvd_pkgName) loadedBuiltinModNames+ where+ hvd_pkgName = fromMaybe (error $ "No package name for: " ++ unitIdString hdv_uid) $+ lookupUnitPackageQualifier hsc_env_new hdv_uid - if_cache <- Just <$> liftIO newIfaceCache+ mss <- getAllLoadedModules - -- Try to find or load the built-in classes from `haskell-debugger-view`- (hdv_uid, loadedBuiltinModNames) <- findHsDebuggerViewUnitId mod_graph_base >>= \case- Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do+ let+ imports+ = map GHC.IIDecl $ preludeImp :+#if MIN_VERSION_ghc(10,1,0)+ [ i { ideclImportList = Just (Exactly, []) }+ | i <- instancesOnly ]+#else+ [ i { ideclImportList = Just (Exactly, L noAnn []) }+ | i <- instancesOnly ]+#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.+ -- We import (only the instances of) all the home unit+ -- modules to bring any orphan DebugView instances in scope.+ instancesOnly =+ dbgViewImps +++ [ packageImportDecl pkgName (moduleName modl)+ | modl <- map moduleNodeInfoModule mss+ , let uid = moduleUnitId modl+ , let pkgName = fromMaybe (error $ "No package name for: " ++ unitIdString uid) $ lookupUnitPackageQualifier hsc_env_new uid+ ] - -- Add the custom unit to the HUG- let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base]- addInMemoryHsDebuggerViewUnit base_dep_uids . setDynFlagWays buildWays =<< getDynFlags - tryLoadHsDebuggerViewModule l if_cache (const False) debuggerViewClassModName debuggerViewClassContents- >>= \case- Failed -> do- -- Failed to load base debugger-view module!- ghcLog <& DebuggerLog Logger.Debug- (LogFailedToCompileDebugViewModule debuggerViewClassModName)- return []- Succeeded -> (debuggerViewClassModName:) . concat <$> do+ GHC.setContext imports - forM debuggerViewInstancesMods $ \(modName, modContent, pkgName) -> do- -- Don't try to load instances whose packages are not even in- -- the module graph:- if any ((pkgName `L.isPrefixOf`) . unitIdString) base_dep_uids then do- tryLoadHsDebuggerViewModule l if_cache- ((\case- -- Keep only "GHC.Debugger.View.Class", which is a dependency of all these.- GHC.TargetFile f _- -> f == "in-memory:" ++ moduleNameString debuggerViewClassModName- _ -> False) . GHC.targetId)- modName modContent >>= \case- Failed -> do- ghcLog <& DebuggerLog Logger.Info- (LogFailedToCompileDebugViewModule modName)- return []- Succeeded -> do- return [modName]- else do- ghcLog <& DebuggerLog Logger.Debug- (LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids))- return []+ -- See Note [External interpreter buffering]+ hscInterp <$> GHC.getSession >>= \interp -> runInternal $ do+ code <- compileExprRemote $ moduleNameString debuggerRuntimeInternalModName ++ ".setLineBuffering"+ liftIO $ evalIO interp code - 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)+ noPrint <- defineNoPrint+ modifySession (\hsc_env -> hsc_env {hsc_IC = GHCi.setInteractivePrintName (hsc_IC hsc_env) noPrint}) - -- Final load combining all base modules plus haskell-debugger-view ones that loaded successfully- -- The targets which were successfully loaded have been set with `setTarget` (e.g. by setupHomeUnitGraph).- final_mod_graph <- doDownsweep (Just mod_graph_base{-cached previous result-})- success <- doLoad if_cache GHC.LoadAllTargets final_mod_graph- when (GHC.failed success) $ liftIO $- throwM DebuggerFailedToLoad+ runReaderT action+ =<< initialDebuggerState (liftLogIO l)+ (if loadedBuiltinModNames == []+ then Nothing+ else Just hdv_uid) - -- See Note [Must explicitly expose module graph units]- setExposedInUnit interactiveGhcDebuggerUnitId (graphUnits final_mod_graph)+preservingThreadLabel :: HasCallStack => Ghc a -> Ghc a+preservingThreadLabel m = do+ thId <- liftIO $ myThreadId+ mlbl <- liftIO $ C.threadLabel thId+ case mlbl of+ Nothing -> m+ Just lbl -> do+ annotateCallStackGhc $ do+ x <- m+ liftIO $ C.labelThread thId lbl+ pure x - -- 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.- hug <- hsc_HUG <$> getSession- let dbgViewImps- -- If hs-dbg-view is a home-unit, refer to it directly- -- See Note [Do not package-qualify imports for home units]- | memberHugUnitId hdv_uid hug- = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames- -- It's available in an exposed unit in the transitive closure. Resolve it- | otherwise- = map (\mn ->- GHC.IIDecl (GHC.simpleImportDecl mn)- { ideclPkgQual = RawPkgQual- StringLiteral- { sl_st = NoSourceText- , sl_fs = mkFastString (unitIdString hdv_uid)- , sl_tc = Nothing- }- }) loadedBuiltinModNames+-- | Throws exception when module fails to load.+loadInternal+ :: LogAction IO DebuggerLog+ -> Ways+ -> Ghc ()+loadInternal l buildWays = do+ let ghcLog = liftLogIO l - mss <- getAllLoadedModules+ dflags <- getDynFlags+ addInMemoryDebuggerInternalUnit (setDynFlagWays buildWays dflags)+ let uid = debuggerInternalUnitId+ successes <- loadInMemoryModules l uid modsToLoad+ forM_ (zip successes modsToLoad) $ \case+ (Failed,(modName,_)) -> do+ ghcLog <& DebuggerLog Logger.Debug+ (LogFailedToCompileBuiltinModule modName)+ liftIO $ fail "Failed to load DebuggerInternal Module"+ (Succeeded,_) ->+ return ()+ where+ modsToLoad =+ [(debuggerRuntimeInternalModName,debuggerRuntimeInternalContents)] - GHC.setContext- (preludeImp :- dbgViewImps ++- map (GHC.IIModule . GHC.ms_mod) mss)+#if !MIN_VERSION_ghc(9,14,2)+data FailedToLoadFFIInspectModule = FailedToLoadFFIInspectModule+ deriving Show+instance Exception FailedToLoadFFIInspectModule - -- See Note [External interpreter buffering]- setBufferings <- compileExprRemote """- do { System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering- ; System.IO.hSetBuffering System.IO.stderr System.IO.LineBuffering }- """- hscInterp <$> GHC.getSession >>= \interp ->- liftIO $ evalIO interp setBufferings+-- | Throws exception when module fails to load.+-- Needed for GHC.Debugger.Runtime.Interpreter.Legacy+loadFFIInspect+ :: LogAction IO DebuggerLog+ -> Ways+ -> Ghc ()+loadFFIInspect l buildWays = do+ let ghcLog = liftLogIO l - noPrint <- defineNoPrint- modifySession (\hsc_env -> hsc_env {hsc_IC = GHCi.setInteractivePrintName (hsc_IC hsc_env) noPrint})+ dflags <- getDynFlags+ uid <- addInMemoryFFIInspectUnit [baseUnitId dflags] (setDynFlagWays buildWays dflags) - runReaderT action- =<< initialDebuggerState dbgLog- (if loadedBuiltinModNames == []- then Nothing- else Just hdv_uid)+ successes <- loadInMemoryModules l uid modsToLoad+ forM_ (zip successes modsToLoad) $ \case+ (Failed,(modName,_)) -> do+ ghcLog <& DebuggerLog Logger.Debug+ (LogFailedToCompileBuiltinModule modName)+ liftIO $ throwIO FailedToLoadFFIInspectModule+ (Succeeded,_) ->+ return ()+ where+ modsToLoad =+ [(debuggerRuntimeFFIInspectModName,debuggerRuntimeFFIInspectContents)]+#endif - case conf.externalInterpreterCustomProc of- Left _ -> do- -- We launched the external interpreter ourselves, so forward its output to the logger.- withUnliftGhc $ \ unlift -> do- withAsync (void externalInterpFwdThread) $ \ fwd_thr -> do- liftIO $ link fwd_thr- unlift mainGhcThread- Right _ ->- -- Ext interp is running in user terminal, no need to forward output to logger- mainGhcThread+findOrLoadHaskellDebuggerView :: LogAction IO DebuggerLog+ -> Ways+ -> Ghc (UnitId, [ModuleName])+findOrLoadHaskellDebuggerView l buildWays = do+ let ghcLog = liftLogIO l+ hsc_env <- getSession + -- Try to find or load the built-in classes from `haskell-debugger-view`+ findHsDebuggerViewUnitId >>= \case+ Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> 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 the custom unit to the HUG+ let base_dep_uids = graphsUnits hsc_env+ addInMemoryHsDebuggerViewUnit base_dep_uids . setDynFlagWays buildWays =<< getDynFlags++ -- Load unit modules using in-memory contents.+ let+ -- Don't try to load instances whose packages are not even in the+ -- module graph.+ (instanceMods,skipped) = L.partition (\ (_modName,_modContent,pkgName) -> any ((pkgName `L.isPrefixOf`) . unitIdString) base_dep_uids)+ debuggerViewInstancesMods+ modsToLoad =+ (debuggerViewClassModName,debuggerViewClassContents)+ : [ (modName,modContent)+ | (modName, modContent, _pkgName) <- instanceMods]++ forM_ skipped $ \(modName,_,pkgName) ->+ ghcLog <& DebuggerLog Logger.Debug+ (LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids))++ successes <- loadInMemoryModules l hsDebuggerViewInMemoryUnitId modsToLoad++ fmap catMaybes . forM (zip successes modsToLoad) $ \case+ (Failed,(modName,_)) -> do+ ghcLog <& DebuggerLog Logger.Debug+ (LogFailedToCompileBuiltinModule modName)+ return $ Nothing+ (Succeeded,(modName,_)) ->+ return $ Just modName++ Just uid -> do+ -- 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)+ {- Note [Shutting down the external interpreter] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -534,27 +580,30 @@ from the debuggee units, however doing so doesn't take care of fixing a unitId for dependencies of dependencies. -Note [Do not package-qualify imports for home units]+Note [Package Qualified Imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A package-qualified module import will be looked up directly in the exposed-packages, IGNORING the home units modules.--This can lead to two scenarios:+Package qualified imports have a quirky behaviour: the source string qualifier gets converted into a `PkgQual` on the way, which can be one of these two:+- `ThisPkg unitId` interpreted as a home unit+- `OtherPkg unitId` interpreted as an external package - 1) a package-import of a loaded unit fails, because that unit, despite being- loaded, is not installed+We get each under these conditions:+- ThisPkg+ - qualifier is the literal "this" or the **package name** of the active home unit or any of its home unit dependencies.+- OtherPkg+ - qualifier is the **package name** of a non-hidden external unit which exports the module we are importing.+ - None of the above apply, and the qualifier itself is interpreted as a `UnitId`.+When choosing between multiple units that satisfy a condition, the first found is committed to. - 2) a package-import of a loaded unit succeeds, because a unit with the same- name (but not necessarily the same unit-id!), is installed.+The upshot is that `UnitId`s normally only work as qualifiers for external packages, unless you change the package names of home units as described in Note [ Ambiguous Package Qualified Imports Workaround ]. -The second case can result in subtly wrong interactive sessions, where the+At the same time doing a PackageImport with a plain PackageName can succeed while resolving to an installed unit while we meant one of the loaded units, resulting in subtly wrong interactive sessions, where the package-qualified imported module shadows the loaded module. Perhaps GHC could warn about this. Cabal-repl and ghci also suffer from this subtle interaction. In light of this, when the debugger imports the `haskell-debugger-view` modules, it is imperative that if the `haskell-debugger-view` unit is in the home units (e.g. if `haskell-debugger-view` is listed in the cabal.project, like it is in-the debugger tree), we do not use a package-qualified import.+the debugger tree), we rely on Note [ Ambiguous Package Qualified Imports Workaround ]. On the other hand, if the `haskell-debugger-view` package is not in the home-units, we *should* package-qualify it to make sure we reference the right@@ -580,10 +629,6 @@ sendMessage i Shutdown pure InterpPending --- | WARNING: callback is not to be used from other threads.-withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a-withUnliftGhc k = reifyGhc $ \ s -> k (flip reflectGhc s)- annotateDebuggerStackString :: String -> Debugger a -> Debugger a annotateDebuggerStackString s (Debugger m) = Debugger $ do r <- ReaderT $ \val -> do@@ -608,85 +653,7 @@ dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1 return (dflags2, leftovers, warns) --- | Make an 'ExtInterpInstance' based on an external interpreter process that--- was launched by the DAP client via 'runInTerminal'. The process sends its--- own PID as the first line on the socket before the GHCi wire protocol--- begins.-extInterpFromTerminalProcess :: PortNumber -> IO Interp-extInterpFromTerminalProcess port = do- putStrLn $ "Trying to connect to " ++ show port- Control.Exception.bracketOnError- (openListener port >>= accept)- (\ (sock,_) -> close sock)- (\ (sock,_) -> do- bi_h <- socketToHandle sock ReadWriteMode - pidLine <- annotateCallStackIO $ hGetLine bi_h-- pid <- case readMaybe pidLine :: Maybe Int of- Just pid -> pure pid- Nothing -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine- ph <- mkProcessHandle (fromIntegral pid) False- interpPipe <- mkPipeFromHandles bi_h bi_h- lock <- newMVar ()- let process = InterpProcess- { interpHandle = ph- , interpPipe- , interpLock = lock- }-- pending_frees <- newMVar []- let inst = ExtInterpInstance- { instProcess = process- , instPendingFrees = pending_frees- , instExtra = ()- }- conf = IServConfig- { iservConfProgram = "the process is already running, we should never need to run it again"- , iservConfOpts = []- -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger]- , iservConfDynamic = hostIsDynamic- , iservConfProfiled = hostIsProfiled- , iservConfHook = Nothing -- it's already running!- , iservConfTrace = pure ()- }-- lookup_cache <- mkInterpSymbolCache- s <- newMVar $ InterpRunning inst- loader <- Loader.uninitializedLoader-#if MIN_VERSION_ghc(9,15,0)- fs_cache <- newMVar emptyFsEnv- return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache)-#else- return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)-#endif- )--openListener :: PortNumber -> IO Socket-openListener port = do- addr <- socketAddressFromPort port- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)- -- Must set before bind!- setSocketOption sock ReuseAddr 1-- bind sock (addrAddress addr)- listen sock maxListenQueue-- return sock--socketAddressFromPort :: PortNumber -> IO AddrInfo-socketAddressFromPort port = do- let- hints = defaultHints- { addrSocketType = Stream- , addrFlags = [AI_PASSIVE] -- For wildcard IP (0.0.0.0 or ::)- , addrFamily = AF_UNSPEC -- Allow IPv4 or IPv6- }- addrs <- getAddrInfo (Just hints) Nothing (Just (show port))- case addrs of- addr : _ -> pure addr- [] -> fail ("Could not resolve address for external interpreter port " ++ show port)- {- Note [Custom external interpreter] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -787,6 +754,30 @@ interpreter was compiled (checked with `hostIsDynamic`, since the external interpreter and the debugger, while not necessarily the same process, are the same executable). Ditto for `iservConfProfiled` (with `hostIsProfiled`).++Note [UniqueSupply is process global]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The generation of `Unique`s is controlled by two global pointers declared in the+`ghc` package. The same two pointers are shared by all sessions, since the host+ghc library is only loaded once.++If the pointers get re-initialized while a session is active, that session might generate+the same Unique again and we randomly get panics about identifiers out of scope or+which do not match their expected type and so on.++GHC calls the initialization function in main, with a comment saying it should be done+before initializing plugins.++The only safe time to initialize is if there are no existing Uniques that are still relevant,+and since it's also cheap we do it right away in `main`, for the `cli` or `server` commands.++Contrary to ghc itself, this means we do not honor the `initialUnique` and `uniqueIncrement`+fields of DynFlags, but they seem to be there for testing anyway.++Users of hdb-as-a-library, e.g. using runHDBServer, will have to do the initialization themselves,+especially if they supply any loaded units/modules to us via the DebugRunner,+as those will contain `Unique`s.+ -} -------------------------------------------------------------------------------- @@ -797,13 +788,26 @@ doDownsweep reuse_mg = do hsc_env <- getSession let msg = batchMultiMsg- (errs_base, mod_graph) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic (Just msg) (maybe [] mgModSummaries reuse_mg) [] False+ (errs_base, mod_graph) <- liftIO $+ downsweep+ hsc_env mkUnknownDiagnostic (Just msg)+ (maybe [] mgModSummaries reuse_mg)+#if MIN_VERSION_ghc(10,1,0)+ reuse_mg+#endif+ [] False when (not $ null errs_base) $ do+ -- Print the errors to the user, rather than just throwing. When using DAP,+ -- outputting to the logger the error is what displays it in the "Debug+ -- Console" rather than "Output" DAP log.+ logger <- getLogger+ dflags <- hsc_dflags <$> getSession+ let ghc_errs = fmap GhcDriverMessage (unionManyMessages errs_base)+ liftIO $ printMessages logger (initPrintConfig dflags) (initDiagOpts dflags) ghc_errs #if MIN_VERSION_ghc(9,15,0)- sec <- initSourceErrorContext . hsc_dflags <$> getSession- throwErrors sec (fmap GhcDriverMessage (unionManyMessages errs_base))+ throwErrors (initSourceErrorContext dflags) ghc_errs #else- throwErrors (fmap GhcDriverMessage (unionManyMessages errs_base))+ throwErrors ghc_errs #endif return mod_graph @@ -812,50 +816,46 @@ let msg = batchMultiMsg load' if_cache how_much mkUnknownDiagnostic (Just msg) mg --- | Returns @Just modName@ if the given module was successfully loaded-tryLoadHsDebuggerViewModule- :: GhcMonad m- => LogAction IO DebuggerLog- -> Maybe ModIfaceCache- -> (GHC.Target -> Bool)- -- ^ Predicate to determine which of the existing- -- targets should be re-used when doing downsweep- -- Should be as minimal as necessary (i.e. just DebugView class for the- -- instances modules).- -> ModuleName -> StringBuffer -> m SuccessFlag-tryLoadHsDebuggerViewModule l if_cache keepTarget modName modContents = do- dflags <- getDynFlags- -- Store existing targets to restore afterwards- -- We want to use as little targets as possible to keep downsweep minimal+fast- old_targets <- GHC.getTargets - -- Also: temporarily disable the logger! We don't want to show the user these- -- modules we're trying to load and compile.+loadInMemoryModules ::+ LogAction IO DebuggerLog+ -> UnitId+ -> [(ModuleName,StringBuffer)] -> Ghc [SuccessFlag]+loadInMemoryModules l uid ts = do+ tgts <- forM ts $ \(modName,modContents) ->+ liftIO $ makeInMemoryTarget uid modName modContents+ GHC.setTargets tgts+ mod_graph <- hsc_mod_graph <$> GHC.getSession+ dvc_mod_graph <- doDownsweep (Just mod_graph)+ let new_mod_graph+#if MIN_VERSION_ghc(10,1,0)+ -- new API allows extending an existing graph.+ = dvc_mod_graph+#else+ = mkModuleGraph $ mg_mss dvc_mod_graph ++ mg_mss mod_graph+#endif+ modifySession $ GHC.setModuleGraph new_mod_graph+ restore_logger <- GHC.getLogger+ dflags <- getSessionDynFlags GHC.modifyLogger $ -- Emit it all as Debug-level debugger logs GHC.pushLogHook $ const $ \_ _ _ sdoc -> l <& DebuggerLog Logger.Debug (LogSDoc dflags sdoc) - -- 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 []))+ -- Might not make sense to keep going if the first fails, but we expect all of+ -- them to succeed, and it's not that many more modules.+ s <- forM tgts $ \ tgt -> compileModuleWithDepsInHpt tgt >>= \case+ Nothing -> pure Succeeded+ Just e -> do+ liftLogIO l <& DebuggerLog Logger.Debug (LogSDoc dflags $ text (show e))+ pure Failed -- Restore logger GHC.modifyLogger $ GHC.pushLogHook (const $ GHC.putLogMsg restore_logger) -- return result+ return s -------------------------------------------------------------------------------- -- * Finding Debugger View@@ -872,13 +872,13 @@ -- version of the library to find the built-in instances in). -- -- See also comment on the @'hsDbgViewUnitId'@ field of @'DebuggerState'@-findHsDebuggerViewUnitId :: ModuleGraph -> GHC.Ghc (Maybe UnitId)-findHsDebuggerViewUnitId mod_graph = do+findHsDebuggerViewUnitId :: GHC.Ghc (Maybe UnitId)+findHsDebuggerViewUnitId = do hsc_env <- getSession let unitState = hsc_units hsc_env -- Note: linear in the module graph but only happens once.- let potential_units = graphUnits mod_graph+ let potential_units = graphsUnits hsc_env -- Note: the intermediate set is expected to be small (<= 2). let hskl_dbgr_vws = Set.toList . Set.fromList $ [ uid@@ -948,11 +948,17 @@ "Cannot use unsupported haskell-debugger-view version found in the transitive closure: " ++ showVersion actual ++ " (supported: " ++ L.intercalate ", " (map (\(l,h) -> showVersion l ++ " <= && < " ++ showVersion h) supported) ++ ")" +data NonFatalException = NonFatalException { userMessage :: String, debugMessage :: String }+ deriving Show++instance Exception NonFatalException++ expectRight :: Exception e => Either e a -> Debugger a expectRight s = case s of Left e -> do logSDoc Logger.Error (text $ displayException e)- liftIO $ throwIO e+ liftIO $ throwIO $ NonFatalException { userMessage = displayException e, debugMessage = displayExceptionWithInfo $ toException e } Right a -> do pure a @@ -961,11 +967,24 @@ -------------------------------------------------------------------------------- -- | List all loaded modules 'ModSummary's-getAllLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getAllLoadedModules :: GHC.GhcMonad m => m [GHC.ModuleNodeInfo] getAllLoadedModules =- (GHC.mgModSummaries <$> GHC.getModuleGraph) >>=- filterM (\ms -> GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms))+ (mgInfos . mg_mss <$> GHC.getModuleGraph) >>=+ filterM (\ms -> GHC.isLoadedModule (moduleNodeInfoUnitId ms) (moduleNodeInfoModuleName ms))+ where+ mgInfos xs = [ info | ModuleNode _ info <- xs ] +getAllLoadedModulesWithPaths :: GHC.GhcMonad m =>+ m [(AbsFilePath,GHC.ModuleNodeInfo)]+getAllLoadedModulesWithPaths = do+ ghcCwd <- mkAbsolute <$> liftIO getCurrentDirectory+ -- TODO: cache?+ map (\ m -> (absoluteSourcePath ghcCwd m, m)) <$> getAllLoadedModules+ where+ absoluteSourcePath :: AbsFilePath -> ModuleNodeInfo -> AbsFilePath+ absoluteSourcePath ghcCwdDir ms+ = ghcCwdDir /> (fromMaybe (error $ "missing source path: " ++ show (moduleNodeInfoModuleName ms)) $ ml_hs_file (moduleNodeInfoLocation ms))+ -------------------------------------------------------------------------------- -- * Forcing laziness --------------------------------------------------------------------------------@@ -1014,49 +1033,8 @@ _ -> do seqTerm hsc_env t ------------------------------------------------------------------------------------ * Logging------------------------------------------------------------------------------------- | A debugger log. May include debuggee ouput.-data DebuggerLog- = DebuggerLog !Logger.Severity !DebuggerMessage- | GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc- | LogDebuggeeOut !Text- | LogDebuggeeErr !Text---- | A debugger log message-data DebuggerMessage- = LogSDoc !DynFlags !SDoc- | LogFailedToCompileDebugViewModule !GHC.ModuleName- | LogSkippingViewModuleNoPkg !GHC.ModuleName String [String]--instance Show DebuggerMessage where- show = \ case- LogFailedToCompileDebugViewModule mn ->- "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views."- LogSkippingViewModuleNoPkg mn pkg uids ->- "Skipping compilation of built-in " ++ moduleNameString mn ++ " module because package "- ++ show pkg ++ " wasn't found in dependencies " ++ show uids- LogSDoc dflags doc -> showSDoc dflags doc- logSDoc :: Logger.Severity -> SDoc -> Debugger () logSDoc sev doc = do dflags <- getDynFlags l <- asks dbgLogger l <& DebuggerLog sev (LogSDoc dflags doc)--ghcLogAction :: LogAction IO DebuggerLog -> GHC.LogAction-ghcLogAction l = \logflags mclass srcSpan sdoc -> do- liftLogIO l <& GHCLog logflags mclass srcSpan sdoc--msgClassSeverity :: MessageClass -> Logger.Severity-msgClassSeverity = \case- MCOutput -> Info- MCFatal -> Logger.Error- MCInteractive -> Info- MCDump -> Debug- MCInfo -> Info- MCDiagnostic SevIgnore _ _ -> Debug -- ?- MCDiagnostic SevWarning _ _ -> Logger.Warning- MCDiagnostic SevError _ _ -> Logger.Error
haskell-debugger/GHC/Debugger/Run.hs view
@@ -16,10 +16,7 @@ import Control.Monad.Catch import Control.Monad.Reader import Data.IORef-import qualified Data.List as List import Data.Maybe-import System.FilePath-import System.Directory import GHC qualified import GHC (@@ -30,30 +27,26 @@ GhciLStmt, GhcPs, InteractiveImport (..),- mkHsString, ModSummary (..), Name,- nlHsLit,- nlList, parseImportDecl, SingleStep (..), SrcSpan (..), StmtLR (..), unLoc,+ mkHsString,+ nlList,+ nlHsLit, ) import GHC.Plugins (SourceError)-import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)+import qualified GHC.Plugins as GHC import GHC.Unit.Types-import GHC.Data.FastString import GHC.Driver.DynFlags as GHC import GHC.Driver.Main (hscParseStmtWithLocation) import GHC.Driver.Monad as GHC import GHC.Driver.Env as GHC import qualified GHC.Driver.Config.Parser as GHC import GHC.Runtime.Debugger.Breakpoints as GHC-import qualified GHC.Unit.Module.ModSummary as GHC-import GHC.Types.Name.Occurrence (mkVarOccFS)-import GHC.Types.Name.Reader as RdrName (mkOrig) import qualified GHCi.Message as GHCi import qualified GHC.Data.Strict as Strict @@ -65,28 +58,33 @@ import qualified GHC.Debugger.Breakpoint.Map as BM import GHC.Debugger.Runtime.Thread import GHC.Debugger.Session (setInteractiveDebuggerDynFlags, getInteractiveDebuggerDynFlags, resumeExec)+import Data.List (find)+import GHC.Unit.Module.Graph as GHC+import GHC.Debugger.Session.Builtin (runInternal, debuggerRuntimeInternalModName) + -------------------------------------------------------------------------------- -- * Evaluation -------------------------------------------------------------------------------- -- | Run a program with debugging enabled-debugExecution :: FilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult+debugExecution :: AbsFilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult debugExecution entryFile entry args = do -- consider always using :trace like ghci-dap to always have a stacktrace? -- better solution could involve profiling stack traces or from IPE info? modSummaryOfEntryFile <- findUnitIdOfEntryFile entryFile- let modOfEntryFile = GHC.ms_mod modSummaryOfEntryFile- unitIdOfEntryFile = GHC.ms_unitid modSummaryOfEntryFile+ let modOfEntryFile = GHC.moduleNodeInfoModule modSummaryOfEntryFile+ unitIdOfEntryFile = GHC.moduleNodeInfoUnitId modSummaryOfEntryFile let evalModule = mkModule (RealUnit (Definite unitIdOfEntryFile)) (moduleName modOfEntryFile) - logSDoc Logger.Debug $ "Eval Module Context:" <+> ppr evalModule+ logSDoc Logger.Debug $ "Eval inputs: " <+> text (show (entryFile,entry,args))+ logSDoc Logger.Debug $ "Eval Module Context:" <+> withPprStyle (PprDump reallyAlwaysQualify) (ppr evalModule) <+> ppr (moduleNodeInfoLocation modSummaryOfEntryFile) old_context <- GHC.getContext- GHC.setContext [GHC.IIModule evalModule]+ GHC.setContext [IIModule evalModule] (entryExp, exOpts) <- case entry of MainEntry nm -> do@@ -101,13 +99,24 @@ -- TODO: if "args" is unescaped (e.g. "some", "thing"), then "some" and -- "thing" will be interpreted as variables. To pass strings it needs to -- be "\"some\"" "\"things\"".- return (fn ++ " " ++ unwords args, GHC.execOptions)+ return (apply fn args, GHC.execOptions) + logSDoc Logger.Debug "Compiled wrapper."+ exec_res <- GHC.execStmt entryExp exOpts- GHC.setContext old_context -- restore context after running `main`- handleExecResult exec_res++ logSDoc Logger.Debug $ "Executed entryExp: " <+> text entryExp++ GHC.setContext old_context++ res <- handleExecResult exec_res+ logSDoc Logger.Debug $ "Computed EvalResult."+ pure res where- -- It's not ideal to duplicate these two functions from ghci, but its unclear where they would better live. Perhaps next to compileParsedExprRemote? The issue is run+ apply x xs = unwords $ x : map (\ a -> "(" ++ a ++ ")") xs++ -- mkEvalWrapper is mostly duplicating ghci's implementation, except we+ -- reference `evalWrapper` from GHC.Debugger.Runtime.Internal (See Note [debuggerInternal unit]). mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue mkEvalWrapper progname' args' = runInternal $ GHC.compileParsedExprRemote@@ -115,32 +124,18 @@ `GHC.mkHsApp` nlList (map nlHsString args') where nlHsString = nlHsLit . mkHsString+ evalWrapper' :: GHC.LHsExpr GhcPs evalWrapper' =- GHC.nlHsVar $ RdrName.mkOrig gHC_INTERNAL_GHCI_HELPERS (mkVarOccFS (fsLit "evalWrapper"))-- -- run internal here serves to overwrite certain flags while executing the- -- internal "evalWrapper" computation which is not relevant to the user.- runInternal :: GhcMonad m => m a -> m a- runInternal =- withTempSession mkTempSession- where- mkTempSession = hscUpdateFlags (\dflags -> dflags- { -- Disable dumping of any data during evaluation of GHCi's internal expressions. (#17500)- dumpFlags = mempty- }- -- We depend on -fimplicit-import-qualified to compile expr- -- with fully qualified names without imports (gHC_INTERNAL_GHCI_HELPERS above).- `gopt_set` Opt_ImplicitImportQualified- )+ GHC.nlHsVar $ GHC.mkRdrQual debuggerRuntimeInternalModName (GHC.mkVarOcc "evalWrapper") - findUnitIdOfEntryFile :: GhcMonad m => FilePath -> m GHC.ModSummary- findUnitIdOfEntryFile fp = do- afp <- normalise <$> liftIO (makeAbsolute fp)- modSums <- getAllLoadedModules- let normalisedModLoc = fmap normalise . GHC.ml_hs_file . GHC.ms_location- case List.find ((Just afp ==) . normalisedModLoc) modSums of- Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp ++ "\nCandidates were:\n" ++ unlines (map (show . normalisedModLoc) modSums)- Just summary -> pure summary+ findUnitIdOfEntryFile :: GhcMonad m => AbsFilePath -> m GHC.ModuleNodeInfo+ findUnitIdOfEntryFile afp = do+ modSums <- getAllLoadedModulesWithPaths+ case find ((== unAbs afp) . unAbs . fst) modSums of+ Nothing -> do+ let norms = map fst modSums+ error $ "findUnitIdOfEntryFile: no unit id found for: " ++ unAbs afp ++ "\nCandidates were:\n" ++ unlines (map show norms)+ Just (_,summary) -> pure summary -- | Resume execution of the stopped debuggee program doContinue :: Debugger EvalResult@@ -211,7 +206,7 @@ -- | Evaluate expression. Includes context of breakpoint if stopped at one (the current interactive context). doEval :: String -> Debugger EvalResult-doEval expr = withCurrentBreakExtensions $ do+doEval expr = withCurrentBreakEnv $ do excr <- (Right <$> exec expr GHC.execOptions) `catch` \(e::SomeException) -> pure (Left (displayException e)) case excr of Left err -> pure $ EvalAbortedWith err@@ -250,20 +245,23 @@ GHC.ExecBreak{} -> continueToCompletion GHC.ExecComplete{} -> return execr --- | @withCurrentBreakExtensions m@ executes @m@ with the language and language+-- | @withCurrentBreakEnv m@ executes @m@ with the imports, language, and language -- extensions of the current breakpoint source module. -- -- If we are not stopped at a breakpoint @m@ is executed with no change.-withCurrentBreakExtensions :: Debugger a -> Debugger a-withCurrentBreakExtensions m = do+withCurrentBreakEnv :: Debugger a -> Debugger a+withCurrentBreakEnv m = do mmodl <- getCurrentBreakModule case mmodl of Nothing -> m Just breakModule -> do ic_dyn_flags <- getInteractiveDebuggerDynFlags break_dyn_flags <- ms_hspp_opts <$> GHC.getModSummary breakModule+ old_context <- GHC.getContext setInteractiveDebuggerDynFlags $ adjustFlags ic_dyn_flags break_dyn_flags+ GHC.setContext (IIModule breakModule : old_context) x <- m+ GHC.setContext old_context setInteractiveDebuggerDynFlags ic_dyn_flags return x where@@ -296,7 +294,6 @@ return EvalStopped{ breakId = Nothing , breakThread = rt_id } ExecBreak {breakNames = _, breakPointId = Just bid} -> do- let performAction BreakpointStop = do rt_id <- getRemoteThreadIdFromContext
haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs view
@@ -27,7 +27,20 @@ import GHC.Debugger.Runtime.Eval.RemoteExpr (RemoteExpr) import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import GHC.Stack.Annotation.Experimental+import GHC.Types.SrcLoc+import GHC.Debugger.Session.Builtin (debuggerRuntimeInternalModName)+import qualified GHC.Exts.Heap.Closures as GHC+import GHCi.RemoteTypes (HValue) +pair :: Remote.RemoteExpr (a -> b -> (a,b))+pair = Remote.raw "(,)"++fst :: Remote.RemoteExpr ((a,b) -> a)+fst = Remote.raw "Prelude.fst"++snd :: Remote.RemoteExpr ((a,b) -> b)+snd = Remote.raw "Prelude.snd"+ -- | Remote 'GHC.Stack.CloneStack.cloneThreadStack' cloneThreadStack :: RemoteExpr ThreadId -> RemoteExpr (IO StackSnapshot) cloneThreadStack = Remote.app $ Remote.var (mkModuleName "GHC.Stack.CloneStack") "cloneThreadStack" []@@ -88,5 +101,15 @@ composeVar = Remote.var (mkModuleName "GHC.Base") "." [] displayStackAnnotation :: RemoteExpr SomeStackAnnotation -> RemoteExpr String-displayStackAnnotation = Remote.app $- Remote.var (mkModuleName "GHC.Stack.Annotation.Experimental") "displayStackAnnotation" ["SomeStackAnnotation"]+displayStackAnnotation = Remote.app $ Remote.var (mkModuleName "GHC.Internal.Stack.Annotation") "displayStackAnnotation" ["GHC.Stack.Annotation.Experimental.SomeStackAnnotation"]++displayStackAnnotationShort :: RemoteExpr SomeStackAnnotation -> RemoteExpr String+displayStackAnnotationShort = Remote.app $ Remote.var (mkModuleName "GHC.Internal.Stack.Annotation") "displayStackAnnotationShort" ["GHC.Stack.Annotation.Experimental.SomeStackAnnotation"]++stackAnnotationSourceLocation :: RemoteExpr SomeStackAnnotation -> RemoteExpr (Maybe SrcLoc)+stackAnnotationSourceLocation = Remote.app $ Remote.var (mkModuleName "GHC.Internal.Stack.Annotation") "stackAnnotationSourceLocation" ["SGHC.Stack.Annotation.Experimental.omeStackAnnotation"]++unpackStackFields :: Remote.RemoteExpr ([GHC.StackField] -> Maybe [Int] -> IO [HValue])+unpackStackFields = Remote.var debuggerRuntimeInternalModName "unpackStackFields" []++
+ haskell-debugger/GHC/Debugger/Runtime/FFIInspect.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}+module GHC.Debugger.Runtime.FFIInspect where+import GHC.Base (StackSnapshot#)+import GHC.Stack.CloneStack++foreign import ccall unsafe "stack.h" bco_args_offset :: StackSnapshot# -> Word -> Int+foreign import ccall unsafe "stack.h" stack_bco_frame_selftest :: IO Bool+++-- | Takes a frame location for a continuation RET_BCO frame.+-- Returns the offset of `bcoArgs` in the AP_STACK object that you'd get if stopping at the beginning of the continuation BCO.+bcoArgsOffset :: StackSnapshot -> Int -> Maybe Word+bcoArgsOffset (StackSnapshot ss) frame_offset =+ case bco_args_offset ss (fromIntegral frame_offset) of+ i | i < 0 -> Nothing+ | otherwise -> Just $ fromIntegral i
haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs view
@@ -18,7 +18,11 @@ import Control.Monad.Reader import GHC+#if MIN_VERSION_ghc(10,1,0)+import GHC.Builtin.KnownKeys (ioTyConKey)+#else import GHC.Builtin.Names+#endif import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Map.Type@@ -110,15 +114,29 @@ let modl = mkModule (RealUnit (Definite hdv_uid)) debuggerViewClassModName let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr) :: RdrName - (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ do+ (err_msgs, res) <- liftIO $+ runTcInteractive+#if MIN_VERSION_ghc(10,1,0)+ StartAndStopTcMPlugins+#endif+ hsc_env $ do - -- Types used by DebugView+ -- Types used by DebugView.+#if MIN_VERSION_ghc(10,1,0)+ let lookupTyConName occ = greName <$> lookupTypeOccRn occ+#else+ let lookupTyConName occ = lookupTypeOccRn occ+#endif varValueIOTy <- fmap mkTyConTy . tcLookupTyCon- =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarValueIO"))+ =<< lookupTyConName (mkOrig modl (mkTcOcc "VarValueIO")) varFieldsIOTy <- fmap mkTyConTy . tcLookupTyCon- =<< lookupTypeOccRn (mkOrig modl (mkTcOcc "VarFieldsIO"))+ =<< lookupTyConName (mkOrig modl (mkTcOcc "VarFieldsIO")) +#if MIN_VERSION_ghc(10,1,0)+ ioTyCon <- tcLookupKnownKeyTyCon ioTyConKey+#else ioTyCon <- tcLookupTyCon ioTyConName+#endif -- Try to compile and load an expression for all methods of `DebugView` -- applied to the dictionary for the given Type (`needle_ty`)
+ haskell-debugger/GHC/Debugger/Runtime/Internal.hs view
@@ -0,0 +1,55 @@+-- | A module providing various remote external variables which we want+-- available in any session. It gets compiled in-memory at the start of one.+--+-- See Note [debuggerInternal unit].+{-# LANGUAGE LambdaCase #-}+module GHC.Debugger.Runtime.Internal+ ( module GHC.Debugger.Runtime.Internal+ , GHC.evalWrapper+ , Prelude.concat+ , Prelude.putStrLn+ )+ where++import GHC.GHCi.Helpers qualified as GHC+import GHCi.RemoteTypes+import qualified Unsafe.Coerce+import GHC.Exts.Heap.Closures+import Data.Maybe+import Data.List+import GHC.Base (returnIO)+import qualified System.IO++-- | Some extensions can mess with [] and (:) syntax, so we setup these plain+-- function aliases.+nil :: [a]+nil = []++-- | See @nil@.+cons :: a -> [a] -> [a]+cons = (:)+++-- Need to be careful not to create extra thunks in the returned `HValue`s, but+-- also avoid forcing the inside of a `Box`.+-- See Note [Forcing debuggee's thunks].+unpackStackField :: StackField -> IO HValue+unpackStackField x = case x of+ (StackBox (Box a)) -> returnIO (HValue a)+ (StackWord w) -> returnIO (HValue (Unsafe.Coerce.unsafeCoerce w))++unpackStackFields :: [StackField] -> Maybe [Int] -> IO [HValue]+unpackStackFields fs = \case+ Nothing -> mapM unpackStackField fs+ Just xs -> flip mapM xs $ \ i ->+ unpackStackField (fromMaybe (error ("Looking up StackField: " ++ show i)) (fs !? i))++-- | We @setInteractivePrintName@ with this so REPL results are forced but not+-- already printed to debug console.+noPrintConstant :: a -> IO ()+noPrintConstant x = x `seq` return ()++setLineBuffering :: IO ()+setLineBuffering = do+ System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering+ System.IO.hSetBuffering System.IO.stderr System.IO.LineBuffering
haskell-debugger/GHC/Debugger/Runtime/Interpreter.hs view
@@ -42,6 +42,7 @@ ( listThreads , decodeThreadStack , collectExceptionInfo+ , unpackStackFields -- * Re-exports , ThreadInfo(..)@@ -53,13 +54,15 @@ import GHCi.RemoteTypes import GHC.Debugger.Monad -import GHC.Debugger.Interface.Messages (ExceptionInfo)+import GHC.Debugger.Interface.Messages (ExceptionInfo,NoShow(..),DbgStackFrameBCOArgs(..)) import GHC.Debugger.Runtime.Interpreter.Custom+import GHC.Debugger.Runtime.Interpreter.Types import Data.Binary import GHC.Driver.Env (hscInterp) import GHC.Driver.Monad (getSession) import GHC.Runtime.Interpreter+import GHC.Exts.Heap.Closures (StackField) import Control.Concurrent import Control.Exception @@ -80,17 +83,29 @@ threadInfoForeignRef <- liftIO $ mkFinalizedHValue interp threadInfoRef pure ti{threadInfoRef = threadInfoForeignRef} -decodeThreadStack :: ForeignRef ThreadId -> Debugger [StackFrameInfo]+decodeThreadStack :: ForeignRef ThreadId -> Debugger [StackFrameInfo ForeignRef] decodeThreadStack ftid = do interp <- hscInterp <$> getSession- liftIO $ withForeignRef ftid $+ fis <- liftIO $ withForeignRef ftid $ interpDbgCmd interp . DecodeThreadStack+ forM fis $ \case+ StackFrameBreakpointInfo ibi (DbgStackFrameBCOArgs (NoShow bcoArgsRef) tag) -> do+ bcoArgsForeignRef <- liftIO $ mkFinalizedHValue interp bcoArgsRef+ pure $ StackFrameBreakpointInfo ibi (DbgStackFrameBCOArgs (NoShow bcoArgsForeignRef) tag)+ StackFrameIPEInfo x -> pure $ StackFrameIPEInfo x+ StackFrameAnnotation x y -> pure $ StackFrameAnnotation x y collectExceptionInfo :: ForeignRef SomeException -> Debugger ExceptionInfo collectExceptionInfo excRef = do interp <- hscInterp <$> getSession liftIO $ withForeignRef excRef $ interpDbgCmd interp . CollectExceptionInfo++unpackStackFields :: ForeignRef [StackField] -> Maybe [Int] -> Debugger [ForeignHValue]+unpackStackFields fldsRef mixs = do+ interp <- hscInterp <$> getSession+ liftIO $ withForeignRef fldsRef $ \ flds ->+ mapM (mkFinalizedHValue interp) =<< interpDbgCmd interp (UnpackStackFields flds mixs) -------------------------------------------------------------------------------- -- * IO+interpreter abstraction
haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs view
@@ -5,9 +5,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeAbstractions #-} {-# OPTIONS_GHC -Wno-orphans #-} -- necessary Binary instances-module GHC.Debugger.Runtime.Interpreter.Custom where -import GHC.Generics (Generic)+-- | This module implements the custom commands supported by HDB as a GHC interpreter.+-- Only functions that will execute on the interpreter side should be defined here.+module GHC.Debugger.Runtime.Interpreter.Custom where import GHCi.Message import GHCi.RemoteTypes@@ -19,7 +20,7 @@ import Foreign.C.String import GHC.ByteCode.Types import GHC.Conc.Sync-import GHC.Exts.Heap.Closures (StackFrame, GenStackFrame (..), Box (..))+import GHC.Exts.Heap.Closures (StackFrame, GenStackFrame (..), Box (..), StackField) import GHC.InfoProv import GHC.Runtime.Interpreter (evalBreakpointToId) import GHC.Stack.Annotation.Experimental@@ -32,11 +33,13 @@ import qualified GHC.Stack as Stack import GHC.Unit.Module import Control.Exception-import GHC.Debugger.Interface.Messages (SourceSpan (..), ExceptionInfo (..))+import System.Directory (getCurrentDirectory)+import GHC.Debugger.Interface.Messages (SourceSpan (..), ExceptionInfo (..), AbsFilePath (unAbs), mkAbsolute, NoShow(..))+import GHC.Debugger.Runtime.Interpreter.Types import Control.Exception.Context import Data.Typeable #if MIN_VERSION_ghc(9,15,0)-import GHC.Debugger.Interface.Messages (srcLocToSourceSpan)+import GHC.Debugger.Interface.Messages (srcLocToSourceSpan, DbgStackFrameBCOArgs(..)) import Data.Maybe import Control.Exception.Backtrace import GHC.Exception@@ -44,32 +47,18 @@ import qualified GHC.Stack.Decode.Experimental as Stack import qualified GHC.Exception.Backtrace.Experimental as Backtrace #endif+import qualified GHC.Debugger.Runtime.Internal as Internal+import qualified GHC.Debugger.Runtime.FFIInspect as FFIInspect -------------------------------------------------------------------------------- -- * Custom Commands -------------------------------------------------------------------------------- -data ThreadInfo ref = ThreadInfo- { threadInfoRef :: !(ref ThreadId)- , threadInfoLabel :: !(Maybe String)- , threadInfoStatus :: !ThreadStatus- }- deriving (Generic)---- | Information about a stack frame-data StackFrameInfo- -- | Information derived from an IPE entry- = StackFrameIPEInfo !InfoProv- -- | User-defined Stack Frame annotation- | StackFrameAnnotation !(Maybe Stack.SrcLoc) !String- -- | Information derived from a continuation BCO breakpoint info.- | StackFrameBreakpointInfo !InternalBreakpointId- deriving (Generic)- data DbgInterpCmd a where ListThreads :: DbgInterpCmd [ThreadInfo RemoteRef]- DecodeThreadStack :: RemoteRef ThreadId -> DbgInterpCmd [StackFrameInfo]+ DecodeThreadStack :: RemoteRef ThreadId -> DbgInterpCmd [StackFrameInfo RemoteRef] CollectExceptionInfo :: RemoteRef SomeException -> DbgInterpCmd ExceptionInfo+ UnpackStackFields :: RemoteRef [StackField] -> Maybe [Int] -> DbgInterpCmd [RemoteRef HValue] dbgInterpCmdTag :: Word8 dbgInterpCmdTag = 0x25@@ -82,7 +71,6 @@ runDbgInterpCmd :: DbgInterpCmd a -> IO a runDbgInterpCmd = \case ListThreads -> mapM threadInfo =<< listThreads-#if MIN_VERSION_ghc(9,14,2) -- decodeStackWithIpe exposed from 9.14.2 onwards (see #27065) DecodeThreadStack threadIdRef -> do -- We clone the stack of the thread and decode it in the external interpreter to avoid@@ -93,14 +81,15 @@ threadId <- localRef threadIdRef clonedStack <- Stack.cloneThreadStack threadId frames <- Stack.decodeStackWithIpe clonedStack- catMaybes <$> mapM stackFrameInfo frames-#else- DecodeThreadStack _ -> fail "Decoding thread stacks is not supported on GHC versions prior to 9.14.2, which exposes the necessary decodeStackWithIpe functions. Please upgrade to GHC 9.14.2 or later to use this feature."-#endif+ catMaybes <$> mapM (stackFrameInfo clonedStack) (zip [0..] frames) CollectExceptionInfo excRef -> do exc <- localRef excRef- let info = exceptionInfo exc+ cwd <- mkAbsolute <$> getCurrentDirectory+ let info = exceptionInfo cwd exc return info+ UnpackStackFields fldsRef mixs -> do+ flds <- localRef fldsRef+ mapM mkRemoteRef =<< Internal.unpackStackFields flds mixs -- | Run a serialized custom 'DbgInterpCmd'. This is used in conjunction with@@ -137,19 +126,31 @@ -- 1. Try stack annotations first -- 2. Try IPE next -- 3. Try decoding a continuation BCO with a breakpoint next-stackFrameInfo :: (StackFrame, Maybe InfoProv) -> IO (Maybe StackFrameInfo)-stackFrameInfo (AnnFrame{annotation}, _)+stackFrameInfo :: Stack.StackSnapshot -> (Int,(StackFrame, Maybe InfoProv)) -> IO (Maybe (StackFrameInfo RemoteRef))+stackFrameInfo _ss (_,(AnnFrame{annotation}, _)) | let Box annVal = annotation- , let stack_anno = displayStackAnnotation @SomeStackAnnotation (unsafeCoerce annVal)- = pure $ Just $ StackFrameAnnotation Nothing{-No source locations yet-} stack_anno-stackFrameInfo (_, Just ipe)+ , let stack_frame = stackAnnoToStackFrameInfo (unsafeCoerce @_ @SomeStackAnnotation annVal)+ = pure $ Just stack_frame+stackFrameInfo _ss (_,(_, Just ipe)) = pure $ Just (StackFrameIPEInfo ipe)-stackFrameInfo (RetBCO{bco}, _)+stackFrameInfo ss (frameIx,(RetBCO{bco,bcoArgs}, _)) | let !(Box !bco_hval) = bco -- needs to be forced for `getClosureData` to look at the right thing.- = fmap StackFrameBreakpointInfo <$> (lookupBCOBreakpoint =<< Heap.getClosureData bco_hval)-stackFrameInfo _+ = do+ xs <- NoShow <$> mkRemoteRef bcoArgs+ -- TODO: change ghc upstream so this offset is available from CgBreakInfo.+ let offset = FFIInspect.bcoArgsOffset ss frameIx+ fmap (\ ibi -> StackFrameBreakpointInfo ibi (DbgStackFrameBCOArgs xs offset)) <$> (lookupBCOBreakpoint =<< Heap.getClosureData bco_hval)+stackFrameInfo _ _ = pure Nothing +stackAnnoToStackFrameInfo :: SomeStackAnnotation -> StackFrameInfo ref+stackAnnoToStackFrameInfo stack_anno =+#if MIN_VERSION_ghc_experimental(9,1402,0)+ StackFrameAnnotation (stackAnnotationSourceLocation stack_anno) (displayStackAnnotationShort stack_anno)+#else+ StackFrameAnnotation Nothing {-No source locations yet-} (displayStackAnnotation stack_anno)+#endif+ -- | Try to find a BRK_FUN breakpoint location at the start of a BCO heap closure lookupBCOBreakpoint :: Heap.GenClosure Box -> IO (Maybe InternalBreakpointId) lookupBCOBreakpoint Heap.BCOClosure{..}@@ -199,8 +200,8 @@ brk_info_ix_lo = index_at 5# lookupBCOBreakpoint _ = pure Nothing -exceptionInfo :: SomeException -> ExceptionInfo-exceptionInfo se'@(SomeException exc) =+exceptionInfo :: AbsFilePath -> SomeException -> ExceptionInfo+exceptionInfo prefix se'@(SomeException exc) = ExceptionInfo { exceptionInfoTypeName = simpleTypeName , exceptionInfoFullTypeName = fullTypeName@@ -213,7 +214,7 @@ ctx = someExceptionContext se' rendered = displayExceptionContext ctx whileHandling = getExceptionAnnotations ctx- innerNodes = map (exceptionInfo . unwrap) whileHandling+ innerNodes = map (exceptionInfo prefix . unwrap) whileHandling simpleTypeName = tyConName tc modulePrefix = case tyConModule tc of mdl | null mdl -> ""@@ -230,7 +231,7 @@ #if MIN_VERSION_ghc(9,15,0) exceptionContextLocation = let fromCallStack cs = case listToMaybe (getCallStack cs) of- Just (_, loc) -> Just (srcLocToSourceSpan loc)+ Just (_, loc) -> Just (srcLocToSourceSpan prefix loc) Nothing -> Nothing bts :: [Backtraces] bts = getExceptionAnnotations ctx@@ -268,6 +269,10 @@ CollectExceptionInfo excRef -> do Bin.put (2 :: Word8) Bin.put excRef+ UnpackStackFields ref mixs -> do+ Bin.put (3 :: Word8)+ Bin.put ref+ Bin.put mixs get = do (tag :: Word8) <- Bin.get@@ -275,21 +280,24 @@ 0 -> pure (Some ListThreads) 1 -> Some . DecodeThreadStack <$> Bin.get 2 -> Some . CollectExceptionInfo <$> Bin.get+ 3 -> Some <$> (UnpackStackFields <$> Bin.get <*> Bin.get) _ -> fail ("Unknown debugger thread command tag: " ++ show tag) instance Bin.Binary (ThreadInfo RemoteRef)-instance Bin.Binary StackFrameInfo+deriving instance Bin.Binary a => Bin.Binary (NoShow a)+instance Bin.Binary (DbgStackFrameBCOArgs RemoteRef)+instance Bin.Binary (StackFrameInfo RemoteRef) instance Bin.Binary Stack.SrcLoc instance Bin.Binary SourceSpan where put SourceSpan{..} = do- Bin.put file+ Bin.put (unAbs file) Bin.put startLine Bin.put endLine Bin.put startCol Bin.put endCol get = do- file <- Bin.get+ file <- mkAbsolute <$> Bin.get startLine <- Bin.get endLine <- Bin.get startCol <- Bin.get
+ haskell-debugger/GHC/Debugger/Runtime/Interpreter/Legacy.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE OrPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultilineStrings #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+module GHC.Debugger.Runtime.Interpreter.Legacy+ ( listThreads+ , decodeThreadStack+ , collectExceptionInfo+ , unpackStackFields+ ) where++import Control.Exception (SomeException)+import System.Directory (getCurrentDirectory)+import Colog.Core as Logger+import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Data.Bits+import Data.Functor+import Data.Maybe+import GHC+import GHC.Builtin.Types+import GHC.Conc.Sync hiding (listThreads)+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Monad+import GHC.Debugger.Runtime.Eval+import GHC.Debugger.Runtime.Interpreter.Types+import GHC.Debugger.Runtime.Term.Parser+import GHC.Driver.Env+import GHC.Exts.Heap.ClosureTypes+import GHC.InfoProv+import GHC.Runtime.Heap.Inspect+import GHC.Runtime.Interpreter as Interp+import GHC.Utils.Encoding.UTF8+import GHC.Utils.Outputable as Ppr+import GHCi.Message+import GHCi.RemoteTypes+import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote+import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote+import qualified GHC.Stack.Types as Stack+import qualified GHC.Stack.CloneStack as Stack+import qualified GHC.Exts.Heap.Closures as Stack+import GHC.Debugger.Session.Builtin (debuggerRuntimeFFIInspectModName, runInternal)+import GHC.Stack.CloneStack (StackSnapshot)++-- GHC 9.14: use @evalX@ and @TermParser@ to do this all without custom commands++--------------------------------------------------------------------------------+-- * Threads+--------------------------------------------------------------------------------++listThreads :: Debugger [ThreadInfo ForeignRef]+listThreads = runInternal $ do+ threads_fvs <- expectRight =<< Remote.evalIOList Remote.listThreads+ labels <- getRemoteThreadsLabels threads_fvs+ forM (zip threads_fvs labels) $ \(castForeignRef -> thread_fv, label) -> do+ status <- getRemoteThreadStatus thread_fv+ pure ThreadInfo+ { threadInfoStatus = status+ , threadInfoLabel = label+ , threadInfoRef = thread_fv+ }++-- | Is the remote thread running or blocked (NOT finished NOR dead)?+getRemoteThreadStatus :: ForeignRef ThreadId -> Debugger ThreadStatus+getRemoteThreadStatus threadIdRef = do+ status_fv <- expectRight =<< Remote.evalIO+ (Remote.threadStatus (Remote.ref threadIdRef))+ status_parsed <-+ obtainParsedTerm "ThreadStatus" 2 True anyTy{-..no..-} (castForeignRef status_fv) threadStatusParser++ case status_parsed of+ Left errs -> do+ logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+ liftIO $ fail "Failed to parse ThreadStatus"+ Right thrdStatus ->+ return thrdStatus++getRemoteThreadsLabels :: [ForeignRef ThreadId] -> Debugger [Maybe String]+getRemoteThreadsLabels threadIdRefs = do++ forM threadIdRefs $ \threadIdRef -> do++ r <- Remote.evalIOList $ Remote.do+ mb_str <- Remote.threadLabel (Remote.ref threadIdRef)+ Remote.return (Remote.maybeToList mb_str)++ expectRight r >>= \case+ [] -> pure Nothing+ [io_lbl_fv] -> Just <$> (expectRight =<< Remote.evalString (Remote.ref io_lbl_fv))+ _ -> liftIO $ fail "Unexpected result from evaluating \"threadLabel\""++--------------------------------------------------------------------------------+-- *** TermParsers+--------------------------------------------------------------------------------++threadStatusParser :: TermParser ThreadStatus+threadStatusParser = do+ (matchConstructorTerm "ThreadRunning" $> ThreadRunning)+ <|> (matchConstructorTerm "ThreadFinished" $> ThreadFinished)+ <|> (matchConstructorTerm "ThreadDied" $> ThreadDied)+ <|> (matchConstructorTerm "ThreadBlocked" *> (ThreadBlocked <$> subtermWith 0 blockedReasonParser))++blockedReasonParser :: TermParser BlockReason+blockedReasonParser = do+ (matchConstructorTerm "BlockedOnMVar" $> BlockedOnMVar)+ <|> (matchConstructorTerm "BlockedOnBlackHole" $> BlockedOnBlackHole)+ <|> (matchConstructorTerm "BlockedOnException" $> BlockedOnException)+ <|> (matchConstructorTerm "BlockedOnSTM" $> BlockedOnSTM)+ <|> (matchConstructorTerm "BlockedOnForeignCall" $> BlockedOnForeignCall)+ <|> (matchConstructorTerm "BlockedOnOther" $> BlockedOnOther)+++--------------------------------------------------------------------------------+-- * Thread stack frames+--------------------------------------------------------------------------------++decodeThreadStack :: ForeignRef ThreadId -> Debugger [StackFrameInfo ForeignRef]+decodeThreadStack threadIdRef = runInternal $ do+ l <- Remote.evalIO $ Remote.do+ clonedStack <- Remote.cloneThreadStack (Remote.ref threadIdRef)+ frames <- Remote.decodeStackWithIpe clonedStack+ Remote.return $ Remote.pair `Remote.app` clonedStack `Remote.app` frames++ case l of+ Left (EvalRaisedException e) -> do+ logSDoc Logger.Info (text "Failed to decode the stack with" <+> text (show e) $$ text "This is likely bug #26640 in the decoder, which has been fixed for 9.14.2 and forward. No StackTrace will be returned...")+ return []+ Left e -> do+ logSDoc Logger.Warning (text "Failed to decode the stack with" <+> text (show e) $$ text "No StackTrace will be returned...")+ return []+ Right p_fv -> do+ stack_frames_fvs <-+ (expectRight =<<) $ Remote.evalIOList $ Remote.do+ Remote.return $ Remote.snd `Remote.appRef` p_fv+ cloned_stack_fv <-+ (expectRight =<<) $ Remote.evalIO $ Remote.do+ Remote.return $ Remote.fst `Remote.appRef` p_fv++ fmap catMaybes $ do+ forM (zip stack_frames_fvs [0..]) $ \ (stack_frame_fv,ix) -> do+ obtainParsedTerm "ghc-heap:StackFrame" 2 True anyTy{-todo:stackframety?-} (castForeignRef stack_frame_fv)+ (stackFrameInfoParser cloned_stack_fv ix) >>= \case+ Left errs -> do+ logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+ return Nothing+ Right tm -> do+ return tm++--------------------------------------------------------------------------------+-- ** Decoding Stack Frames ----------------------------------------------------+--------------------------------------------------------------------------------++-- | Try to decode a 'StackFrameInfo' from a @(StackFrame, Maybe InfoProv)@ term+stackFrameInfoParser :: ForeignRef Stack.StackSnapshot -> Int -> TermParser (Maybe (StackFrameInfo ForeignRef))+stackFrameInfoParser stack frameIx = do+ -- Try a stack annotation first+ stackAnno <- subtermWith 0 stackAnnoParser+ case stackAnno of+ Nothing -> do+ -- Try IPE next+ mipe <- subtermWith 1 (maybeParser infoProvParser)+ case mipe of+ Nothing -> do+ -- Try decoding a continuation BCO with a breakpoint next+ fmap (uncurry StackFrameBreakpointInfo)+ <$> subtermWith 0 (retBCOParser stack frameIx)+ Just ipe -> pure $+ Just (StackFrameIPEInfo ipe)+ Just (srcLoc, ann) -> pure $+ Just (StackFrameAnnotation srcLoc ann)++-- | Decode an 'InfoProv' from an @InfoProv@ term+infoProvParser :: TermParser InfoProv+infoProvParser = InfoProv+ <$> subtermWith 0 stringParser -- ipName+ <*> pure INVALID_OBJECT -- ipDesc (this is a stub)+ <*> subtermWith 2 stringParser -- ipTyDesc+ <*> subtermWith 3 stringParser -- ipLabel+ <*> subtermWith 4 stringParser -- ipUnitId+ <*> subtermWith 5 stringParser -- ipMod+ <*> subtermWith 6 stringParser -- ipSrcFile+ <*> subtermWith 7 stringParser -- ipSrcSpan++-- | Try to decode an 'InternalBreakpointId' from a @StackFrame@ term+retBCOParser :: ForeignRef Stack.StackSnapshot+ -> Int+ -> TermParser (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))+retBCOParser stack_fv frame_ix = do+ -- Match against "RetBCO" frames and extract the BCOClosure information+ let bcoParser = subtermWith 1 (subtermWith 0{-take from Box-} anyTerm)+ bcoArgsParser = subtermWith 2 (seqTermP ensureTerm)+ optional (matchConstructorTerm "RetBCO" *> liftA2 (,) bcoParser bcoArgsParser)+ >>= \case+ Just (Suspension{val, ctype=BCO},Term{val=bcoArgs}) -> do+ {-"the otherwise case: Unknown closure", hence Suspension-}++ let bcoArgsOffset :: Remote.RemoteExpr (StackSnapshot -> Int -> Maybe Word)+ bcoArgsOffset = Remote.var debuggerRuntimeFFIInspectModName "bcoArgsOffset" []++ tag_fv <- liftDebuggerOrFail $ Remote.eval (bcoArgsOffset `Remote.appRef` stack_fv `Remote.app` (Remote.lit frame_ix))+ tag <- liftDebuggerOrFail $ obtainParsedTerm "tag" 3 True anyTy (castForeignRef tag_fv) (maybeParser $ wordParser <|> wordPrimParser)++ -- Decode the BCO closure using 'getClosureData' on the foreign heap+ bco_closure_fv <- liftDebuggerOrFail $+ Remote.evalIO+ (Remote.getClosureData (Remote.ref (castForeignRef val)))++ r <- liftDebuggerOrFail $+ obtainParsedTerm "BCO BRK_FUN info" 2 True anyTy (castForeignRef bco_closure_fv) bcoInternalBreakpointId+ let bcorefs = NoShow $ castForeignRef bcoArgs+ return $ (, DbgStackFrameBCOArgs bcorefs tag) <$> r+ _ -> pure Nothing++-- | Try to decode an 'StackAnnotation' from a @StackFrame@ term+stackAnnoParser :: TermParser (Maybe (Maybe Stack.SrcLoc, String))+stackAnnoParser = do+ -- Match against "AnnFrame" frames and extract the 'SomeStackAnnotation'+ (matchConstructorTerm "AnnFrame" *> subtermWith 1 (subtermWith 0{-take from Box-} (Just <$> anyTerm)) <|> pure Nothing)+ >>= \case+ Just Term{val} -> do+ stack_anno <- liftDebuggerOrFail $+ Remote.evalString+#if MIN_VERSION_ghc_experimental(9,1402,0)+ (Remote.displayStackAnnotationShort (Remote.ref (castForeignRef val)))+#else+ (Remote.displayStackAnnotation (Remote.ref (castForeignRef val)))+#endif++ src_loc <- getOptionalStackAnnotationSrcLoc++ pure $ Just (src_loc, stack_anno)+ _ ->+ pure Nothing++-- | Parse an 'InternalBreakpointId' out of a 'BCOClosure' term.+bcoInternalBreakpointId :: TermParser (Maybe InternalBreakpointId)+bcoInternalBreakpointId = do+ mbcpIxs <- bcoBreakPointInfoParser+ case mbcpIxs of+ Nothing -> return Nothing+ Just BCOBreakPointInfo{..} -> do+ mod_name <- bcoLiteralString info_mod_name_ix+ mod_id <- bcoLiteralString info_mod_id_ix++ return $ Just $ evalBreakpointToId EvalBreakpoint+ { eb_info_mod = mod_name+ , eb_info_mod_unit = utf8EncodeShortByteString mod_id+ , eb_info_index = fromIntegral $ brk_info_ix_hi .<<. 16 + brk_info_ix_lo+ }++getOptionalStackAnnotationSrcLoc :: TermParser (Maybe Stack.SrcLoc)+#if MIN_VERSION_ghc_experimental(9,1402,0)+getOptionalStackAnnotationSrcLoc = do+ src_loc_fv <- liftDebuggerOrFail $+ Remote.eval+ (Remote.stackAnnotationSourceLocation (Remote.ref (castForeignRef val)))++ liftDebuggerOrFail $+ obtainParsedTerm "Annotation SrcLoc" maxBound True anyTy (castForeignRef src_loc_fv) (maybeParser srcLocParser)+ where+ -- | Parse a 'SrcLoc'.+ srcLocParser :: TermParser Stack.SrcLoc+ srcLocParser = do+ Stack.SrcLoc+ <$> subtermWith 0 stringParser -- srcLocPackage+ <*> subtermWith 1 stringParser -- srcLocModule+ <*> subtermWith 2 stringParser -- srcLocFile+ <*> subtermWith 3 intPrimParser -- unpacked srcLocStartLine+ <*> subtermWith 4 intPrimParser -- unpacked srcLocStartCol+ <*> subtermWith 5 intPrimParser -- unpacked srcLocEndLine+ <*> subtermWith 6 intPrimParser -- unpacked srcLocEndCol+#else+getOptionalStackAnnotationSrcLoc = do+ pure Nothing+#endif+++-- | Parse a literal 'String' from a BCO given a valid index into the literals array+bcoLiteralString :: Word -> TermParser String+bcoLiteralString ix = do+ Term{val=literals_fv} <- subtermWith 2 (subtermTerm 0{-Box's field-})+ liftDebuggerOrFail $ do+ Remote.evalIOString $+ Remote.peekCString $+ Remote.withUnboxed (Remote.lit (fromIntegral ix))+ (Remote.indexAddrArray (Remote.untypedRef literals_fv))++-- | The indexes found in the BRK_FUN instruction+data BCOBreakPointInfo = BCOBreakPointInfo+ { brk_array_ix :: !Word+ , info_mod_name_ix :: !Word+ , info_mod_id_ix :: !Word+ , brk_info_ix_hi :: !Word+ , brk_info_ix_lo :: !Word+ }+ deriving Show++-- | Parses a 'BCOBreakPoint' if the current term is a 'BCOClosure' headed by a+-- BRK_FUN bytecode instruction.+-- Returns Nothing if the 'BCOClosure' instructions are headed by a BRK_FUN.+bcoBreakPointInfoParser :: TermParser (Maybe BCOBreakPointInfo)+bcoBreakPointInfoParser = do+ Term{val=instrs_array_fv} <- subtermWith 1{-instrs field-} (subtermTerm 0{-Box's field-})+ -- highly internals dependent...+ -- find the BCI at index 0. bci is word16. the first 8bits are for flags+ -- something something BCO_READ_LARGE_ARG with (index_at 0#) rather than always BCO_NEXT?+ do+ hsc_env <- liftDebugger getSession++ -- The BRK_FUN is the first instruction, unless BCO_NAME is enabled, in+ -- which case it's the second.+ let bRK_FUN_offset+ | gopt Opt_AddBcoName (hsc_dflags hsc_env) = 2 -- BCO_NAME + ptrs ix.+ | otherwise = 0 :: Int++ let find_ixs_fv = Remote.raw $+ "\\x -> let index_at n = GHC.Word.W16# (GHC.Base.indexWord16Array# x (n GHC.Exts.+# " ++ show bRK_FUN_offset ++ """#))+ in if (index_at 0# Data.Bits..&. 0xFF) == 66{-bci_BRK_FUN-} then+ Data.Maybe.Just (index_at 1#, index_at 2#, index_at 3#, index_at 4#, index_at 5#)+ else Data.Maybe.Nothing"""+ rs_fv <- liftDebuggerOrFail $ Remote.eval+ (find_ixs_fv `Remote.app` Remote.untypedRef instrs_array_fv)++ mparsed_bco_brk <- liftDebugger $ obtainParsedTerm "Ixs" maxBound True anyTy rs_fv $+ maybeParser $ BCOBreakPointInfo <$>+ subtermWith 0 wordParser <*> subtermWith 1 wordParser <*> subtermWith 2 wordParser+ <*> subtermWith 3 wordParser <*> subtermWith 4 wordParser+ case mparsed_bco_brk of+ Left errs -> liftDebugger $ do+ logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+ liftIO $ fail "Failed to parse BCOClosure's BRK_FUN"+ Right r -> return r++unpackStackFields :: ForeignRef [Stack.StackField] -> Maybe [Int] -> Debugger [ForeignHValue]+unpackStackFields fldsRef mixs = runInternal $ do+ (expectRight =<<) $ Remote.evalIOList $+ Remote.unpackStackFields `Remote.appRef` fldsRef `Remote.app` Remote.raw (show mixs)++--------------------------------------------------------------------------------+-- * Exception Info+--------------------------------------------------------------------------------++-- | Evaluate helper code inside the debuggee that turns the exception context+-- into our 'ExceptionInfo' structure.+collectExceptionInfo :: ForeignRef SomeException -> Debugger (Maybe ExceptionInfo)+collectExceptionInfo excRef = runInternal $ do+ -- 1. Add a "data" declaration for the datatype the expression will return+ _ <- runDecls exceptionInfoData+ -- 2. Gather information about the exception.+ evalRes <- Remote.eval+ (Remote.raw exceptionInfoExpr `Remote.app` Remote.ref excRef)+ case evalRes of+ Left err -> do+ logSDoc Logger.Debug $+ Ppr.text "Failed to evaluate exception info:" Ppr.<+> Ppr.text (show err)+ return Nothing+ Right fhv -> do+ parsed <- obtainParsedTerm "Exception info" 4 True anyTy (castForeignRef fhv)+ exceptionInfoParser+ case parsed of+ Left errs -> do+ logSDoc Logger.Debug $+ Ppr.text "Failed to parse exception info:"+ Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs)+ return Nothing+ Right info -> return (Just info)++-- | Parse the helper 'ExceptionInfoNode' structure produced inside the+-- debuggee into our externally facing 'ExceptionInfo'.+exceptionInfoParser :: TermParser ExceptionInfo+exceptionInfoParser = do+ cwd <- liftIO $ mkAbsolute <$> getCurrentDirectory+ ExceptionInfo+ <$> subtermWith 0 stringParser+ <*> subtermWith 1 stringParser+ <*> subtermWith 2 stringParser+ <*> subtermWith 3 (maybeParser stringParser)+ <*> subtermWith 4 (maybeParser $ exceptionLocationTupleParser cwd)+ <*> subtermWith 5 (parseList exceptionInfoParser)+ where+ -- Parsed from @(String, Int, Int)@.+ -- See Note [Paths should be made absolute at the source]+ exceptionLocationTupleParser :: AbsFilePath -> TermParser SourceSpan+ exceptionLocationTupleParser prefix = do+ locFile <- subtermWith 0 stringParser+ srcLine <- subtermWith 1 intParser+ srcCol <- subtermWith 2 intParser+ pure SourceSpan+ { file = prefix /> locFile+ , startLine = srcLine+ , startCol = srcCol+ , endLine = srcLine+ , endCol = srcCol+ }++-- | Definition for the helper 'ExceptionInfoNode' data type compiled into the+-- debuggee to aid in transporting nested exception information.+-- We need a specific datatype because ExceptionInfoNode is recursive.+exceptionInfoData :: String+exceptionInfoData = """+ data ExceptionInfoNode = ExceptionInfoNode+ { exceptionNodeTypeName :: String+ , exceptionNodeFullTypeName :: String+ , exceptionNodeMessage :: String+ , exceptionNodeContext :: Data.Maybe.Maybe String+ , exceptionNodeSourceSpan :: Data.Maybe.Maybe (String, Int, Int)+ , exceptionNodeInner :: [ExceptionInfoNode]+ }+ """++-- | Helper expression run in the debuggee that walks the exception context and+-- populates the 'ExceptionInfoNode' structure.+exceptionInfoExpr :: String+exceptionInfoExpr = """+ let collectExceptionInfo :: Control.Exception.SomeException -> ExceptionInfoNode+ collectExceptionInfo se' =+ case se' of+ Control.Exception.SomeException exc ->+ let ctx = Control.Exception.someExceptionContext se'+ rendered = Control.Exception.Context.displayExceptionContext ctx+ whileHandling = Control.Exception.Context.getExceptionAnnotations ctx+ innerNodes = Prelude.map (collectExceptionInfo Prelude.. unwrap) whileHandling+ sourceSpan = exceptionContextLocation ctx+ simpleTypeName = Data.Typeable.tyConName tc+ modulePrefix = case Data.Typeable.tyConModule tc of+ mdl | Prelude.null mdl -> \"\"+ | otherwise -> mdl Prelude.++ \".\"+ packagePrefix = case Data.Typeable.tyConPackage tc of+ pkg | Prelude.null pkg -> \"\"+ | otherwise -> pkg Prelude.++ \":\"+ tc = Data.Typeable.typeRepTyCon (Data.Typeable.typeOf exc)+ fullTypeName = packagePrefix Prelude.++ modulePrefix Prelude.++ simpleTypeName+ unwrap (Control.Exception.WhileHandling inner) = inner+ contextText = if Prelude.null rendered then Data.Maybe.Nothing else Data.Maybe.Just rendered+ in ExceptionInfoNode+ { exceptionNodeTypeName = simpleTypeName+ , exceptionNodeFullTypeName = fullTypeName+ , exceptionNodeMessage = Control.Exception.displayException se'+ , exceptionNodeContext = contextText+ , exceptionNodeSourceSpan = sourceSpan+ , exceptionNodeInner = innerNodes+ }+ exceptionContextLocation ctx =+ let fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of+ Data.Maybe.Just (_, loc) ->+ Data.Maybe.Just+ ( GHC.Exception.srcLocFile loc+ , GHC.Exception.srcLocStartLine loc+ , GHC.Exception.srcLocStartCol loc+ )+ Data.Maybe.Nothing -> Data.Maybe.Nothing+ bts :: [Control.Exception.Backtrace.Backtraces]+ bts = Control.Exception.Context.getExceptionAnnotations ctx+ in case bts of+ bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of+ Data.Maybe.Just cs -> fromCallStack cs+ Data.Maybe.Nothing -> Data.Maybe.Nothing+ [] -> Data.Maybe.Nothing+ in collectExceptionInfo+ """
+ haskell-debugger/GHC/Debugger/Runtime/Interpreter/Types.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveGeneric #-}+module GHC.Debugger.Runtime.Interpreter.Types where++import GHC.Generics (Generic)++import GHC.Debugger.Interface.Messages (DbgStackFrameBCOArgs)+import GHC.ByteCode.Types+import GHC.Conc.Sync+import GHC.InfoProv+import qualified GHC.Stack as Stack++--------------------------------------------------------------------------------+-- * Types+--------------------------------------------------------------------------------++data ThreadInfo ref = ThreadInfo+ { threadInfoRef :: !(ref ThreadId)+ , threadInfoLabel :: !(Maybe String)+ , threadInfoStatus :: !ThreadStatus+ }+ deriving (Generic)++-- | Information about a stack frame+data StackFrameInfo ref+ -- | Information derived from an IPE entry+ = StackFrameIPEInfo !InfoProv+ -- | User-defined Stack Frame annotation+ | StackFrameAnnotation !(Maybe Stack.SrcLoc) !String+ -- | Information derived from a continuation BCO breakpoint info.+ | StackFrameBreakpointInfo !InternalBreakpointId !(DbgStackFrameBCOArgs ref)+ deriving (Generic, Show)
haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs view
@@ -54,6 +54,12 @@ liftDebugger :: Debugger a -> TermParser a liftDebugger action = TermParser $ \_ -> Right <$> action +liftDebuggerOrFail :: Show e => Debugger (Either e a) -> TermParser a+liftDebuggerOrFail action = do+ liftDebugger action >>= \case+ Left e -> fail (show e)+ Right x -> pure x+ instance MonadIO TermParser where liftIO action = TermParser $ \_ -> Right <$> liftIO action @@ -287,10 +293,16 @@ intParser :: TermParser Int intParser = fromIntegral <$> wordParser +intPrimParser :: TermParser Int+intPrimParser = fromIntegral <$> primParser+ -- | Parse a 'Word' wordParser :: TermParser Word wordParser = subtermWith 0 primParser +wordPrimParser :: TermParser Word+wordPrimParser = primParser+ -- | Parse a 'String' term stringParser :: TermParser String stringParser = do@@ -392,4 +404,3 @@ reifyBool :: Bool -> Debugger ForeignHValue reifyBool b = Comp.compileRaw (show b ++ ":: Bool")-
haskell-debugger/GHC/Debugger/Runtime/Thread.hs view
@@ -24,7 +24,11 @@ import Data.IORef import GHC.Conc.Sync +#if MIN_VERSION_ghc(10,1,0)+import GHC.Builtin.WiredIn.Types+#else import GHC.Builtin.Types+#endif import GHC.Runtime.Heap.Inspect import GHC.Utils.Outputable @@ -37,15 +41,14 @@ import GHC.Debugger.Runtime.Term.Parser import GHC.Debugger.Runtime.Thread.Map -import GHC.Debugger.Runtime.Interpreter.Custom+import GHC.Debugger.Runtime.Interpreter.Types import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote -#if MIN_VERSION_ghc(9,15,0)+#if MIN_VERSION_ghc(9,14,2) import qualified GHC.Debugger.Runtime.Interpreter as Debuggee #else-import Data.Functor-import Control.Applicative+import qualified GHC.Debugger.Runtime.Interpreter.Legacy as Debuggee #endif -- | Get a 'RemoteThreadId' from a remote 'ResumeContext' gotten from an 'ExecBreak'@@ -67,11 +70,7 @@ -- This may include the debugger threads if using the internal interpreter. listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ThreadInfo ForeignRef)] listAllLiveRemoteThreads = do-#if MIN_VERSION_ghc(9,15,0) threadInfos <- Debuggee.listThreads-#else- threadInfos <- GHC.Debugger.Runtime.Thread.listThreads-#endif fmap catMaybes $ forM threadInfos $ \ti -> do rti <- getRemoteThreadId ti.threadInfoRef@@ -100,74 +99,3 @@ insertThreadMap tid_int threadIdRef return (RemoteThreadId tid_int)--#if MIN_VERSION_ghc(9,15,0)--- The needed functions are imported from GHC.Debugger.Runtime.Interpreter,--- which abstracts over the custom interpreter commands.-#else------------------------------------------------------------------------------------ ** GHC 9.14: use @evalX@ and @TermParser@ to do it without custom commands-----------------------------------------------------------------------------------listThreads :: Debugger [ThreadInfo ForeignRef]-listThreads = do- threads_fvs <- expectRight =<< Remote.evalIOList Remote.listThreads- labels <- getRemoteThreadsLabels threads_fvs- forM (zip threads_fvs labels) $ \(castForeignRef -> thread_fv, label) -> do- status <- getRemoteThreadStatus thread_fv- pure ThreadInfo- { threadInfoStatus = status- , threadInfoLabel = label- , threadInfoRef = thread_fv- }---- | Is the remote thread running or blocked (NOT finished NOR dead)?-getRemoteThreadStatus :: ForeignRef ThreadId -> Debugger ThreadStatus-getRemoteThreadStatus threadIdRef = do- status_fv <- expectRight =<< Remote.evalIO- (Remote.threadStatus (Remote.ref threadIdRef))- status_parsed <-- obtainParsedTerm "ThreadStatus" 2 True anyTy{-..no..-} (castForeignRef status_fv) threadStatusParser-- case status_parsed of- Left errs -> do- logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))- liftIO $ fail "Failed to parse ThreadStatus"- Right thrdStatus ->- return thrdStatus--getRemoteThreadsLabels :: [ForeignRef ThreadId] -> Debugger [Maybe String]-getRemoteThreadsLabels threadIdRefs = do-- forM threadIdRefs $ \threadIdRef -> do-- r <- Remote.evalIOList $ Remote.do- mb_str <- Remote.threadLabel (Remote.ref threadIdRef)- Remote.return (Remote.maybeToList mb_str)-- expectRight r >>= \case- [] -> pure Nothing- [io_lbl_fv] -> Just <$> (expectRight =<< Remote.evalString (Remote.ref io_lbl_fv))- _ -> liftIO $ fail "Unexpected result from evaluating \"threadLabel\""------------------------------------------------------------------------------------- *** TermParsers-----------------------------------------------------------------------------------threadStatusParser :: TermParser ThreadStatus-threadStatusParser = do- (matchConstructorTerm "ThreadRunning" $> ThreadRunning)- <|> (matchConstructorTerm "ThreadFinished" $> ThreadFinished)- <|> (matchConstructorTerm "ThreadDied" $> ThreadDied)- <|> (matchConstructorTerm "ThreadBlocked" *> (ThreadBlocked <$> subtermWith 0 blockedReasonParser))--blockedReasonParser :: TermParser BlockReason-blockedReasonParser = do- (matchConstructorTerm "BlockedOnMVar" $> BlockedOnMVar)- <|> (matchConstructorTerm "BlockedOnBlackHole" $> BlockedOnBlackHole)- <|> (matchConstructorTerm "BlockedOnException" $> BlockedOnException)- <|> (matchConstructorTerm "BlockedOnSTM" $> BlockedOnSTM)- <|> (matchConstructorTerm "BlockedOnForeignCall" $> BlockedOnForeignCall)- <|> (matchConstructorTerm "BlockedOnOther" $> BlockedOnOther)--#endif
haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs view
@@ -15,36 +15,12 @@ import Control.Concurrent import GHCi.RemoteTypes import GHC.Debugger.Monad-import GHC.Debugger.Runtime.Interpreter.Custom+import GHC.Debugger.Runtime.Interpreter.Types -#if MIN_VERSION_ghc(9,15,0)+#if MIN_VERSION_ghc(9,14,2) import qualified GHC.Debugger.Runtime.Interpreter as Debuggee #else-import Data.Bits-import Data.Maybe-import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class-import GHC.Exts.Heap.ClosureTypes-import GHC.Utils.Encoding.UTF8-import GHC.InfoProv--import GHC-import GHC.Builtin.Types-import GHC.Runtime.Heap.Inspect-import qualified GHC.Stack.Types as Stack--import GHC.Driver.Env-import GHC.Runtime.Interpreter as Interp-import GHC.Utils.Outputable--import GHCi.Message--import Colog.Core as Logger-import GHC.Debugger.Runtime.Term.Parser-import GHC.Debugger.Runtime.Eval-import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote-import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote+import qualified GHC.Debugger.Runtime.Interpreter.Legacy as Debuggee #endif --------------------------------------------------------------------------------@@ -52,180 +28,5 @@ -------------------------------------------------------------------------------- -- | Clone the stack of the given remote thread and get the breakpoint ids of available frames-getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [StackFrameInfo]-getRemoteThreadStackCopy threadIdRef = do-#if MIN_VERSION_ghc(9,15,0)- Debuggee.decodeThreadStack threadIdRef-#else- l <- Remote.evalIOList $ Remote.do- clonedStack <- Remote.cloneThreadStack (Remote.ref threadIdRef)- frames <- Remote.decodeStackWithIpe clonedStack- Remote.return frames-- case l of- Left (EvalRaisedException e) -> do- logSDoc Logger.Info (text "Failed to decode the stack with" <+> text (show e) $$ text "This is likely bug #26640 in the decoder, which has been fixed for 9.14.2 and forward. No StackTrace will be returned...")- return []- Left e -> do- logSDoc Logger.Warning (text "Failed to decode the stack with" <+> text (show e) $$ text "No StackTrace will be returned...")- return []- Right stack_frames_fvs -> fmap catMaybes $- forM stack_frames_fvs $ \ stack_frame_fv -> do- obtainParsedTerm "ghc-heap:StackFrame" 2 True anyTy{-todo:stackframety?-} (castForeignRef stack_frame_fv)- stackFrameInfoParser >>= \case- Left errs -> do- logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))- return Nothing- Right tm ->- return tm-#endif--#if MIN_VERSION_ghc(9,15,0)--- Nothing needed in this case :)-#else------------------------------------------------------------------------------------ ** Decoding Stack Frames ----------------------------------------------------------------------------------------------------------------------------------------- | Try to decode a 'StackFrameInfo' from a @(StackFrame, Maybe InfoProv)@ term-stackFrameInfoParser :: TermParser (Maybe StackFrameInfo)-stackFrameInfoParser = do- -- Try a stack annotation first- stackAnno <- subtermWith 0 stackAnnoParser- case stackAnno of- Nothing -> do- -- Try IPE next- mipe <- subtermWith 1 (maybeParser infoProvParser)- case mipe of- Nothing -> do- -- Try decoding a continuation BCO with a breakpoint next- fmap StackFrameBreakpointInfo- <$> subtermWith 0 retBCOParser- Just ipe -> pure $- Just (StackFrameIPEInfo ipe)- Just (srcLoc, ann) -> pure $- Just (StackFrameAnnotation srcLoc ann)---- | Decode an 'InfoProv' from an @InfoProv@ term-infoProvParser :: TermParser InfoProv-infoProvParser = InfoProv- <$> subtermWith 0 stringParser -- ipName- <*> pure INVALID_OBJECT -- ipDesc (this is a stub)- <*> subtermWith 2 stringParser -- ipTyDesc- <*> subtermWith 3 stringParser -- ipLabel- <*> subtermWith 4 stringParser -- ipUnitId- <*> subtermWith 5 stringParser -- ipMod- <*> subtermWith 6 stringParser -- ipSrcFile- <*> subtermWith 7 stringParser -- ipSrcSpan---- | Try to decode an 'InternalBreakpointId' from a @StackFrame@ term-retBCOParser :: TermParser (Maybe InternalBreakpointId)-retBCOParser = do- -- Match against "RetBCO" frames and extract the BCOClosure information- (matchConstructorTerm "RetBCO" *> subtermWith 1 (subtermWith 0{-take from Box-} (Just <$> anyTerm)) <|> pure Nothing)- >>= \case- Just Suspension{val, ctype=BCO} -> do- {-"the otherwise case: Unknown closure", hence Suspension-}-- -- Decode the BCO closure using 'getClosureData' on the foreign heap- bco_closure_fv <- liftDebugger $- expectRight =<< Remote.evalIO- (Remote.getClosureData (Remote.ref (castForeignRef val)))-- r <- liftDebugger $- obtainParsedTerm "BCO BRK_FUN info" 2 True anyTy (castForeignRef bco_closure_fv) bcoInternalBreakpointId- case r of- Left err -> fail (show err)- Right t -> return t- _ -> pure Nothing---- | Try to decode an 'StackAnnotation' from a @StackFrame@ term-stackAnnoParser :: TermParser (Maybe (Maybe Stack.SrcLoc, String))-stackAnnoParser = do- -- Match against "AnnFrame" frames and extract the 'SomeStackAnnotation'- (matchConstructorTerm "AnnFrame" *> subtermWith 1 (subtermWith 0{-take from Box-} (Just <$> anyTerm)) <|> pure Nothing)- >>= \case- Just Term{val} -> do- stack_anno <- liftDebugger $- expectRight =<< Remote.evalString- (Remote.displayStackAnnotation (Remote.ref (castForeignRef val)))-- pure $ Just (Nothing {- No source locations yet :( -}, stack_anno)- _ ->- pure Nothing---- | Parse an 'InternalBreakpointId' out of a 'BCOClosure' term.-bcoInternalBreakpointId :: TermParser (Maybe InternalBreakpointId)-bcoInternalBreakpointId = do- mbcpIxs <- bcoBreakPointInfoParser- case mbcpIxs of- Nothing -> return Nothing- Just BCOBreakPointInfo{..} -> do- mod_name <- bcoLiteralString info_mod_name_ix- mod_id <- bcoLiteralString info_mod_id_ix-- return $ Just $ evalBreakpointToId EvalBreakpoint- { eb_info_mod = mod_name- , eb_info_mod_unit = utf8EncodeShortByteString mod_id- , eb_info_index = fromIntegral $ brk_info_ix_hi .<<. 16 + brk_info_ix_lo- }---- | Parse a literal 'String' from a BCO given a valid index into the literals array-bcoLiteralString :: Word -> TermParser String-bcoLiteralString ix = do- Term{val=literals_fv} <- subtermWith 2 (subtermTerm 0{-Box's field-})- liftDebugger $ do-- r <- Remote.evalIOString $- Remote.peekCString $- Remote.withUnboxed (Remote.lit (fromIntegral ix))- (Remote.indexAddrArray (Remote.untypedRef literals_fv))-- expectRight r---- | The indexes found in the BRK_FUN instruction-data BCOBreakPointInfo = BCOBreakPointInfo- { brk_array_ix :: !Word- , info_mod_name_ix :: !Word- , info_mod_id_ix :: !Word- , brk_info_ix_hi :: !Word- , brk_info_ix_lo :: !Word- }- deriving Show---- | Parses a 'BCOBreakPoint' if the current term is a 'BCOClosure' headed by a--- BRK_FUN bytecode instruction.--- Returns Nothing if the 'BCOClosure' instructions are headed by a BRK_FUN.-bcoBreakPointInfoParser :: TermParser (Maybe BCOBreakPointInfo)-bcoBreakPointInfoParser = do- Term{val=instrs_array_fv} <- subtermWith 1{-instrs field-} (subtermTerm 0{-Box's field-})- -- highly internals dependent...- -- find the BCI at index 0. bci is word16. the first 8bits are for flags- -- something something BCO_READ_LARGE_ARG with (index_at 0#) rather than always BCO_NEXT?- liftDebugger $ do- hsc_env <- getSession-- -- The BRK_FUN is the first instruction, unless BCO_NAME is enabled, in- -- which case it's the second.- let bRK_FUN_offset- | gopt Opt_AddBcoName (hsc_dflags hsc_env) = 2 -- BCO_NAME + ptrs ix.- | otherwise = 0 :: Int-- let find_ixs_fv = Remote.raw $- "\\x -> let index_at n = GHC.Word.W16# (GHC.Base.indexWord16Array# x (n GHC.Exts.+# " ++ show bRK_FUN_offset ++ """#))- in if (index_at 0# Data.Bits..&. 0xFF) == 66{-bci_BRK_FUN-} then- Data.Maybe.Just (index_at 1#, index_at 2#, index_at 3#, index_at 4#, index_at 5#)- else Data.Maybe.Nothing"""- rs_fv <- expectRight =<< Remote.eval- (find_ixs_fv `Remote.app` Remote.untypedRef instrs_array_fv)-- mparsed_bco_brk <- obtainParsedTerm "Ixs" maxBound True anyTy rs_fv $- maybeParser $ BCOBreakPointInfo <$>- subtermWith 0 wordParser <*> subtermWith 1 wordParser <*> subtermWith 2 wordParser- <*> subtermWith 3 wordParser <*> subtermWith 4 wordParser- case mparsed_bco_brk of- Left errs -> do- logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))- liftIO $ fail "Failed to parse BCOClosure's BRK_FUN"- Right r -> return r-#endif+getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [StackFrameInfo ForeignRef]+getRemoteThreadStackCopy = Debuggee.decodeThreadStack
haskell-debugger/GHC/Debugger/Session.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE DerivingStrategies, CPP, RecordWildCards #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-x-partial #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | Initialise the GHC session for one or more home units. --@@ -29,23 +33,38 @@ setDynFlagWays, makeDynFlagsAbsoluteOverall, resumeExec,- setExposedInUnit,- graphUnits,+ exposeModGraphUnitsInInteractiveGhcDebuggerUnit,+ graphsUnits,+ compileModuleWithDepsInHpt,+ home_unit_dflags,+ packageImportDecl,+ withUnliftGhc,+ annotateCallStackGhc,+ lookupUnitPackageQualifier,+ fixHomeUnitsDynFlagsForIIDecl, getPgmI,+ initUniqSupplyIO ) where #if MIN_VERSION_ghc(9,14,2) import Data.Function ((&)) #endif+import Control.Applicative ((<|>))+import Control.Exception (assert) import Control.Monad+import Control.Monad.Identity import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1 as H import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map+#if MIN_VERSION_ghc(10,1,0)+import Data.IORef (newIORef)+#endif import qualified Data.List as L-import qualified Data.Containers.ListUtils as L+import qualified Data.List as List+import qualified Data.Containers.ListUtils as ListUtils import GHC.ResponseFile (expandResponse) import HIE.Bios.Environment as HIE import System.FilePath@@ -62,21 +81,44 @@ import GHC.Unit.Home.Graph import GHC.Unit.Home.PackageTable import GHC.Unit.Env+#if MIN_VERSION_ghc(10,1,0)+import GHC.Unit.External.Index (UnitIndexCache)+#endif import GHC.Unit.Types import qualified GHC.Unit.State as State import GHC.Driver.Env import GHC.Types.SrcLoc-import GHC.Settings (ToolSettings(..)) import Language.Haskell.Syntax.Module.Name import qualified Data.Foldable as Foldable import qualified GHC.Unit.Home.Graph as HUG import qualified Data.Set as Set import Data.Maybe import GHC.Types.Target (InputFileBuffer)-import GHC (SingleStep, ExecResult)+import GHC (SingleStep, ExecResult, ModSummary (ms_hspp_opts), ideclPkgQual, ImportDecl, GhcPs) import Data.Set (Set) import qualified GHC.Unit as GHC-import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), ModNodeKeyWithUid (mnkUnitId), mnKey)+import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), mnKey)+import GHC.Driver.Make+import GHC.Unit.Home.ModInfo (HomeModInfo(..))+import qualified GHC.Driver.Errors.Types as GHC+import System.Directory (doesFileExist)+import qualified GHC.Types.Error as GHC+import qualified GHC.Utils.Error as GHC+import GHC.Driver.Pipeline (compileOne)+import qualified GHC.Unit.Home.ModInfo as GHC+import GHC.Utils.TmpFs+import Data.Foldable (for_)+import GHC.Plugins (SourceError, try, RawPkgQual (..), HasCallStack, FastString, mkFastString, lookupUnitId)+#if MIN_VERSION_ghc(10,1,0)+import GHC.Types.SourceText (SourceText (..))+#else+import GHC.Types.SourceText (StringLiteral(..), SourceText (..))+#endif+import GHC.Stack.Annotation+import GHC.Stack (callStack)+import GHC.Settings (ToolSettings(..))+import qualified GHC.Types.Unique.Supply as GHC+import Data.Containers.ListUtils (nubOrd) -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m@@ -147,21 +189,58 @@ -- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's. -- The first 'DynFlags' are the 'DynFlags' for the interactive session.-createHomeUnitGraph :: GHC.Logger -> [DynFlags] -> IO HomeUnitGraph-createHomeUnitGraph logger unitDflags = do+createHomeUnitGraph :: GHC.Logger -> UnitEnv -> [DynFlags] -> IO HomeUnitGraph+createHomeUnitGraph logger _uenv unitDflags = do let home_units = Set.fromList $ map homeUnitId_ unitDflags+ unitEnvList <- flip traverse unitDflags $ \ dflags -> do- hue <- setupNewHomeUnitEnv logger dflags Nothing home_units- pure (homeUnitId_ dflags, hue)+ let uid = homeUnitId_ dflags+#if MIN_VERSION_ghc(10,1,0)+ hue <- setupNewHomeUnitEnv home_units logger dflags (ue_uic _uenv)+#else+ hue <- setupNewHomeUnitEnv home_units logger dflags Nothing+#endif+ assert (homeUnitId_ (homeUnitEnv_dflags hue) == uid) $+ pure (uid, hue) pure $ unitEnv_new (Map.fromList unitEnvList) -setupNewHomeUnitEnv :: GHC.Logger -> DynFlags -> Maybe [GHC.UnitDatabase UnitId] -> Set UnitId -> IO HomeUnitEnv-setupNewHomeUnitEnv logger dflags cached_dbs other_home_units = do+-- | See Note [ Ambiguous Package Qualified Imports Workaround ]+fixHomeUnitsDynFlagsForIIDecl :: Ghc ()+fixHomeUnitsDynFlagsForIIDecl = do+ modifySession $ hscUpdateHUG $ \ hug -> do+ let manyHomeUnits = Set.size (HUG.allUnits hug) > 1+ let h hue = hue { homeUnitEnv_dflags = fixFlagsForIIDecl manyHomeUnits (homeUnitEnv_dflags hue) }+ runIdentity . unitEnv_traverseWithKey (const $ pure . h) $ hug+ where+ -- | Makes package names of home units unique and removes hidden modules.+ fixFlagsForIIDecl :: Bool -> DynFlags -> DynFlags+ fixFlagsForIIDecl False df | Just{} <- thisPackageName df = df {hiddenModules = mempty}+ -- TODO #288: pick more user-friendly names.+ fixFlagsForIIDecl _manyHUnits dflags = dflags { thisPackageName = Just (unitIdString (homeUnitId_ dflags))+ , hiddenModules = mempty}++-- | The first argument should contain the home units the new @HomeUnitEnv@ depends on (@allUnits (hsc_HUG env)@ is always safe to give).+-- The actual dependencies are specified by the @packageFlags@ in the @DynFlags@ argument.+setupNewHomeUnitEnv+ :: Set UnitId -> GHC.Logger -> DynFlags+#if MIN_VERSION_ghc(10,1,0)+ -> UnitIndexCache+#else+ -> Maybe [GHC.UnitDatabase UnitId]+#endif+ -> IO HomeUnitEnv+setupNewHomeUnitEnv hug_keys logger dflags cached_dbs = do emptyHpt <- emptyHomePackageTable- (dbs,unit_state,home_unit,mconstants) <- State.initUnits logger dflags cached_dbs other_home_units+#if MIN_VERSION_ghc(10,1,0)+ (unit_state,home_unit,mconstants) <- State.initUnits logger dflags cached_dbs hug_keys updated_dflags <- GHC.updatePlatformConstants dflags mconstants+ pure $ mkHomeUnitEnv unit_state updated_dflags emptyHpt (Just home_unit)+#else+ (dbs,unit_state,home_unit,mconstants) <- State.initUnits logger dflags cached_dbs hug_keys+ updated_dflags <- GHC.updatePlatformConstants dflags mconstants pure $ mkHomeUnitEnv unit_state (Just dbs) updated_dflags emptyHpt (Just home_unit)+#endif -- | Given a set of 'DynFlags', set up the 'UnitEnv' and 'HomeUnitEnv' for this -- 'HscEnv'.@@ -169,96 +248,110 @@ -- anything. initHomeUnitEnv :: [DynFlags] -> HscEnv -> IO HscEnv initHomeUnitEnv unitDflags env = do- let dflags0 = hsc_dflags env - initial_home_graph <- createHomeUnitGraph (hsc_logger env) unitDflags+ initial_home_graph <- createHomeUnitGraph (hsc_logger env) (hsc_unit_env env) unitDflags + -- We need one of the units to be the `ue_currentUnit`: by default it's "main", but we don't create such a unit and Ghc panics.+ addInteractiveGhcDebuggerUnit (Set.toList . allUnits $ initial_home_graph) $ hscUpdateHUG (const initial_home_graph) env++-- | Adds or refreshes the @interactiveGhcDebuggerUnit@ passing the first+-- argument as @ExposePackage@ flags.+addInteractiveGhcDebuggerUnit :: [UnitId] -> HscEnv -> IO HscEnv+addInteractiveGhcDebuggerUnit exposed env = do+ let dflags0 = hsc_dflags env+ let initial_home_graph = hsc_HUG env -- We set up the interactive debugger home unit after the other home units -- have been initialised. -- This allows us to reuse the package databases and their respective visibilities. interactiveHomeUnit <- do let- home_units = unitEnv_keys initial_home_graph- interactiveDynFlags = dflags0 { homeUnitId_ = interactiveGhcDebuggerUnitId , importPaths = [] , packageFlags = [ ExposePackage- (unitIdString home_unit_id)- (UnitIdArg $ RealUnit (Definite home_unit_id))+ (unitIdString uid)+ (UnitIdArg $ RealUnit (Definite uid)) (ModRenaming True [])- | home_unit_id <- Set.toList home_units+ | uid <- exposed+ , uid /= rtsUnitId+ , uid /= ghcInternalUnitId+ , uid /= interactiveGhcDebuggerUnitId+ -- TODO: other uids to filter? ]+ , packageDBFlags = concatPackageDbStacksUsingLongestCommonPrefix $+ (fmap (packageDBFlags . homeUnitEnv_dflags) (Foldable.toList initial_home_graph)) } +#if MIN_VERSION_ghc(10,1,0)+ setupNewHomeUnitEnv (allUnits initial_home_graph) (hsc_logger env) interactiveDynFlags (hscUIC env)+#else let cached_unit_dbs = concat . catMaybes . fmap homeUnitEnv_unit_dbs $ Foldable.toList initial_home_graph- setupNewHomeUnitEnv (hsc_logger env) interactiveDynFlags (Just cached_unit_dbs) home_units+ setupNewHomeUnitEnv (allUnits initial_home_graph) (hsc_logger env) interactiveDynFlags (Just cached_unit_dbs)+#endif let home_unit_graph = HUG.unitEnv_insert interactiveGhcDebuggerUnitId interactiveHomeUnit initial_home_graph let interactiveDFlags = homeUnitEnv_dflags interactiveHomeUnit- unit_env <-- initUnitEnv interactiveGhcDebuggerUnitId home_unit_graph (GHC.ghcNameVersion interactiveDFlags) (targetPlatform interactiveDFlags)+ let unit_env = (hsc_unit_env env)+ { ue_home_unit_graph = home_unit_graph+ , ue_current_unit = interactiveGhcDebuggerUnitId+ , ue_platform = targetPlatform interactiveDFlags+ , ue_namever = GHC.ghcNameVersion interactiveDFlags+ } pure $ hscSetFlags interactiveDFlags $ hscSetUnitEnv unit_env env+ where+ -- inlined from GHCi. Patiently waiting for a nice Dev UX to units and flags...+ concatPackageDbStacksUsingLongestCommonPrefix :: Ord a => [[a]] -> [a]+ concatPackageDbStacksUsingLongestCommonPrefix (fmap reverse -> stacks) =+ let+ -- O (m * n)+ -- m ... Number of PackageDBFlag stacks+ -- n ... Size of the stacks+ longestCommonPrefix =+ map List.head . List.takeWhile ((List.all . (==) . List.head) <*> List.tail) . List.transpose+ prefix =+ longestCommonPrefix stacks+ in+ prefix ++ nubOrd (concatMap (List.drop (length prefix)) stacks) --- | Extracts @UnitId@s from the graph.-graphUnits :: GHC.ModuleGraph -> [UnitId]-graphUnits mod_graph = L.nubOrd .- (`mapMaybe` mg_mss mod_graph) $ \case- UnitNode _deps uid -> Just uid+-- | Sets the units from the @ModuleGraph@ as the exposed ones for @InteractiveGhcDebuggerUnit@.+--+-- See Note [Must explicitly expose module graph units].+exposeModGraphUnitsInInteractiveGhcDebuggerUnit :: Ghc ()+exposeModGraphUnitsInInteractiveGhcDebuggerUnit =+ modifySessionM $ \ env -> do+ liftIO $ addInteractiveGhcDebuggerUnit (graphsUnits env) env++-- | Extracts @UnitId@s from @ModuleGraph@ and @HomeUnitGraph@.+graphsUnits :: HscEnv -> [UnitId]+graphsUnits env = ListUtils.nubOrd $ modGraphUIDs ++ hugPreloadUIDs+ where+ -- [TODO](https://github.com/well-typed/haskell-debugger/issues/351): redundant?+ modGraphUIDs = (`mapMaybe` mg_mss mod_graph) $ \case+ UnitNode _deps uid -> Just uid ModuleNode _ modl -> Just $ mnkUnitId $ mnKey modl InstantiationNode uid _ -> Just uid LinkNode _ _ -> Nothing+ mod_graph = hsc_mod_graph env+ hug = hsc_HUG env+ -- external deps do not always show up in the ModuleGraph+ -- (e.g. when we are given a cached session),+ -- so we also include the preloadUnits of the home units.+ hugPreloadUIDs =+ [ uid+ | (_,hue) <- unitEnv_assocs hug+ , uid <- GHC.preloadUnits $ homeUnitEnv_units hue ] --- | Rebuilds the UnitState of the unit, exposing the given packages.------ Takes care of updating hsc_dflags, ue_platform, and ue_namever if this is the ue_currentUnit.-setExposedInUnit :: UnitId -> [UnitId] -> Ghc ()-setExposedInUnit unitId exposed = do- env <- GHC.getSession- let old_ie = case lookupHugUnitId unitId (hsc_HUG env) of- Just hue -> hue- Nothing -> error $ "setExposedInUnit: unit not found " ++ unitIdString unitId+-- | WARNING: callback is not to be used from other threads.+withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a+withUnliftGhc k = reifyGhc $ \ s -> k (flip reflectGhc s) - let dflags = (homeUnitEnv_dflags old_ie) { packageFlags = [ExposePackage- (unitIdString uid)- (UnitIdArg $ RealUnit (Definite uid))- (ModRenaming True [])- | uid <- exposed- , uid /= rtsUnitId- , uid /= ghcInternalUnitId- , unitIdString uid /= "haskell-debugger-view-in-memory"- -- FIXME: any other to filter out?- ]}- let cached_dbs = homeUnitEnv_unit_dbs old_ie- let home_units = Set.fromList $ State.homeUnitDepends $ homeUnitEnv_units old_ie- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger env) dflags cached_dbs home_units+annotateCallStackGhc :: HasCallStack => Ghc a -> Ghc a+annotateCallStackGhc m = let x = callStack in withUnliftGhc $ \k -> annotateStackShowIO x $ k m - updated_dflags <- liftIO $ GHC.updatePlatformConstants dflags mconstants- let ie = old_ie- { homeUnitEnv_units = unit_state- , homeUnitEnv_unit_dbs = Just dbs- , homeUnitEnv_dflags = updated_dflags- , homeUnitEnv_home_unit = Just home_unit- } - let home_unit_graph = HUG.unitEnv_insert unitId ie (hsc_HUG env)- let ue0 = hsc_unit_env env- let ue1 = ue0 {ue_home_unit_graph = home_unit_graph}- let- new_env- | ue_currentUnit ue1 /= unitId = hscSetUnitEnv ue1 env- | otherwise = hscSetFlags dflags1 $ hscSetUnitEnv ue2 env- where- dflags1 = homeUnitEnv_dflags $ unitEnv_lookup unitId (ue_home_unit_graph ue1)- ue2 = ue1- { ue_platform = targetPlatform dflags1- , ue_namever = GHC.ghcNameVersion dflags1- }- GHC.setSession new_env- -- | Setup the given 'HscEnv' to hold a 'UnitEnv' -- with all the given components. -- We return the modified 'HscEnv' and all the 'TargetDetails' for@@ -268,7 +361,7 @@ -> HscEnv -- ^ An empty HscEnv that we can use the setup the session. -> [(DynFlags, [GHC.Target])] -- ^ New components to be loaded. Expected to be non-empty. -> IO (HscEnv, [TargetDetails])-setupMultiHomeUnitGhcSession exts hsc_env cis = do+setupMultiHomeUnitGhcSession exts hsc_env cis = annotateCallStackIO $ do let dfs = map fst cis hscEnv' <- initHomeUnitEnv dfs hsc_env@@ -280,14 +373,14 @@ let mk t = fromTargetId (importPaths df) exts (homeUnitId_ df) (GHC.targetId t) (GHC.targetContents t) ctargets <- concatMapM mk targets - return (L.nubOrdOn targetTarget ctargets)+ return (ListUtils.nubOrdOn targetTarget ctargets) pure (hscEnv', concat ts) -- | Find and return the ways in which the home units are built. -- INVARIANT: All home units are built with the same 'Ways'-validateUnitsWays :: NonEmpty.NonEmpty (DynFlags, [GHC.Target]) -> IO Ways-validateUnitsWays flagsAndTargets = do- let unitWays = NonEmpty.map (ways . fst) flagsAndTargets+validateUnitsWays :: NonEmpty.NonEmpty DynFlags -> IO Ways+validateUnitsWays flags = do+ let unitWays = NonEmpty.map ways flags firstWays = NonEmpty.head unitWays restWays = NonEmpty.tail unitWays if all (== firstWays) restWays@@ -341,6 +434,31 @@ | otherwise = (f ++ "-boot") return [TargetDetails (TargetFile f) [f, other] unitId ctts] +{-+Note [ Ambiguous Package Qualified Imports Workaround ]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Source level package qualified imports `import "foo" A` interpret "foo" as a package name.++When one manually builds a `RawPkgQual` for an `ImportDecl` one can get away with using a unit-id, but only for external (i.e. not home) units.+That it works does not seem entirely intended (see quoted snippet below), the code is in `renamePkgQual`: If a package qualifier is not found among packages it's looked up as an external unit. This is already in the code path for `OtherPkg` though, which is why Home Units are excluded.+```+ | otherwise+ -> OtherPkg (UnitId pkg_fs)+ -- not really correct as pkg_fs is unlikely to be a valid unit-id but+ -- we will report the failure later...+```++Home units will only be found if the qualifier matches their dflags' `thisPackageName`. However that's bugged because the lookup doesn't bother considering there can be multiple units in the same package (library, sublibraries and exe units), and just picks the first found, leading to an import error if e.g. the library unit is picked but the module was in the exe one.+Related GHC issue: https://gitlab.haskell.org/ghc/ghc/-/issues/24227++Turns out that the package name of a home unit is pretty meaningless though, so we can update the dflags to replace it with anything that's actually unique so we can dodge the bug.++Another stumbling block is that the `IIDecl` mode of an `InteractiveImport` does not allow importing hidden modules, but again for home units we can alter the DynFlags so all modules are exposed.++See issue #288 for what can we do for users at the repl.+-}+ -- ---------------------------------------------------------------------------- -- GHC Utils that should likely be exposed by GHC -- ----------------------------------------------------------------------------@@ -351,6 +469,37 @@ hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv hscSetUnitEnv ue env = env { hsc_unit_env = ue } +home_unit_dflags :: HscEnv -> UnitId -> Maybe DynFlags+home_unit_dflags hsc_env uid+ = fmap homeUnitEnv_dflags+ . HUG.lookupHugUnitId uid . ue_home_unit_graph+ . hsc_unit_env+ $ hsc_env++-- | See Note [Package Qualified Imports] for why this is sometimes a @PackageName@ and sometimes a @UnitId@.+newtype PackageQualifier = PackageQualifier FastString++lookupUnitPackageQualifier :: HscEnv -> UnitId -> Maybe PackageQualifier+lookupUnitPackageQualifier env uid = home_unit_name <|> ext_unit_name+ where+ -- See Note [Package Qualified Imports]+ home_unit_name = PackageQualifier . mkFastString <$> (thisPackageName =<< home_unit_dflags env uid)+ ext_unit_name = const (PackageQualifier (unitIdFS uid)) <$> lookupUnitId (hsc_units env) uid++packageImportDecl :: PackageQualifier -> ModuleName -> ImportDecl GhcPs+packageImportDecl (PackageQualifier pkgName) mn =+ (GHC.simpleImportDecl $ mn)+ { ideclPkgQual = RawPkgQual+#if MIN_VERSION_ghc(10,1,0)+ NoSourceText pkgName+#else+ StringLiteral+ { sl_st = NoSourceText+ , sl_fs = pkgName+ , sl_tc = Nothing+ }+#endif+ } -- ---------------------------------------------------------------------------- -- Session cache directory -- ----------------------------------------------------------------------------@@ -382,6 +531,69 @@ -- GHC options will create incompatible interface files. opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) ++getTargetFileSummary ::+ HscEnv ->+ GHC.Target ->+ IO (Either GHC.DriverMessages GHC.ModSummary)+getTargetFileSummary hsc_env target+ | GHC.TargetFile file mb_phase <- targetId+ = do+ let offset_file = GHC.augmentByWorkingDirectory dflags file+ exists <- liftIO $ doesFileExist offset_file+#if MIN_VERSION_ghc(10,1,0)+ -- summariseFile now takes a mutable ModSummary cache (an IORef).+ old_summary_map <- newIORef Map.empty+#endif+ if exists || isJust maybe_buf+ then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase+ maybe_buf+ else+ return $ Left $ GHC.singleMessage $+ GHC.mkPlainErrorMsgEnvelope noSrcSpan (GHC.DriverFileNotFound offset_file)+ | otherwise = error "FIXME"+ where+#if !MIN_VERSION_ghc(10,1,0)+ old_summary_map = Map.empty+#endif+ GHC.Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target+ home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+ dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))++compileModuleWithDepsInHpt ::+ GHC.Target ->+ Ghc (Maybe SourceError)+compileModuleWithDepsInHpt target@GHC.Target{targetUnitId = uid} = do+ hsc_env0 <- getSession+ let !old_active = hscActiveUnitId hsc_env0+ let !hsc_env = hscSetActiveUnitId uid hsc_env0+ ehmi <- liftIO $ try @SourceError $ do+ Right summary <- getTargetFileSummary hsc_env target+ result <- compileOne hsc_env (forceRecomp summary) 1 1 Nothing (GHC.HomeModLinkable Nothing Nothing)+ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (ms_hspp_opts summary)+ pure result+ case ehmi of+ Left e -> do+ return $ Just e+ Right hmi -> do+ setSession . hscSetActiveUnitId old_active =<< liftIO (addDepsToHscEnv [hmi] hsc_env)+ return Nothing+ where+ -- This bypasses another recompilation check in 'compileOne'+ forceRecomp summary =+ summary {ms_hspp_opts = gopt_set (ms_hspp_opts summary) Opt_ForceRecomp}++addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> IO HscEnv+addDepsToHscEnv deps hsc_env = do+ for_ deps $ \ dep -> hscInsertHPT dep hsc_env+ pure hsc_env++cleanCurrentModuleTempFilesMaybe :: MonadIO m => GHC.Logger -> TmpFs -> DynFlags -> m ()+cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =+ if gopt Opt_KeepTmpFiles dflags+ then liftIO $ keepCurrentModuleTempFiles logger tmpfs+ else liftIO $ cleanCurrentModuleTempFiles logger tmpfs+ -- ---------------------------------------------------------------------------- -- The Interactive DynFlags -- ----------------------------------------------------------------------------@@ -507,6 +719,9 @@ setPgmI f = alterToolSettings $ \s -> s { toolSettings_pgm_i = f } addOptI f = alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } +getPgmI :: DynFlags -> String+getPgmI df = toolSettings_pgm_i (toolSettings df)+ alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } @@ -523,6 +738,10 @@ (wayUnsetGeneralFlags platform w) in dflags3 +-- | See Note [ UniqSupply is process global ]+initUniqSupplyIO :: IO ()+initUniqSupplyIO = GHC.initUniqSupply 0 1+ -- ---------------------------------------------------------------------------- -- Wrappers around GHC's odd behavior -- ----------------------------------------------------------------------------@@ -576,3 +795,8 @@ | otherwise = f xs (drop i xs) where f (a:as) (_:bs) = a : f as bs f _ _ = []++#if !MIN_VERSION_ghc(10,1,0)+deriving instance Ord PkgDbRef+deriving instance Ord PackageDBFlag+#endif
haskell-debugger/GHC/Debugger/Session/Builtin.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -- | Built-in units and modules module GHC.Debugger.Session.Builtin@@ -6,12 +8,24 @@ debuggerViewBuiltinMods , debuggerViewInstancesMods , debuggerViewClassModName, debuggerViewClassContents- -- * In memory unit , hsDebuggerViewInMemoryUnitId , addInMemoryHsDebuggerViewUnit- , makeInMemoryHsDebuggerViewTarget+ , makeInMemoryTarget+ , runInternal + , debuggerInternalUnitId+ , addInMemoryDebuggerInternalUnit+ , debuggerRuntimeInternalContents+ , debuggerRuntimeInternalModName+ , debuggerRuntimeInternalUnit+ , debuggerRuntimeInternalModule++#if !MIN_VERSION_ghc(9,14,2)+ , addInMemoryFFIInspectUnit+ , hsDebuggerFFIInspectUnitId+ , debuggerRuntimeFFIInspectModName, debuggerRuntimeFFIInspectContents+#endif -- 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.@@ -20,9 +34,11 @@ import Data.FileEmbed import Data.Function-import Data.Maybe import Data.Time+#if !MIN_VERSION_ghc(10,1,0)+import Data.Maybe import qualified Data.Foldable as Foldable+#endif import GHC import GHC.Unit@@ -33,6 +49,12 @@ 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.Data.FastString (unpackFS)+import Data.Coerce+import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.LanguageExtensions as LangExt+import GHC.Runtime.Context (InteractiveContext(..), emptyInteractiveContext)+import Control.Monad.Catch (finally) -------------------------------------------------------------------------------- -- * Built-in Modules@@ -94,9 +116,97 @@ => [UnitId] -- ^ The unit-ids from the transitive dependencies closure of the user-given targets -> DynFlags -- ^ Dynflags resulting from first downsweep of user given targets -> m ()-addInMemoryHsDebuggerViewUnit base_uids initialDynFlags = do+addInMemoryHsDebuggerViewUnit = addInMemoryUnit+ hsDebuggerViewInMemoryUnitId+ (PackageName "haskell-debugger-view")++#if !MIN_VERSION_ghc(9,14,2)+-- | The fixed unit-id (@haskell-debugger-ffi-inspect@) used to load @GHC.Debugger.Runtime.FFIInspect@ in the debuggee when we can't have custom ghci-serv commands.+hsDebuggerFFIInspectUnitId :: UnitId+hsDebuggerFFIInspectUnitId = stringToUnitId "haskell-debugger-ffi-inspect"++addInMemoryFFIInspectUnit :: GhcMonad m => [UnitId] -> DynFlags -> m UnitId+addInMemoryFFIInspectUnit deps dflags = do+ addInMemoryUnit+ hsDebuggerFFIInspectUnitId+ (coerce hsDebuggerFFIInspectUnitId)+ deps dflags+ return hsDebuggerFFIInspectUnitId+#endif++-- run internal here serves to overwrite certain flags while executing the+-- internal "evalWrapper" computation which is not relevant to the user.+runInternal :: GhcMonad m => m a -> m a+runInternal m = withSavedSession $ do+ modifySession $+ -- The new imports are checked against the old ones: GHC attempts to scan+ -- them for orphan instances, and crashes if those modules are not+ -- accessible from the new active unit.+ --+ -- We empty anything to do with things defined interactively too.+ emptyIC .+ hscSetActiveUnitId debuggerInternalUnitId+ setContext [IIDecl $ GHC.simpleImportDecl $ GHC.mkModuleName "Prelude"]+ m+ where+ withSavedSession act = do+ s <- getSession+ act `finally` setSession s+ emptyIC env = case hsc_IC env of+ InteractiveContext{..} ->+ env {hsc_IC = (emptyInteractiveContext ic_dflags)+ { ic_mod_index = ic_mod_index+ , ic_int_print = ic_int_print+ , ic_monad = ic_monad+ }}++debuggerInternalUnitId :: UnitId+debuggerInternalUnitId = stringToUnitId "haskell-debugger-internal"++addInMemoryDebuggerInternalUnit :: (MonadFail m, GhcMonad m) => DynFlags -> m ()+addInMemoryDebuggerInternalUnit dflags = do+ us <- hsc_units <$> getSession+ Just deps' <- pure $ mapM (lookupPackageName us . PackageName) ["ghc-heap","ghci"]++ let deps = baseUnitId dflags+#if !MIN_VERSION_ghc(9,14,2)+ : hsDebuggerFFIInspectUnitId+#endif+ : deps'+ addInMemoryUnit+ debuggerInternalUnitId+ (coerce debuggerInternalUnitId)+ deps $+ dflags+ { -- Running GHCi's internal expression is incompatible with -XSafe.+ -- We temporarily disable any Safe Haskell settings while running+ -- GHCi internal expressions. (see #12509)+ safeHaskell = GHC.Sf_None,+ -- Disable dumping of any data during evaluation of GHCi's internal+ -- expressions. (#17500)+ dumpFlags = EnumSet.empty+ }+ -- RebindableSyntax can wreak havoc with GHCi in several ways+ -- (see #13385 and #14342 for examples), so we temporarily+ -- disable it too.+ `xopt_unset` LangExt.RebindableSyntax+ -- We heavily depend on -fimplicit-import-qualified to compile expr+ -- with fully qualified names without imports.+ `gopt_set` Opt_ImplicitImportQualified+++ return ()+++addInMemoryUnit :: GhcMonad m+ => UnitId -- ^ The unit-id for the unit to add+ -> PackageName -- ^ The package name for the unit to add+ -> [UnitId] -- ^ The unit-ids for dependencies+ -> DynFlags -- ^ Dynflags to base the unit on.+ -> m ()+addInMemoryUnit uid (PackageName pkgName) base_uids initialDynFlags = do let imhdv_dflags = initialDynFlags- { homeUnitId_ = hsDebuggerViewInMemoryUnitId+ { homeUnitId_ = uid , importPaths = [] , packageFlags = [ ExposePackage@@ -107,11 +217,22 @@ , unitId /= rtsUnitId , unitId /= ghcInternalUnitId ]+ , thisPackageName = Just $ unpackFS pkgName }- & setGeneralFlag' Opt_HideAllPackages+ & flip gopt_unset Opt_HideAllPackages+ & flip gopt_unset Opt_InsertBreakpoints+#if MIN_VERSION_ghc(9,14,2)+ -- In memory modules should not write .hi nor .gbc files.+ & flip gopt_unset Opt_WriteByteCode+ & flip gopt_unset Opt_WriteInterface+#endif hsc_env <- getSession+#if MIN_VERSION_ghc(10,1,0)+ (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger hsc_env) imhdv_dflags (hscUIC hsc_env) $ HUG.allUnits $ hsc_HUG $ hsc_env+#else 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+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger hsc_env) imhdv_dflags (Just cached_unit_dbs) $ HUG.allUnits $ hsc_HUG $ hsc_env+#endif updated_dflags <- liftIO $ updatePlatformConstants imhdv_dflags mconstants emptyHpt <- liftIO HPT.emptyHomePackageTable modifySession $ \env ->@@ -120,27 +241,76 @@ & hscUpdateHUG (\hug -> let hdv_hue = HUG.HomeUnitEnv { HUG.homeUnitEnv_units = unit_state+#if !MIN_VERSION_ghc(10,1,0) , HUG.homeUnitEnv_unit_dbs = Just dbs+#endif , HUG.homeUnitEnv_dflags = updated_dflags , HUG.homeUnitEnv_hpt = emptyHpt , HUG.homeUnitEnv_home_unit = Just home_unit }- in HUG.unitEnv_insert hsDebuggerViewInMemoryUnitId hdv_hue hug+ in HUG.unitEnv_insert uid 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++-- | Make an in-memory 'GHC.Target' for a module from the module name and contents+makeInMemoryTarget :: UnitId -> ModuleName -> StringBuffer -> IO GHC.Target+makeInMemoryTarget uid modName sb = do time <- getCurrentTime let mkTarget mn contents = GHC.Target { targetId = GHC.TargetFile ("in-memory:" ++ moduleNameString mn) Nothing , targetAllowObjCode = False- , GHC.targetUnitId = hsDebuggerViewInMemoryUnitId+ , GHC.targetUnitId = uid , GHC.targetContents = Just (contents, time) } return $ mkTarget modName sb ++{- Note [debuggerInternal unit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In a few cases we want to compile and run debugger code on the interpreter, e.g.++- define constant for `setInteractivePrintName`+- format and print messages for logging breakpoints+- Specialize `evalWrapper` to provided arguments++and more uses if you include .Legacy.++There is however a challenge: the normally active unit is+`interactiveGhcDebugger`, which depends on the debuggee units, so we can't be+sure how module names are resolved: if the intended module is shadowed by+another package you might just get a "Not in scope" error. Extensions like+`RebindableSyntax` or `Overloaded*` also cause problems, as listed in the+comments to `runInternal` in ghci's codebase.++As a defensive measure we add an in-memory unit, debuggerInternalUnit, dedicated to+running "internal" code, which only depends on boot packages we need.++The unit is depended upon by interactiveGhcDebugger, and exposes the module+`GHC.Debugger.Runtime.Internal` where various aliases or helpers that are needed+at runtime are defined. The module is also compiled as part of the+haskell-debugger package, so it can be used from custom commands if needed.++The aliases are helpful when we have to evaluate expressions that mix+debuggee/user code and internal code, like `logMessageExpression`, because there's+less of a chance that e.g. `GHC.Debugger.Runtime.Internal.concat` would clash+compared to `Prelude.concat`, since there are custom preludes out there.++Moreover we define our own version of `runInteral` which temporarily sets+`debuggerInternalUnit` as the active unit, reducing the possible interactions.++Reccommendations for runtime code:+ - See if it can be made a custom command first.+ - Refer only to functions via `GHC.Debugger.Runtime.Internal` not any other modules.+ - Prefer plain function application rather than syntactic sugar (even list or tuple syntax counts as sugar).+ - Define an helper in GHC.Debugger.Runtime.Internal rather than evaluate a larger expression.+ - If compiling exclusively internal code, use `runInternal`.++For .Legacy the reccommendation is relaxed to the use of runInternal, as it+should be sufficient and avoids polishing a module we want to get rid of.+-}++ -------------------------------------------------------------------------------- -- * In memory module contents --------------------------------------------------------------------------------@@ -160,3 +330,26 @@ -- | GHC.Debugger.View.ByteString debuggerViewByteStringContents :: StringBuffer debuggerViewByteStringContents = stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs")++#if !MIN_VERSION_ghc(9,14,2)+debuggerRuntimeFFIInspectModName :: ModuleName+debuggerRuntimeFFIInspectModName = mkModuleName "GHC.Debugger.Runtime.FFIInspect"++-- | The contents of GHC.Debugger.Runtime.FFIInspect in memory+debuggerRuntimeFFIInspectContents :: StringBuffer+debuggerRuntimeFFIInspectContents = stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger/GHC/Debugger/Runtime/FFIInspect.hs")+#endif++debuggerRuntimeInternalModName :: ModuleName+debuggerRuntimeInternalModName = mkModuleName "GHC.Debugger.Runtime.Internal"++-- | The contents of GHC.Debugger.Runtime.FFIInspect in memory+debuggerRuntimeInternalContents :: StringBuffer+debuggerRuntimeInternalContents = stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger/GHC/Debugger/Runtime/Internal.hs")++debuggerRuntimeInternalModule :: Module+debuggerRuntimeInternalModule = mkModule debuggerRuntimeInternalUnit debuggerRuntimeInternalModName++debuggerRuntimeInternalUnit :: Unit+debuggerRuntimeInternalUnit = RealUnit (Definite debuggerInternalUnitId)+
haskell-debugger/GHC/Debugger/Session/Interactive.hs view
@@ -13,99 +13,20 @@ module GHC.Debugger.Session.Interactive where import Control.Monad.IO.Class-import Data.Maybe #if MIN_VERSION_ghc(9,15,0) import GHC.Linker.Types (modifyHomePackageBytecodeState) #endif import GHC-import GHC.Driver.Config-import GHC.Driver.DynFlags as GHC import GHC.Driver.Env-import GHC.Driver.Main-import qualified GHC.Linker.Loader as Loader-import GHC.Runtime.Interpreter as GHCi-import GHC.Runtime.Context as GHCi-import GHCi.RemoteTypes (HValueRef)+import GHC.Iface.Env (lookupNameCache)+import GHC.Debugger.Session.Builtin+import GHC.Plugins (mkVarOcc, Definite (Definite), GenUnit (RealUnit)) -- | Defines a strict @noPrintConstant :: a -> IO ()@ while taking care not to introduce its OccName into scope. defineNoPrint :: Ghc Name defineNoPrint = do- let ExecOptions{execSourceFile,execLineNumber} = GHC.execOptions hsc_env <- getSession- let input = "let noPrintConstant x = x `Prelude.seq` Prelude.return () :: Prelude.IO ()"- stmt <-- liftIO $ fmap (fromMaybe $ error "impossible: parsing noPrintConstant") $- runInteractiveHsc hsc_env $- hscParseStmtWithLocation execSourceFile execLineNumber input-- mr <- execStmtNoOccEnv stmt- case mr of- Just ExecComplete{execResult = Right [n]} -> return n- _ -> error "impossible: defining noPrintConstant"---- | Executes a statement to completion without bringing any OccName in scope.-execStmtNoOccEnv :: GhcMonad m => GhciLStmt GhcPs -> m (Maybe ExecResult)-execStmtNoOccEnv stmt = do- hsc_env <- getSession- let interp = hscInterp hsc_env-- -- Turn off -fwarn-unused-local-binds when running a statement, to hide- -- warnings about the implicit bindings we introduce.- let ic = hsc_IC hsc_env -- use the interactive dflags- idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds- hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' }})-- r <- liftIO $ hscParsedStmt hsc_env' stmt-- case r of- Nothing ->- -- empty statement / comment- return (Just $ ExecComplete (Right []) 0)- Just (ids, hval, _fix_env) -> do- -- updateFixityEnv fix_env-- status <-- liftIO $ do- let eval_opts = initEvalOpts idflags' EvalStepNone- evalStmt interp eval_opts (EvalThis hval)-- handleCompleted extendInteractiveContextWithIdsNoOccEnv ids status--handleCompleted :: GhcMonad m- => (InteractiveContext -> [Id] -> InteractiveContext)- -> [Id]- -> EvalStatus_ [ForeignHValue] [HValueRef]- -> m (Maybe ExecResult)-handleCompleted extendIC final_ids status = do- hsc_env <- getSession- let- interp = hscInterp hsc_env- case status of-- -- Completed successfully- EvalComplete allocs (EvalSuccess hvals) -> do- let- final_ic = extendIC (hsc_IC hsc_env) final_ids- final_names = map getName final_ids-#if MIN_VERSION_ghc(9,15,0)- liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals)-#else- liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)-#endif- -- hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}- setSession $ hsc_env{hsc_IC=final_ic}- return (Just $ ExecComplete (Right final_names) allocs)- _ -> return Nothing---- | Extend the @InteractiveContext@ with the @Id@s without bringing their @OccName@s in scope.-extendInteractiveContextWithIdsNoOccEnv :: InteractiveContext -> [Id] -> InteractiveContext-extendInteractiveContextWithIdsNoOccEnv ictxt new_ids- | null new_ids = ictxt- | otherwise- = ictxt { ic_mod_index = ic_mod_index ictxt + 1- , ic_tythings = new_tythings ++ ic_tythings ictxt- }- -- no change to ic_gre_cache as that deals with OccNames- where- new_tythings = map AnId new_ids+ let debuggerInternalUnit = RealUnit (Definite debuggerInternalUnitId)+ liftIO $ lookupNameCache (hsc_NC hsc_env) (mkModule debuggerInternalUnit debuggerRuntimeInternalModName)+ (mkVarOcc "noPrintConstant")
haskell-debugger/GHC/Debugger/Stopped.hs view
@@ -25,6 +25,7 @@ import qualified GHC.Unit.Home.Graph as HUG import GHC.Debugger.Stopped.Exception+import GHC.Debugger.Stopped.Frames import GHC.Debugger.Stopped.Variables import GHC.Debugger.Runtime import GHC.Debugger.Runtime.Thread@@ -35,6 +36,7 @@ import qualified GHC.Debugger.Interface.Messages as DbgStackFrame (DbgStackFrame(..)) import GHC.Debugger.Utils import qualified Colog.Core as Logger+import System.Directory (getCurrentDirectory) {- Note [Don't crash if not stopped]@@ -115,6 +117,7 @@ hsc_env <- getSession let hug = hsc_HUG hsc_env+ cwd <- mkAbsolute <$> liftIO getCurrentDirectory decoded_frames <- catMaybes <$> case m_f_tid of Nothing -> pure [] Just f_tid -> do@@ -122,7 +125,7 @@ -- and use the BRK_FUN src locations. stack_frames <- getRemoteThreadStackCopy f_tid forM stack_frames $ \case- StackFrameBreakpointInfo ibi -> do+ StackFrameBreakpointInfo ibi s -> do info_brks <- liftIO $ readIModBreaks hug ibi let modl = getBreakSourceMod ibi info_brks srcSpan <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks@@ -131,28 +134,31 @@ modl_str <- display modl return $ Just DbgStackFrame { name = modl_str ++ "." ++ decl- , sourceSpan = realSrcSpanToSourceSpan $ realSrcSpan srcSpan+ , sourceSpan = realSrcSpanToSourceSpan cwd $ realSrcSpan srcSpan , breakId = Just ibi+ , args = Just s } StackFrameIPEInfo ipe -> do- case srcSpanStringToSourceSpan (ipLoc ipe) of+ case srcSpanStringToSourceSpan cwd (ipLoc ipe) of Left err -> do -- Couldn't parse. The srcLoc may be invalid so just keep this as info, not warning. logSDoc Logger.Info $ text "Couldn't parse StackEntry srcLoc \"" Ppr.<> text (ipLoc ipe) Ppr.<> text "\":" <+> text err return Nothing- Right sourceSpan ->+ Right sourceSpan -> do return $ Just DbgStackFrame { name = ipMod ipe ++ "." ++ ipLabel ipe , sourceSpan = sourceSpan , breakId = Nothing+ , args = Nothing } StackFrameAnnotation srcLoc ann -> do return $ Just DbgStackFrame { name = ann- , sourceSpan = maybe unhelpfulSourceSpan srcLocToSourceSpan srcLoc+ , sourceSpan = maybe unhelpfulSourceSpan (srcLocToSourceSpan cwd) srcLoc , breakId = Nothing+ , args = Nothing } -- Add the latest resume context at the head.@@ -162,7 +168,7 @@ return Nothing r:_ -> do let resumeSpanR = GHC.resumeSpan r- mRealSpan = realSrcSpanToSourceSpan <$> srcSpanToRealSrcSpan resumeSpanR+ mRealSpan = realSrcSpanToSourceSpan cwd <$> srcSpanToRealSrcSpan resumeSpanR firstSpan = DbgStackFrame.sourceSpan <$> listToMaybe decoded_frames r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r) if r_tid /= req_tid then@@ -180,6 +186,7 @@ { name = modl_str ++ "." ++ GHC.resumeDecl r , sourceSpan = ss , breakId = Just ibi+ , args = Nothing } _ -> do mExcSpan <- exceptionInfoSourceSpan <$> getExceptionInfo req_tid@@ -188,6 +195,7 @@ { name = GHC.resumeDecl r , sourceSpan , breakId = Nothing+ , args = Nothing } Nothing -> return Nothing return (maybe id (:) head_frame $ decoded_frames)@@ -270,6 +278,7 @@ -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`) -- (VARR)(b,c) SpecificVariable key -> do+ term <- obtainTerm key case term of@@ -298,10 +307,14 @@ VarFields vfs -> pure (VariableFields vfs) -- (VARR)(a) from here onwards- LocalVariables -> fmap VariableFields $ do- -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)- mapM (tyThingToVarInfo fam_envs) =<< GHC.getBindings+ vars <- if frameIx == 0+ then+ -- top frame vars already bound when stopping+ GHC.getBindings+ else+ map AnId <$> getStackFrameBindings frame+ mapM (tyThingToVarInfo fam_envs) vars ModuleVariables | frameIx < length frames
haskell-debugger/GHC/Debugger/Stopped/Exception.hs view
@@ -20,15 +20,10 @@ ) import GHC.Debugger.Runtime.Thread import GHCi.RemoteTypes-#if MIN_VERSION_ghc(9,15,0)+#if MIN_VERSION_ghc(9,14,2) import qualified GHC.Debugger.Runtime.Interpreter as Debuggee #else-import GHC.Builtin.Types (anyTy)-import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote-import GHC.Debugger.Runtime.Term.Parser-import GHC.Debugger.Interface.Messages (SourceSpan(..))-import GHC.Utils.Outputable as Ppr-import qualified Colog.Core as Logger+import qualified GHC.Debugger.Runtime.Interpreter.Legacy as Debuggee #endif import Control.Exception (SomeException) @@ -52,118 +47,7 @@ #if MIN_VERSION_ghc(9,15,0) Just <$> Debuggee.collectExceptionInfo excRef #else- -- 1. Add a "data" declaration for the datatype the expression will return- _ <- runDecls exceptionInfoData- -- 2. Gather information about the exception.- evalRes <- Remote.eval- (Remote.raw exceptionInfoExpr `Remote.app` Remote.ref excRef)- case evalRes of- Left err -> do- logSDoc Logger.Debug $- Ppr.text "Failed to evaluate exception info:" Ppr.<+> Ppr.text (show err)- return Nothing- Right fhv -> do- parsed <- obtainParsedTerm "Exception info" 4 True anyTy (castForeignRef fhv)- exceptionInfoParser- case parsed of- Left errs -> do- logSDoc Logger.Debug $- Ppr.text "Failed to parse exception info:"- Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs)- return Nothing- Right info -> return (Just info)---- | Parse the helper 'ExceptionInfoNode' structure produced inside the--- debuggee into our externally facing 'ExceptionInfo'.-exceptionInfoParser :: TermParser ExceptionInfo-exceptionInfoParser = do- ExceptionInfo- <$> subtermWith 0 stringParser- <*> subtermWith 1 stringParser- <*> subtermWith 2 stringParser- <*> subtermWith 3 (maybeParser stringParser)- <*> subtermWith 4 (maybeParser exceptionLocationTupleParser)- <*> subtermWith 5 (parseList exceptionInfoParser)- where- -- Parsed from @(String, Int, Int)@.- exceptionLocationTupleParser :: TermParser SourceSpan- exceptionLocationTupleParser = do- locFile <- subtermWith 0 stringParser- srcLine <- subtermWith 1 intParser- srcCol <- subtermWith 2 intParser- pure SourceSpan- { file = locFile- , startLine = srcLine- , startCol = srcCol- , endLine = srcLine- , endCol = srcCol- }---- | Definition for the helper 'ExceptionInfoNode' data type compiled into the--- debuggee to aid in transporting nested exception information.--- We need a specific datatype because ExceptionInfoNode is recursive.-exceptionInfoData :: String-exceptionInfoData = """- data ExceptionInfoNode = ExceptionInfoNode- { exceptionNodeTypeName :: String- , exceptionNodeFullTypeName :: String- , exceptionNodeMessage :: String- , exceptionNodeContext :: Data.Maybe.Maybe String- , exceptionNodeSourceSpan :: Data.Maybe.Maybe (String, Int, Int)- , exceptionNodeInner :: [ExceptionInfoNode]- }- """---- | Helper expression run in the debuggee that walks the exception context and--- populates the 'ExceptionInfoNode' structure.-exceptionInfoExpr :: String-exceptionInfoExpr = """- let collectExceptionInfo :: Control.Exception.SomeException -> ExceptionInfoNode- collectExceptionInfo se' =- case se' of- Control.Exception.SomeException exc ->- let ctx = Control.Exception.someExceptionContext se'- rendered = Control.Exception.Context.displayExceptionContext ctx- whileHandling = Control.Exception.Context.getExceptionAnnotations ctx- innerNodes = Prelude.map (collectExceptionInfo Prelude.. unwrap) whileHandling- sourceSpan = exceptionContextLocation ctx- simpleTypeName = Data.Typeable.tyConName tc- modulePrefix = case Data.Typeable.tyConModule tc of- mdl | Prelude.null mdl -> \"\"- | otherwise -> mdl Prelude.++ \".\"- packagePrefix = case Data.Typeable.tyConPackage tc of- pkg | Prelude.null pkg -> \"\"- | otherwise -> pkg Prelude.++ \":\"- tc = Data.Typeable.typeRepTyCon (Data.Typeable.typeOf exc)- fullTypeName = packagePrefix Prelude.++ modulePrefix Prelude.++ simpleTypeName- unwrap (Control.Exception.WhileHandling inner) = inner- contextText = if Prelude.null rendered then Data.Maybe.Nothing else Data.Maybe.Just rendered- in ExceptionInfoNode- { exceptionNodeTypeName = simpleTypeName- , exceptionNodeFullTypeName = fullTypeName- , exceptionNodeMessage = Control.Exception.displayException se'- , exceptionNodeContext = contextText- , exceptionNodeSourceSpan = sourceSpan- , exceptionNodeInner = innerNodes- }- exceptionContextLocation ctx =- let fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of- Data.Maybe.Just (_, loc) ->- Data.Maybe.Just- ( GHC.Exception.srcLocFile loc- , GHC.Exception.srcLocStartLine loc- , GHC.Exception.srcLocStartCol loc- )- Data.Maybe.Nothing -> Data.Maybe.Nothing- bts :: [Control.Exception.Backtrace.Backtraces]- bts = Control.Exception.Context.getExceptionAnnotations ctx- in case bts of- bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of- Data.Maybe.Just cs -> fromCallStack cs- Data.Maybe.Nothing -> Data.Maybe.Nothing- [] -> Data.Maybe.Nothing- in collectExceptionInfo- """+ Debuggee.collectExceptionInfo excRef #endif -- | Placeholder exception info returned when the context could not be
+ haskell-debugger/GHC/Debugger/Stopped/Frames.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+ DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+ TypeApplications, ScopedTypeVariables, BangPatterns, MultiWayIf, OverloadedRecordDot #-}+module GHC.Debugger.Stopped.Frames+ ( getStackFrameBindings+ , addIdsToInteractiveContext+ )+ where++import Control.Monad+import Control.Monad.Reader+import qualified Data.List as L+import qualified Data.Map.Strict as Map++import GHC+import GHC.ByteCode.Breakpoints+import GHC.Data.Maybe+import GHC.Driver.Env as GHC+import GHC.Runtime.Eval+import GHC.Utils.Outputable as Ppr++import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Utils+import qualified Colog.Core as Logger+import qualified GHC.Plugins as GHC+import qualified GHC.Tc.Utils.Monad as GHC+import qualified GHC.IfaceToCore as GHC+import qualified GHC.Linker.Loader as Loader+import qualified GHC.Exts.Heap.Closures as GHC+import qualified GHC.Types.Id as Id+import GHC.Iface.Env (newInteractiveBinder)+import qualified GHC.Runtime.Context as GHC+import qualified GHC.Core.Predicate as GHC+import qualified GHC.Core.TyCo.Tidy as GHC+import qualified GHC.Types.RepType as GHC+import qualified GHC.Tc.Utils.TcType as GHC+import qualified GHC.Utils.Logger as GHC+import qualified GHC.Core.TyCo.Ppr as GHC+import qualified GHC.Runtime.Heap.Inspect as GHC+import GHCi.RemoteTypes (ForeignRef)+#if MIN_VERSION_ghc(9,14,2)+import GHC.Linker.Types+import qualified GHC.Debugger.Runtime.Interpreter as Debuggee+#else+import qualified GHC.Debugger.Runtime.Interpreter.Legacy as Debuggee+#endif++-- We need a fresh Unique for each Id we bind, because the linker+-- state is single-threaded and otherwise we'd spam old bindings+-- whenever we stop at a breakpoint. The InteractveContext is properly+-- saved/restored, but not the linker state. See #1743, test break026.+mkNewId :: HscEnv -> GHC.FastString -> GHC.Type -> Maybe Id -> IO Id+mkNewId hsc_env occ ty old_id+ = do { name <- newInteractiveBinder hsc_env (GHC.mkVarOccFS occ) (fromMaybe GHC.interactiveSrcSpan $ GHC.getSrcSpan <$> old_id)+ -- NB: use variable namespace.+ -- Don't use record field namespaces, lest we cause #25109.+ ; return $ Id.mkVanillaGlobalWithInfo name ty (fromMaybe GHC.vanillaIdInfo $ GHC.idInfo <$> old_id) }++getStackFrameBindings :: DbgStackFrame -> Debugger [Id]+getStackFrameBindings frame@DbgStackFrame{breakId = ibi,args = Nothing} = do+ logSDoc Logger.Warning $ text "getStackFrameBindings: no args. ibi,frame =" <+> ppr ibi <+> text "," <+> text (show frame)+ return []+getStackFrameBindings DbgStackFrame{breakId = ibi0, args = Just (DbgStackFrameBCOArgs (NoShow bcoArgsRef) offset0)} = do+ case (ibi0, offset0) of+ (Just ibi, Just offset)+ -> do+#ifdef TESTING+ -- Making sure the fallback path doesn't crash.+ -- It was hard to directly trigger.+ fids <- bindFrameVarsWithNoInfo bcoArgsRef+ logSDoc Logger.Debug $ text "fallback ids" <+> ppr fids+#endif+ bindFrameVarsWithBreakpointInfo ibi bcoArgsRef offset+ _ -> bindFrameVarsWithNoInfo bcoArgsRef++bindFrameVarsWithNoInfo :: ForeignRef [GHC.StackField] -> Debugger [Id]+bindFrameVarsWithNoInfo bcoArgsRef = do+ bcoArgs <- Debuggee.unpackStackFields bcoArgsRef Nothing+ hsc_env <- getSession+ let artificial = zipWith fa bcoArgs [0 :: Int ..]+ where+ fa fv i = do+ id' <- mkNewId hsc_env (GHC.mkFastString $ "_a" ++ show i) (GHC.anyTypeOfKind GHC.liftedTypeKind) Nothing+ pure $ (id', fv, getOccName id')+ arts <- liftIO $ sequence artificial+ liftIO $ bindForeignHValues hsc_env arts++bindFrameVarsWithBreakpointInfo :: InternalBreakpointId -> ForeignRef [GHC.StackField] -> Word -> Debugger [Id]+bindFrameVarsWithBreakpointInfo ibi bcoArgs delta0 = do+ hsc_env <- getSession+ let hug = hsc_HUG hsc_env++ info_brks <- liftIO $ readIModBreaks hug ibi+ occs <- liftIO $ getBreakVars (readIModModBreaks hug) ibi info_brks+ let info = getInternalBreak ibi info_brks+ let delta = fromIntegral delta0+ (mbVars, _result_ty) <- liftIO $ GHC.initIfaceLoad hsc_env+ $ GHC.initIfaceLcl (ibi_info_mod ibi) (text "debugger") NotBoot+ $ GHC.hydrateCgBreakInfo info+ unless (length mbVars == length occs) $ do+ logSDoc Logger.Warning $ text "different length of cgb_vars and getBreakVars for ibi" <+> ppr mbVars <+> ppr occs <+> ppr ibi+ let mbVarsIx = flip map mbVars $ \x -> x >>= \(var,offset) -> (var,) <$> do+ guard (offset >= delta)+ pure (offset - delta)+ let discarded = [p | p@(Just _, Nothing) <- zip mbVars mbVarsIx]+ unless (null discarded) $ do+ logSDoc Logger.Warning $ text "Variables discarded due to (offset - delta) underflow: delta =" <+> ppr delta <+> text "," <+> ppr discarded+ let varsIxs = Map.fromList [ (pos :: Int,v) | (pos,Just v) <- zip [0..] mbVarsIx]++ let joinOccs m = Map.elems $ Map.intersectionWith (\(x,y) z -> (x,y,z)) m (Map.fromList $ zip [0..] occs)++ fhvs <- joinOccs <$> do+ withMapElems varsIxs $ \ xs -> withListElems xs $+ Debuggee.unpackStackFields bcoArgs . Just . map fromIntegral++ liftIO $ bindForeignHValues hsc_env fhvs+ where+ withListElems :: Monad m => [(a,b)] -> ([b] -> m [c]) -> m [(a,c)]+ withListElems xs f = do+ let (as,bs) = unzip xs+ bs' <- f bs+ pure $ zip as bs'++ withMapElems :: (Monad m, Ord a) => Map.Map a b -> ([b] -> m [c]) -> m (Map.Map a c)+ withMapElems m f = Map.fromList <$> withListElems (Map.toList m) f++-- | Modeled after bindLocalsAtBreakpoint+-- Returns new Ids generated from the given ones and OccNames, with refreshed free type variables.+-- The values are bound to the new Ids in the loader state.+bindForeignHValues :: HscEnv -> [(Id, ForeignHValue, GHC.OccName)] -> IO [Id]+bindForeignHValues hsc_env mbVals = do+ let interp = hscInterp hsc_env+ let+ -- Filter out any unboxed ids by changing them to Nothings;+ -- we can't bind these at the prompt++ -- TODO: do we have the same restriction in hdb?+ mbPointers = [x | x@(id',_,_) <- mbVals, isPointer id']++ (ids, hvalues, occs) = unzip3 mbPointers++ new_ids <- mkNewIds ids occs++ let names = map GHC.idName new_ids++ let fhvs = hvalues+ Loader.extendLoadedEnv interp+#if MIN_VERSION_ghc(9,14,2)+ modifyHomePackageBytecodeState+#endif+ (zip names fhvs)+ return new_ids+ where+ mkNewIds ids occs = do+ let+ free_tvs = GHC.tyCoVarsOfTypesWellScoped (map idType ids)++ us <- GHC.mkSplitUniqSupply+#if MIN_VERSION_ghc(9,14,2)+ GHC.BcoTag+#else+ 'b'+#endif+ let tv_subst = newTyVars us free_tvs+ tidy_tys = GHC.tidyOpenTypes GHC.emptyTidyEnv $+ map (GHC.substTy tv_subst . idType) ids+ mkNewId' occ ty id' = mkNewId hsc_env (GHC.occNameFS occ) ty (Just id')+ GHC.zipWith3M mkNewId' occs tidy_tys ids++ mkRuntimeUnkTyVar :: Name -> Kind -> TyVar+ mkRuntimeUnkTyVar name kind = GHC.mkTcTyVar name kind GHC.RuntimeUnk++ newTyVars :: GHC.UniqSupply -> [GHC.TcTyVar] -> GHC.Subst+ -- Similarly, clone the type variables mentioned in the types+ -- we have here, *and* make them all RuntimeUnk tyvars+ newTyVars us tvs = foldl' mk_new_tv GHC.emptySubst (tvs `zip` GHC.uniqsFromSupply us)+ mk_new_tv subst (tv,uniq) = GHC.extendTCvSubstWithClone subst tv new_tv+ where+ new_tv = mkRuntimeUnkTyVar (GHC.setNameUnique (GHC.tyVarName tv) uniq)+ (GHC.substTy subst (GHC.tyVarKind tv))++ isPointer id' | [rep] <- GHC.typePrimRep (idType id')+ , GHC.isGcPtrRep rep = True+ | otherwise = False++-- | Extends the InteractiveContext with the given Ids, setting up the RTTI information.+-- Assumes the Ids' Names are already known to the Loader.+addIdsToInteractiveContext :: HscEnv -> [Id] -> IO HscEnv+addIdsToInteractiveContext hsc_env final_ids = do+ let+ ictxt0 = hsc_IC hsc_env+ ictxt1 = GHC.extendInteractiveContextWithIds ictxt0 final_ids+ rttiEnvironment hsc_env{ hsc_IC = ictxt1 }++rttiEnvironment :: HscEnv -> IO HscEnv+rttiEnvironment hsc_env0@HscEnv{hsc_IC=ic0} = do+ let tmp_ids = [id' | AnId id' <- GHC.ic_tythings ic0]+ incompletelyTypedIds =+ [id' | id' <- tmp_ids+ , not $ noSkolems id'+ , (GHC.occNameFS . GHC.nameOccName . GHC.idName) id' /= result_fs]+ foldM improveTypes hsc_env0 (map GHC.idName incompletelyTypedIds)+ where+ result_fs :: GHC.FastString+ result_fs = GHC.fsLit "_result"++ noSkolems = GHC.noFreeVarsOfType . idType+ improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do+ let tmp_ids = [id' | AnId id' <- GHC.ic_tythings ic]+ let+ id' = expectJust $ L.find (\i -> GHC.idName i == name) tmp_ids+ if noSkolems id'+ then return hsc_env+ else do+ mb_new_ty <- reconstructType hsc_env 10 id'+ let old_ty = idType id'+ case mb_new_ty of+ Nothing -> return hsc_env+ Just new_ty -> do+ case GHC.improveRTTIType hsc_env old_ty new_ty of+ Nothing -> warnPprTrace True (":print failed to calculate the "+ ++ "improvement for a type")+ (vcat [ text "id" <+> ppr id'+ , text "old_ty" <+> GHC.debugPprType old_ty+ , text "new_ty" <+> GHC.debugPprType new_ty ]) $+ return hsc_env+ Just subst -> do+ let logger = hsc_logger hsc_env+ GHC.putDumpFileMaybe logger GHC.Opt_D_dump_rtti "RTTI"+ GHC.FormatText+ (fsep [text "RTTI Improvement for", ppr id', equals,+ ppr subst])++ let ic' = GHC.substInteractiveContext ic subst+ return hsc_env{hsc_IC=ic'}
haskell-debugger/GHC/Debugger/Stopped/Variables.hs view
@@ -202,7 +202,13 @@ getFamInstEnvs' :: Debugger FamInstEnvs getFamInstEnvs' = do hsc_env <- getSession- (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ tcGetFamInstEnvs+ (err_msgs, res) <- liftIO $+ runTcInteractive+#if MIN_VERSION_ghc(10,1,0)+ NoTcMPlugins+#endif+ hsc_env+ tcGetFamInstEnvs case res of Just fam_envs -> pure fam_envs Nothing -> do
haskell-debugger/GHC/Debugger/Utils.hs view
@@ -53,9 +53,10 @@ -------------------------------------------------------------------------------- -- | Convert a GHC's src span into an interface one-realSrcSpanToSourceSpan :: RealSrcSpan -> SourceSpan-realSrcSpanToSourceSpan ss = SourceSpan- { file = unpackFS $ srcSpanFile ss+-- See Note [Paths should be made absolute at the source]+realSrcSpanToSourceSpan :: AbsFilePath -> RealSrcSpan -> SourceSpan+realSrcSpanToSourceSpan prefix ss = SourceSpan+ { file = prefix /> unpackFS (srcSpanFile ss) , startLine = srcSpanStartLine ss , startCol = srcSpanStartCol ss , endLine = srcSpanEndLine ss@@ -79,11 +80,12 @@ -- -- - @hdb/Development/Debug/Adapter/Init.hs:(188,15)-(197,48)@ -- - @hdb/Development/Debug/Adapter/Proxy.hs:93:34-37@-srcSpanStringToSourceSpan :: String -> Either String SourceSpan-srcSpanStringToSourceSpan s = parseOnly pSrcSpan (T.pack s)+-- See Note [Paths should be made absolute at the source]+srcSpanStringToSourceSpan :: AbsFilePath -> String -> Either String SourceSpan+srcSpanStringToSourceSpan prefix s = parseOnly pSrcSpan (T.pack s) where pSrcSpan = do- fp <- pFile <* char ':'+ fp <- (prefix />) <$> pFile <* char ':' pParenStyle fp <|> pColonStyle fp -- file:(l1,c1)-(l2,c2)
haskell-debugger/GHC/Debugger/Utils/Orphans.hs view
@@ -20,3 +20,11 @@ [ (showModule k, VarFieldValue v) | (k, v) <- moduleEnvToList m ]++instance DebugView ModuleName where+ debugValue t = simpleValue (moduleNameString t) False+ debugFields _ = pure (VarFields [])++instance DebugView UnitId where+ debugValue t = simpleValue (unitIdString t) False+ debugFields _ = pure (VarFields [])
+ hdb-dap/Development/Debug/Adapter.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+module Development.Debug.Adapter where++import Control.Concurrent+import Control.Monad (void)+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (liftBaseDiscard)+import qualified Data.IntSet as IS+import qualified Data.Map as Map+import qualified Data.IntMap as IM+import qualified Data.Text as T++import DAP+import qualified GHC+import qualified GHC.Debugger.Interface.Messages as D (Command, Response, RemoteThreadId, VariableReference)+import GHC.Debugger.Interface.Messages (AbsFilePath, unAbs)++type DebugAdaptor = Adaptor DebugAdaptorState Request+type DebugAdaptorCont = Adaptor DebugAdaptorState ()+type DebugAdaptorX r = Adaptor DebugAdaptorState r ()++-- | Debugger state:+--+-- * Keep a mapping from DAP breakpoint ids to internal breakpoint ids+-- * Keep the MVar through which synchronous communication with the debugger is done.+-- - The debugger main worker writes to this MVar responses (and, for now, events too)+-- - The handler worker reads from this MVar and writes them to the client with the 'Adapter'.+data DebugAdaptorState = DAS+ { syncRequests :: MVar D.Command+ , syncResponses :: MVar D.Response+ , nextFreshId :: !Int+ , breakpointMap :: Map.Map GHC.InternalBreakpointId BreakpointSet+ , stackFrameMap :: IM.IntMap StackFrameIx+ , variablesMap :: IM.IntMap VariablesIx+ , entryFile :: AbsFilePath+ , entryPoint :: String+ , entryArgs :: [String]+ , projectRoot :: AbsFilePath+ , waitForDebuggee :: IO ()+ -- ^ Blocks until the debuggee is ready for @startExecution@.+ }++type BreakpointId = Int+type BreakpointSet = IS.IntSet++data StackFrameIx = StackFrameIx D.RemoteThreadId Int{-stack frame ix-}+ deriving (Eq, Ord)+data VariablesIx = VariablesIx StackFrameIx D.VariableReference++instance MonadFail DebugAdaptor where+ fail a = sendError (ErrorMessage (T.pack a)) Nothing++safeDestroyDebugSession :: Adaptor app request ()+safeDestroyDebugSession = void $ do+ -- Without forkIO we might kill ourselves first and not kill anything else.+ liftBaseDiscard forkIO $+ destroyDebugSession `catchError` \ e -> liftIO $ putStrLn ("safeDestroyDebugSession: ignoring missing session: " ++ show e)++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++-- | Transform the given file into a DAP 'Source'. The file may be modified:+--+-- * if the given filepath is absolute, it's returned unchanged+-- * if it is relative it's made absolute by prepending the current directory.+fileToSource :: AbsFilePath -> DebugAdaptor Source+fileToSource file = do+ let fullPath = unAbs file+ return defaultSource{sourcePath = Just (T.pack fullPath)}++-- | Generate fresh Int identifier.+getFreshId :: DebugAdaptor Int+getFreshId = do+ nid <- nextFreshId <$> getDebugSession+ updateDebugSession $ \s -> s { nextFreshId = nextFreshId s + 1 }+ pure nid
+ hdb-dap/Development/Debug/Adapter/Breakpoints.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, RecordWildCards, PatternSynonyms #-}+module Development.Debug.Adapter.Breakpoints where++import qualified Data.Text as T+import qualified Data.Map as Map+import qualified Data.IntSet as IS+import Text.Read+import Control.Monad+import Data.Maybe++import qualified GHC++import DAP++import GHC.Debugger.Interface.Messages hiding (Command, Response)++import Development.Debug.Adapter+import Development.Debug.Adapter.Interface++-- | BreakpointLocations command+commandBreakpointLocations :: DebugAdaptor ()+commandBreakpointLocations = do+ BreakpointLocationsArguments{..} <- getArguments+ filePath <- fileFromSourcePath breakpointLocationsArgumentsSource++ DidGetBreakpoints mspan <-+ sendSync $ GetBreakpointsAt+ ModuleBreak { path = filePath+ , lineNum = breakpointLocationsArgumentsLine+ , columnNum = breakpointLocationsArgumentsColumn+ }++ let locs = case mspan of+ Nothing -> []+ Just SourceSpan {..} ->+ [ BreakpointLocation+ { breakpointLocationLine = startLine+ , breakpointLocationColumn = Just startCol+ , breakpointLocationEndLine = Just endLine+ , breakpointLocationEndColumn = Just endCol+ }+ ]++ sendBreakpointLocationsResponse locs++-- | Execute adaptor command set module breakpoints+commandSetBreakpoints :: DebugAdaptor ()+commandSetBreakpoints = do+ SetBreakpointsArguments {..} <- getArguments+ filePath <- fileFromSourcePath setBreakpointsArgumentsSource+ let breaks_wanted = fromMaybe [] setBreakpointsArgumentsBreakpoints++ -- Clear existing module breakpoints+ DidClearBreakpoints <- sendSync (ClearModBreakpoints filePath)++ -- Set requested ones+ breaks <- forM breaks_wanted $ \bp -> do+ DidSetBreakpoint bf <-+ sendSync $ SetBreakpoint+ ModuleBreak { path = filePath+ , lineNum = DAP.sourceBreakpointLine bp+ , columnNum = DAP.sourceBreakpointColumn bp+ }+ (readMaybe @Int =<< (T.unpack <$> DAP.sourceBreakpointHitCondition bp))+ (T.unpack <$> DAP.sourceBreakpointCondition bp)+ (T.unpack <$> DAP.sourceBreakpointLogMessage bp)+ registerBreakFound bf++ sendSetBreakpointsResponse (concat breaks)++-- | Execute adaptor command set function breakpoints+commandSetFunctionBreakpoints :: DebugAdaptor ()+commandSetFunctionBreakpoints = do+ SetFunctionBreakpointsArguments{..} <- getArguments+ let+ breaks_wanted = setFunctionBreakpointsArgumentsBreakpoints++ -- Clear existing function breakpoints+ DidClearBreakpoints <- sendSync ClearFunctionBreakpoints++ -- Set requested ones+ breaks <- forM breaks_wanted $ \bp -> do+ DidSetBreakpoint bf <-+ sendSync $ SetBreakpoint+ FunctionBreak { function = T.unpack $ DAP.functionBreakpointName bp }+ (readMaybe @Int =<< (T.unpack <$> DAP.functionBreakpointHitCondition bp))+ (T.unpack <$> DAP.functionBreakpointCondition bp)+ Nothing+ registerBreakFound bf++ sendSetFunctionBreakpointsResponse (concat breaks)++-- | Execute adaptor command set exception breakpoints+commandSetExceptionBreakpoints :: DebugAdaptor ()+commandSetExceptionBreakpoints = do+ SetExceptionBreakpointsArguments{..} <- getArguments++ -- Clear old exception breakpoints+ DidRemoveBreakpoint _ <- sendSync (DelBreakpoint OnExceptionsBreak)+ DidRemoveBreakpoint _ <- sendSync (DelBreakpoint OnUncaughtExceptionsBreak)++ let breakOnExceptions = BREAK_ON_EXCEPTION `elem` setExceptionBreakpointsArgumentsFilters+ let breakOnError = BREAK_ON_ERROR `elem` setExceptionBreakpointsArgumentsFilters++ when breakOnExceptions $ do+ DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak Nothing Nothing Nothing)+ pure ()++ when breakOnError $ do+ DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak Nothing Nothing Nothing)+ pure ()++ sendSetExceptionBreakpointsResponse+ [ defaultBreakpoint | True <- [breakOnError, breakOnExceptions] ]++--------------------------------------------------------------------------------+-- * Aux+--------------------------------------------------------------------------------++pattern BREAK_ON_EXCEPTION, BREAK_ON_ERROR :: T.Text+pattern BREAK_ON_EXCEPTION = "break-on-exception"+pattern BREAK_ON_ERROR = "break-on-error"++-- | Turn a haskell-debugger 'BreakFound' into a DAP 'Breakpoint'.+--+-- Additionally, gets a fresh Id for the breakpoint and registers it on the breakpoint map+registerBreakFound :: BreakFound -> DebugAdaptor [DAP.Breakpoint]+registerBreakFound b =+ case b of+ ManyBreaksFound bs -> concat <$> mapM registerBreakFound bs+ BreakNotFound -> pure [ DAP.defaultBreakpoint { DAP.breakpointVerified = False } ]+ BreakFoundNoLoc _ch -> pure [ DAP.defaultBreakpoint { DAP.breakpointVerified = True } ]+ BreakFound _ch iid ss -> do+ source <- fileToSource ss.file+ bids <- mapM registerNewBreakpoint iid+ pure $ map (\bid -> DAP.defaultBreakpoint+ { DAP.breakpointVerified = True+ , DAP.breakpointSource = Just source+ , DAP.breakpointLine = Just ss.startLine+ , DAP.breakpointEndLine = Just ss.endLine+ , DAP.breakpointColumn = Just ss.startCol+ , DAP.breakpointEndColumn = Just ss.endCol+ , DAP.breakpointId = Just bid+ }) bids++-- | Adds new BreakpointId to the debug adapter mapping+registerNewBreakpoint :: GHC.InternalBreakpointId -> DebugAdaptor BreakpointId+registerNewBreakpoint breakpoint = do+ bkpId <- getFreshId+ updateDebugSession $ \das@DAS{..} -> das {breakpointMap = Map.insertWith mappend breakpoint (IS.singleton bkpId) breakpointMap}+ pure bkpId++-- | Get the file from a DAP Source+--+-- TODO: Handles sourceReferences too+fileFromSourcePath :: Source -> DebugAdaptor AbsFilePath+fileFromSourcePath source = do+ prjRoot <- projectRoot <$> getDebugSession+ let+ file = T.unpack $+ fromMaybe (error "sourceReference unsupported") $+ sourcePath source+ return $ prjRoot /> file
+ hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NondecreasingIndentation #-}++-- | TODO: This module should be called Launch.+module Development.Debug.Adapter.DAPDebuggee where++#if !MIN_VERSION_ghc(9,15,0)+-- no longer needs to be imported from here in 9.15+import GHC.Conc.Sync (labelThread)+#endif++import GHC.IO.Handle+import GHC.Stack.Annotation (annotateStackStringIO)+import System.Process+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as T+import Control.Monad.Trans+import System.IO+import Control.Monad.Catch+import Control.Exception (throwIO, IOException)+import Control.Concurrent+import Control.Concurrent.Async (concurrently_)+import Control.Monad+import Data.Functor.Contravariant++import Development.Debug.Adapter+import Colog.Core as Logger+import qualified Development.Debug.Adapter.Output as Output+++import DAP+import Development.Debug.Adapter.Handles+import Development.Debug.Session.Setup+import Development.Debug.Adapter.Proxy+import Network.Socket (socketPort, close)+import GHC.Debugger.Debuggee as Debugger+import GHC.Debugger.Utils (forwardHandleToLogger)++data DAPDebuggee = DAPDebuggee+ { dapdInterpreterSettings :: InterpreterSettings+ , dapdWaitForDebuggee :: IO ()+ , dapdThreads :: [(DebugAdaptorCont () -> IO ()) -> IO ()]+ -- ^ Additional threads to register for this session depending on the process+ -- we're running through `runInTerminal` (see 'interpreterInit').+ , dapdAfterRegister :: DebugAdaptor ()+ -- ^ additional commands to run after registering the session.+ }+++internalNoInTerminalDAPD :: Applicative f => f DAPDebuggee+internalNoInTerminalDAPD+ -- Not using the terminal proxy, but we still want to output our own+ -- stdout/err (from the internal interpreter) as console events.+ = do+ let interpSettings = InterpreterSettings+ { interpreterFlags = mkInternalInterpreterFlags+ , interpreterSetup = mkInternalInterpreterSetup+ }+ pure $+ DAPDebuggee+ interpSettings+ (pure ())+ [ stdoutCaptureThread Nothing, stderrCaptureThread Nothing ]+ (pure ())++externalNoInTerminalDAPD :: MonadIO f => FilePath -> f DAPDebuggee+externalNoInTerminalDAPD hdbProg = do+ iserv_handles <- liftIO newEmptyMVar+ let interpSettings = InterpreterSettings+ { interpreterFlags = mkExternalInterpreterFlags hdbProg+ , interpreterSetup = mkExternalInterpreterSubProcessSetup CreatePipe CreatePipe CreatePipe (putMVar iserv_handles)+ }+ pure $+ DAPDebuggee+ interpSettings+ (pure ())+ [\ withAdaptor -> fwdThread iserv_handles (LogAction $ withAdaptor . Output.stdout) (LogAction $ withAdaptor . Output.stderr)+ ]+ (pure ())+ where+ fwdThread iserv_handles logOut logErr = annotateStackStringIO "External interpreter forwarding parent thread" $ do+ (_, Just serv_out, Just serv_err, _) <- takeMVar iserv_handles+ concurrently_+ (annotateStackStringIO "External interpreter stderr forwarding" $ forwardHandleToLogger serv_err logErr)+ (annotateStackStringIO "External interpreter stdout forwarding" $ forwardHandleToLogger serv_out logOut)++externalInTerminalDAPD :: MonadIO m => FilePath -> m DAPDebuggee+externalInTerminalDAPD hdbProg+ -- No additional bookkeeping is needed in this case because GHC will+ -- naturally have to wait for the external interpreter in order to start execution+ = liftIO $ do+ -- We keep the socket open so we claim the port.+ bracketOnError openSocketAvailablePort Network.Socket.close $ \ sock -> do+ let+ interpSettings = InterpreterSettings+ { interpreterFlags = mkExternalInterpreterFlags hdbProg+ , interpreterSetup = mkExternalInterpreterFromIOSetup+ $ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process"+ $ extInterpFromListeningSocket sock+ }+ extInterpPort <- liftIO $ socketPort sock+ pure $+ DAPDebuggee+ interpSettings+ (pure ())+ -- When session is killed the socket is closed too.+ [\ _ -> forever (threadDelay 100_000_000) `finally` Network.Socket.close sock]+ (sendRunInTerminalReverseRequest+ RunInTerminalRequestArguments+ { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated+ , runInTerminalRequestArgumentsTitle = Nothing+ , runInTerminalRequestArgumentsCwd = ""+ , runInTerminalRequestArgumentsArgs =+ [T.pack hdbProg, "external-interpreter", "--port", T.pack (show extInterpPort)]+ , runInTerminalRequestArgumentsEnv = Nothing+ , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False+ })++internalInTerminalDAPD :: LogAction IO DAPSessionLog -> FilePath -> Adaptor DebugAdaptorState r DAPDebuggee+internalInTerminalDAPD l hdbProg = do+ (syncProxyIn, syncProxyOut, syncProxyErr)+ <- liftIO $ (,,) <$> newChan <*> newChan <*> newChan+ proxyClientReady <- liftIO $ newEmptyMVar++ (serverPort, serverProxyThread) <- liftIO $+ mkServerSideHdbProxy (contramap RunProxyServerLog l)+ syncProxyIn syncProxyOut syncProxyErr proxyClientReady+ let interpSettings = InterpreterSettings+ { interpreterFlags = mkInternalInterpreterFlags+ , interpreterSetup = mkInternalInterpreterSetup+ }+ waitForDebuggee =+ -- Only start executing after proxy client connects succesfully (#95)+ takeMVar proxyClientReady+ pure $ DAPDebuggee+ interpSettings+ waitForDebuggee+ [ const serverProxyThread+ -- Setup capturing of the process' own stdout and forwarding of the process' own stdin,+ -- but only because we're using the internal interpreter!+ , stdinForwardThread syncProxyIn+ , stdoutCaptureThread (Just syncProxyOut)+ , stderrCaptureThread (Just syncProxyErr)+ ]++ -- When using the internal interpreter and 'runInTerminal' is supported+ -- (the 'RunProxyInTerminal' case), we ask the DAP client to launch the+ -- `hdb proxy` attached to the user's terminal. The proxy forwards+ -- input/output from the user terminal to the debugger+debuggee shared process+ (sendRunProxyInTerminal hdbProg serverPort)++--------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------+type SessionId = T.Text+data DAPSessionLog+ = DAPSessionSetupLog (WithSeverity SessionSetupLog)+ | DAPDebuggerLog Debugger.DebuggerLog+ | RunProxyServerLog (WithSeverity T.Text)+++--------------------------------------------------------------------------------+-- * Capturing stdout, stderr, and writing to self stdin+--------------------------------------------------------------------------------++-- | Hijack the current process stdin and forward to it the messages from the given channel+stdinForwardThread :: Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()+stdinForwardThread syncIn _withAdaptor = do+ tid <- myThreadId+ labelThread tid "Stdin Forward Thread"++ -- We need to hijack stdin to write to it++ -- 1. Create a new pipe from writeEnd->readEnd+ (readEnd, writeEnd) <- createPipe++ -- 2. Substitute the read-end of the pipe by stdin+ _ <- hDuplicateTo readEnd stdin+ hClose readEnd -- we'll never need to read from readEnd++ forever $ do+ i <- readChan syncIn+ -- 3. Write to write-end of the pipe+ BS.hPut writeEnd i >> hFlush writeEnd++-- | This thread captures stdout from the debuggee and sends it to the client.+-- NOTE, redirecting the stdout handle is a process-global operation. So this thread+-- will capture ANY stdout the debuggee emits. Therefore you should never directly+-- write to stdout, but always write to the appropiate handle.+stdoutCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO ()+stdoutCaptureThread msyncOut withAdaptor = do+ tid <- myThreadId+ labelThread tid "Stdout Capture Thread"+ withInterceptedStdout $ \_ interceptedStdout -> do+ forever $ do+ line <- liftIO $ T.hGetLine interceptedStdout+ case msyncOut of+ Nothing -> pure ()+ Just syncOut -> writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n")++ -- Always output to Debug Console+ catch+ (withAdaptor $ Output.stdout line)+ (\(_ :: IOException) ->+ throwIO (FailedToWriteToAdaptor line))++-- | Like 'stdoutCaptureThread' but for stderr+stderrCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO ()+stderrCaptureThread msyncErr withAdaptor = do+ tid <- myThreadId+ labelThread tid "Stderr Capture Thread"+ withInterceptedStderr $ \_ interceptedStderr -> do+ forever $ do+ line <- liftIO $ T.hGetLine interceptedStderr+ case msyncErr of+ Nothing -> pure ()+ Just syncErr -> writeChan syncErr $ T.encodeUtf8 (line <> "\n")++ -- Always output to Debug Console+ catch+ (withAdaptor $ Output.stderr line)+ (\(_ :: IOException) ->+ 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
+ hdb-dap/Development/Debug/Adapter/Evaluation.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE RecordWildCards, OverloadedRecordDot, DuplicateRecordFields #-}+module Development.Debug.Adapter.Evaluation where++import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.IntSet as IS+import qualified Data.IntMap as IM++import DAP++import GHC.Debugger.Interface.Messages+import Development.Debug.Adapter+import Development.Debug.Adapter.Interface+import qualified Development.Debug.Adapter.Output as Output++--------------------------------------------------------------------------------+-- * Executing debuggee+--------------------------------------------------------------------------------++-- | Start executing from entry point+--+-- TODO:+-- [ ] Consider using Output events for debuggee evaluation.+startExecution :: DebugAdaptor EvalResult+startExecution = do+ DAS{entryFile, entryPoint, entryArgs} <- getDebugSession+ let entry+ | entryPoint == "main" = MainEntry Nothing+ | otherwise = FunctionEntry entryPoint+ DidExec er <- sendSync DebugExecution{entryPoint = entry, entryFile, runArgs = entryArgs}+ return er++--------------------------------------------------------------------------------+-- * Eval+--------------------------------------------------------------------------------++-- | Command for evaluation (includes evaluation-on-hover)+commandEvaluate :: DebugAdaptor ()+commandEvaluate = do+ EvaluateArguments {evaluateArgumentsFrameId=_todo{-evaluate expression in specific frame-}, ..} <- getArguments++ let simpleEvalResp res ty = EvaluateResponse+ { evaluateResponseResult = res+ , evaluateResponseType = ty+ , evaluateResponsePresentationHint = Nothing+ , evaluateResponseVariablesReference = 0+ , evaluateResponseNamedVariables = Nothing+ , evaluateResponseIndexedVariables = Nothing+ , evaluateResponseMemoryReference = Nothing+ }++ DidEval er <- sendSync (DoEval (T.unpack evaluateArgumentsExpression))+ case er of+ EvalStopped{} -> error "impossible, execution is resumed automatically for 'DoEval'"+ EvalAbortedWith e ->+ -- Evaluation failed, we report it but don't terminate.+ sendEvaluateResponse (simpleEvalResp (T.pack e) (T.pack ""))+ EvalException {resultVal, resultType} ->+ sendEvaluateResponse (simpleEvalResp (T.pack resultVal) (T.pack resultType))+ EvalCompleted{resultVal, resultType, resultSourceKind, resultStructureRef} -> do+ varIx <- case resultStructureRef of+ NoVariables -> pure 0+ LocalVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"+ ModuleVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"+ GlobalVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"+ SpecificVariable _ -> do+ varId <- getFreshId+ updateDebugSession $ \s ->+ s { variablesMap =+ IM.insert varId+ (VariablesIx (StackFrameIx (RemoteThreadId (-1)) (-1) {- shouldn't be a problem bc it's not Local/Module/Global vars -}) resultStructureRef)+ s.variablesMap+ }+ pure varId++ let orIfNoResult !x !y+ | Just IsStmt <- resultSourceKind = y+ | resultType == "()" = y+ | otherwise = x++ sendEvaluateResponse EvaluateResponse+ { evaluateResponseResult = T.pack resultVal `orIfNoResult` T.empty+ , evaluateResponseType = T.pack resultType `orIfNoResult` T.empty+ , evaluateResponsePresentationHint = Nothing+ , evaluateResponseVariablesReference = varIx `orIfNoResult` 0+ , evaluateResponseNamedVariables = Nothing+ , evaluateResponseIndexedVariables = Nothing+ , evaluateResponseMemoryReference = Nothing+ }++--------------------------------------------------------------------------------+-- * Utils+--------------------------------------------------------------------------------++-- | Handle an EvalResult by sending a stopped or exited event.+--+-- In particular, the result of evaluation is ignored by this function.+-- The 'EvaluateRequest' handler inspects the EvalResult itself and reports on the result.+handleEvalResult :: Bool {-^ Whether we are "stepping" -} -> EvalResult -> DebugAdaptor ()+handleEvalResult stepping er = case er of+ EvalAbortedWith e -> do+ Output.console (T.pack e)+ sendTerminatedEvent defaultTerminatedEvent+ sendExitedEvent (ExitedEvent 43)+ EvalCompleted{resultVal, resultType} -> do+ Output.console (T.pack $ "Evaluation returned: " ++ resultVal ++ " :: " ++ resultType)+ sendTerminatedEvent defaultTerminatedEvent+ sendExitedEvent (ExitedEvent 0)+ EvalException{resultVal, resultType} -> do+ Output.stderr (T.pack $ "Uncaught exception of type " ++ resultType ++ " was thrown!")+ Output.stderr (T.pack resultVal)+ sendTerminatedEvent defaultTerminatedEvent+ sendExitedEvent (ExitedEvent 42)+ EvalStopped {breakId = Nothing, breakThread} ->+ sendStoppedEvent+ defaultStoppedEvent {+ stoppedEventAllThreadsStopped = True+ , stoppedEventReason = StoppedEventReasonException+ , stoppedEventHitBreakpointIds = []+ , stoppedEventThreadId = Just $ remoteThreadIntRef breakThread+ }+ EvalStopped {breakId = Just bid, breakThread} -> do+ DAS{breakpointMap} <- getDebugSession+ sendStoppedEvent+ defaultStoppedEvent {+ stoppedEventAllThreadsStopped = True+ -- could be more precise here by saying "function breakpoint" rather than always "breakpoint"+ , stoppedEventReason+ = if stepping then StoppedEventReasonStep+ else StoppedEventReasonBreakpoint+ , stoppedEventHitBreakpointIds+ = maybe [] IS.toList (M.lookup bid breakpointMap)+ , stoppedEventThreadId = Just $ remoteThreadIntRef breakThread+ }
+ hdb-dap/Development/Debug/Adapter/ExceptionInfo.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Development.Debug.Adapter.ExceptionInfo+ ( commandExceptionInfo+ ) where++import qualified Data.Text as T++import DAP++import Development.Debug.Adapter+import Development.Debug.Adapter.Interface+import qualified GHC.Debugger.Interface.Messages as D++commandExceptionInfo :: DebugAdaptor ()+commandExceptionInfo = do+ ExceptionInfoArguments{..} <- getArguments+ let remoteThread = D.RemoteThreadId exceptionInfoArgumentsThreadId+ D.GotExceptionInfo info <- sendSync (D.GetExceptionInfo remoteThread)+ sendExceptionInfoResponse (toDAPExceptionInfo info)++-- | Convert the debugger's 'ExceptionInfo' into a DAP 'ExceptionInfoResponse'.+toDAPExceptionInfo :: D.ExceptionInfo -> ExceptionInfoResponse+toDAPExceptionInfo info =+ let typeNameStr = exceptionTypeName info+ typeNameText = T.pack typeNameStr+ messageStr = exceptionMessage info+ messageText = T.pack <$> messageStr+ in ExceptionInfoResponse+ { exceptionInfoResponseExceptionId = typeNameText+ , exceptionInfoResponseDescription = messageText+ , exceptionInfoResponseBreakMode = Always+ , exceptionInfoResponseDetails = Just (exceptionInfoToDetails (Just "_exception") info)+ }++exceptionInfoToDetails :: Maybe T.Text -> D.ExceptionInfo -> ExceptionDetails+exceptionInfoToDetails evalName info@D.ExceptionInfo{..} =+ let typeNameText = T.pack (exceptionTypeName info)+ fullTypeNameText = T.pack (exceptionFullTypeName info)+ stackTraceText = T.pack <$> exceptionInfoContext+ innerDetails = map (exceptionInfoToDetails Nothing) exceptionInfoInner+ innerField = if null innerDetails then Nothing else Just innerDetails+ in defaultExceptionDetails+ { exceptionDetailsMessage = exceptionMessage info+ , exceptionDetailstypeName = Just typeNameText+ , exceptionDetailsFullTypeName = Just fullTypeNameText+ , exceptionDetailsStackTrace = stackTraceText+ , exceptionDetailsInnerException = innerField+ , exceptionDetailsEvaluateName = evalName+ }++exceptionTypeName :: D.ExceptionInfo -> String+exceptionTypeName D.ExceptionInfo{..}+ | null exceptionInfoTypeName = "Exception"+ | otherwise = exceptionInfoTypeName++exceptionFullTypeName :: D.ExceptionInfo -> String+exceptionFullTypeName info@D.ExceptionInfo{..}+ | null exceptionInfoFullTypeName = exceptionTypeName info+ | otherwise = exceptionInfoFullTypeName++exceptionMessage :: D.ExceptionInfo -> Maybe String+exceptionMessage D.ExceptionInfo{..}+ | null exceptionInfoMessage = Nothing+ | otherwise = Just exceptionInfoMessage
+ hdb-dap/Development/Debug/Adapter/Exit.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE LambdaCase #-}++-- | Module concerning with reporting failures and exiting cleanly the+-- debugging process. An overview of covered exit modes:+--+-- == 1. The top-level DebugAdaptor process+-- * Command Terminate+-- * Command Disconnect+-- * DebugAdaptor crashes while executing (handled by DAP library?)+-- * One of the threads launched by registerNewDebugSession crash+--+-- == 2. The haskell-debugger process+-- * The debugger crashes while initializing (e.g. while compiling or when discovering flags)+-- * The debugger crashes while executing a request+--+-- == 3. The debuggee loaded in haskell-debugger and runs+-- * The debuggee terminates successfully+-- * The debuggee terminates with an exception+-- * The debuggee crashes in another way+--+-- Notes:+-- * @'destroyDebugSession'@ kills all threads started for this session with @'registerNewDebugSession'@.+module Development.Debug.Adapter.Exit where++import DAP+import Development.Debug.Adapter++-- | Command terminate (1a)+--+-- Terminate the *debuggee* gracefully+commandTerminate :: DebugAdaptor ()+commandTerminate = do+ destroyDebugSession -- kills debugger GHC session (which handles stopping the debuggee ext-interp too)+ sendTerminateResponse+ sendTerminatedEvent (TerminatedEvent False) -- we're done debugging now!++-- | Command disconnect (1b)+--+-- Terminate the debuggee (and any child processes) forcefully.+commandDisconnect :: DebugAdaptor ()+commandDisconnect = do+ -- kills debugger GHC session (which handles stopping the debuggee ext-interp too)+ -- ignore error if session has already been destroyed (e.g. client sends disconnect after terminate)+ safeDestroyDebugSession+ sendDisconnectResponse
+ hdb-dap/Development/Debug/Adapter/Exit/Helpers.hs view
@@ -0,0 +1,47 @@+module Development.Debug.Adapter.Exit.Helpers where++import DAP+import Data.Function+import System.IO+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Development.Debug.Adapter+import qualified Development.Debug.Adapter.Output as Output++--- Exit Cleanly ---------------------------------------------------------------++-- | Outputs a message notification ('Output.important'), sends a terminated+-- event, destroys the debug session, and dies.+--+-- ::WARNING::+--+-- This function should not be called if the debugsession with the debugger+-- threads haven't yet been registered because it WILL block on the call to+-- @'destroyDebugSession'@.+exitCleanupWithMsg+ :: Handle+ -- ^ Handle to finalize reading as OutputEvents before exiting (but after+ -- killing the output thread with @destroyDebugSession@)+ -> String+ -- ^ Error message, logged with notification+ -> DebugAdaptor ()+exitCleanupWithMsg final_handle msg = do+ 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+ terminateWithError msg++-- | Abruptly terminate a session in the middle of a Request/Response cycle by+-- sending a Terminated event (meaning the debug session is over), destroying+-- the debug session threads, and replying to the response with 'ErrorResponse'+terminateWithError :: String -> DebugAdaptor ()+terminateWithError msg = do+ Output.important (T.pack msg)+ destroyDebugSession+ sendTerminatedEvent (TerminatedEvent False)+ sendError (ErrorMessage (T.pack msg)) Nothing
+ hdb-dap/Development/Debug/Adapter/Handles.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, CPP, DeriveAnyClass, DeriveGeneric, DerivingVia, LambdaCase, RecordWildCards #-}+module Development.Debug.Adapter.Handles+ ( handleLogger+ , withInterceptedStdout+ , withInterceptedStderr+ , withInterceptedStdoutForwarding+ , withInterceptedStderrForwarding+ ) where++import DAP++import System.IO ()+import DAP.Log+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Control.Concurrent.MVar+import GHC.IO.Handle.FD+import GHC.IO.Handle+import System.Process+import Control.Exception+import Control.Concurrent.Async++handleLogger :: Handle -> IO (LogAction IO T.Text)+handleLogger out_handle = do+ handleLock <- newMVar ()+ return $ LogAction $ \msg -> do+ withLock handleLock $ do+ T.hPutStrLn out_handle msg++-- | Redirect stdout globally, run the continuation with a bypass handle for real stdout.+withInterceptedStdout :: (Handle -- ^ realStdout, write to this handle sends output to stdout+ -> Handle -- ^ interceptedStdout, stdout captured from attempting to write to stdout handle.+ -> IO ()) -> IO ()+withInterceptedStdout k = do+ withPipe $ \readOutHandle writeOutHandle -> do+ hSetBuffering readOutHandle NoBuffering+ hSetBuffering writeOutHandle LineBuffering+ withStdoutBypass writeOutHandle $ \realStdout -> do+ k realStdout readOutHandle++-- | Redirect stderr globally, run the continuation with a bypass handle for real stderr.+withInterceptedStderr :: (Handle -- ^ realStderr, write to this handle sends output to stderr+ -> Handle -- ^ interceptedStderr, stdout captured from attempting to write to stderr handle.+ -> IO ()) -> IO ()+withInterceptedStderr k = do+ withPipe $ \readErrHandle writeErrHandle -> do+ hSetBuffering readErrHandle NoBuffering+ hSetBuffering writeErrHandle LineBuffering+ withStderrBypass writeErrHandle $ \realStderr -> do+ k realStderr readErrHandle++-- | Intercept stderr, and spawn a thread which forwards the input+-- onwards using the supplied IO action.+withInterceptedStderrForwarding :: (T.Text -> IO ())+ -- ^ All stderr input that is intercepted is forwarded to this thread+ -> (Handle -> IO ())+ -- ^ The continuation receives the REAL STDERR+ -> IO ()+withInterceptedStderrForwarding write_stderr k = do+ withInterceptedStderr $ \realStderr interceptedStderr -> do+ withAsync (forwardingThread write_stderr interceptedStderr) $ \_ -> do+ k realStderr++-- | Intercept stdout, and spawn a thread which forwards the input+-- onwards using the supplied IO action.+withInterceptedStdoutForwarding :: (T.Text -> IO ())+ -- ^ All stdout input that is intercepted is forwarded to this thread+ -> (Handle -> IO ())+ -- ^ The continuation receives the REAL STDOUT+ -> IO ()+withInterceptedStdoutForwarding write_stdout k = do+ withInterceptedStdout $ \realStdout interceptedStdout -> do+ withAsync (forwardingThread write_stdout interceptedStdout) $ \_ ->+ k realStdout++--------------------------------------------------------------------------------+-- Auxiliary+--------------------------------------------------------------------------------++-- | Temporarily bypass the intercepted stdout/stderr to write directly to the original stdout/stderr.+-- This is useful for debugging or for sending output that should not be intercepted.+withStdoutBypass, withStderrBypass+ :: Handle+ -> (Handle -> IO r)+ -> IO r+withStdoutBypass interceptH = withHandleBypass stdout interceptH+withStderrBypass interceptH = withHandleBypass stderr interceptH++-- | Capture all output written to a given handle and redirect it to the other+-- one; the continuation can use the "real" copy of the first handle to write+-- to it while bypassing the redirection.+--+-- This is useful for debugging or for sending output that should not be intercepted.+withHandleBypass :: Handle+ -- ^ Text written to this handle...+ -> Handle+ -- ^ ...will be redirected to this handle+ -> (Handle -> IO r)+ -- ^ Continuation receives as an argument a "real" copy of the handle that is now being redirected.+ -- If you write to this Handle, it will write to the original one and *bypass* the redirection (ie it will not be redirected)+ -> IO r+withHandleBypass originalHandle interceptWriteHandle action =+ bracket setup clean action+ where+ setup = do+ realHandle <- hDuplicate originalHandle+ hFlush originalHandle+ hDuplicateTo interceptWriteHandle originalHandle+ hSetBuffering originalHandle LineBuffering+ return realHandle++ clean realHandle = do+ hFlush originalHandle+ hDuplicateTo realHandle originalHandle+ hClose realHandle++-- | Thread to read from the intercepted stdout pipe and forward onwards+forwardingThread :: (T.Text -> IO ()) -> Handle -> IO ()+forwardingThread write_action fromPipe = loop+ where+ loop = do+ eof <- hIsEOF fromPipe+ if eof+ then return ()+ else do+ line <- T.hGetLine fromPipe+ write_action line+ loop++withPipe :: (Handle -> Handle -> IO r) -> IO r+withPipe action = bracket createPipe closeBoth (uncurry action)+ where+ closeBoth (readH, writeH) = do+ hClose readH+ hClose writeH+
+ hdb-dap/Development/Debug/Adapter/Init.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NondecreasingIndentation #-}++-- | TODO: This module should be called Launch.+module Development.Debug.Adapter.Init+ ( module Development.Debug.Adapter.Init+ , DAPSessionLog(..)+ )+ where++#if !MIN_VERSION_ghc(9,15,0)+-- no longer needs to be imported from here in 9.15+import GHC.Conc.Sync (labelThread)+#endif++import GHC.IO.Handle+import qualified Data.Text as T+import qualified System.Process as P+import Control.Exception (displayExceptionWithInfo, ExceptionWithContext (ExceptionWithContext), AsyncException (..))+import Control.Monad (when)+import Control.Monad.Except+import Control.Monad.Trans+import Data.Function+import Data.Maybe+import Data.UUID.V4 qualified as UUID+import System.IO+import GHC.IO.Encoding+import Control.Monad.Catch+import Control.Concurrent+import Data.Aeson as Aeson+import GHC.Generics+import System.Directory+import Data.Functor.Contravariant++import Development.Debug.Adapter+import Colog.Core as Logger+import qualified Development.Debug.Adapter.Output as Output++import GHC (Ghc)+import GHC.Utils.Logger (defaultLogActionWithHandles)+import GHC.Debugger.Utils (forwardHandleToLogger, IsLine (text))+import qualified GHC.Debugger as Debugger+import qualified GHC.Debugger.Monad as Debugger+import qualified GHC.Debugger.Interface.Messages as D (Command, Response)+import GHC.Debugger.Interface.Messages hiding (Command, Response)++import DAP+import Development.Debug.Adapter.Handles+import Development.Debug.Session.Setup+import GHC.Debugger.Debuggee as Debugger+import Development.Debug.Adapter.DAPDebuggee++--------------------------------------------------------------------------------+-- * Client+--------------------------------------------------------------------------------++-- | Client arguments are custom for launch+data LaunchArgs+ = LaunchArgs+ { __sessionId :: Maybe String+ -- ^ SessionID, set by VSCode client+ , projectRoot :: Maybe FilePath+ -- ^ Absolute path to the project root+ , entryFile :: Maybe FilePath+ -- ^ The file with the entry point e.g. @app/Main.hs@+ , entryPoint :: Maybe String+ -- ^ Either @main@ or a function name+ , entryArgs :: Maybe [String]+ -- ^ The arguments to either set as environment arguments when @entryPoint = "main"@+ -- or function arguments otherwise.+ , extraGhcArgs :: Maybe [String]+ -- ^ Additional arguments to pass to the GHC invocation inferred by hie-bios for this project+ , cradleFile :: Maybe FilePath+ -- ^ specify cradle file rather than let it be inferred from @entryFile@, relative to @projectRoot@.+ } deriving stock (Show, Eq, Generic)+ deriving anyclass FromJSON++--------------------------------------------------------------------------------+-- * Launch Debugger+--------------------------------------------------------------------------------++data DAPServerConf = DAPServerConf+ { hdbProgram :: FilePath+ -- ^ invoked with `external-interpreter` to serve as the external interpreter+ , getDebugRunner :: DebugRunnerProvider ()+ , dapServerConfig :: ServerConfig+ }++data InterpreterChoice = InterpreterChoice { runInTerminal :: Bool, internal :: Bool }+++-- | Initialize debugger+--+-- Returns @()@ if successful, throws @InitFailed@ otherwise+initDebugger :: LogAction IO (T.Text,DAPSessionLog) -> DAPServerConf -> InterpreterChoice+ -> LaunchArgs -> DebugAdaptor ()+initDebugger l0 servConf interpChoice+ LaunchArgs{ __sessionId+ , projectRoot = givenRoot+ , entryFile = entryFileMaybe+ , entryPoint = fromMaybe "main" -> entryPoint+ , entryArgs = fromMaybe [] -> entryArgs+ , extraGhcArgs = fromMaybe [] -> extraGhcArgs+ , cradleFile+ } = do+ syncRequests <- liftIO newEmptyMVar+ syncResponses <- liftIO newEmptyMVar++ entryFile <- case entryFileMaybe of+ Nothing -> throwError ("Missing \"entryFile\" key in debugger configuration", Nothing)+ Just ef -> pure ef++ projectRoot <- liftIO $ mkAbsolute <$> maybe getCurrentDirectory makeAbsolute givenRoot++ sessionId <- liftIO $ maybe (T.show <$> UUID.nextRandom) (pure . T.pack) __sessionId+ let l = contramap (sessionId,) l0++ -- Create a pipe to which messages to send to the DAP console are written and read.+ -- todo: This could just be a Haskell channel now...+ (readDAPOutput, writeDAPOutput) <- liftIO P.createPipe+ liftIO $ do+ hSetBuffering readDAPOutput LineBuffering+ hSetBuffering writeDAPOutput NoBuffering+ -- GHC output uses utf8+ hSetEncoding readDAPOutput utf8+ hSetEncoding writeDAPOutput utf8+ setLocaleEncoding utf8++ dapLogger <- liftIO $ handleLogger writeDAPOutput++ let hieBiosLogger = contramap DAPSessionSetupLog l <> logHieBiosToDAP++ logHieBiosToDAP = LogAction $ \case+ WithSeverity msg sev+ | sev >= Info -> dapLogger <& renderSessionSetupLog msg+ | otherwise -> mempty++ let debugRunnerConf = DebugRunnerConf (unAbs projectRoot) entryFile extraGhcArgs cradleFile++ liftIO (getDebugRunner servConf hieBiosLogger debugRunnerConf) >>= \case+ Left e -> throwError (ErrorMessage (T.pack e), Nothing)+ Right (ghcInvocation, debugRunner) -> do++ let+ nextFreshId = 0+ breakpointMap = mempty+ stackFrameMap = mempty+ variablesMap = mempty++ dbgLog <- liftIO $ createDebuggerLogger l dapLogger writeDAPOutput++ dapd <- initDAPDebuggee l (hdbProgram servConf) interpChoice++ let+ defaultRunConf = Debugger.RunDebuggerSettings+ { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap+ , supportsANSIHyperlinks = False -- VSCode does not support this+ , interpreterSettings = dapdInterpreterSettings dapd+ }+ absEntryFile = projectRoot /> entryFile+ daState = DAS{entryFile=absEntryFile,waitForDebuggee = dapdWaitForDebuggee dapd,..}++ registerNewDebugSession sessionId daState $ map (destroyDebugSessionOnException l) $+ [ \withAdaptor -> do+ -- The info here is already taken into account in debugRunner.+ let GhcInvocation libdir units args = ghcInvocation+ withAdaptor $+ Output.console $ T.pack $ unlines $+ [ "libdir: " <> libdir+ , "units: " <> unwords units+ , "args: " <> unwords args+ ]+ debuggerThread dbgLog debugRunner defaultRunConf syncRequests syncResponses+ , \withAdaptor -> forwardHandleToLogger readDAPOutput $+ LogAction (\msg -> withAdaptor (Output.neutral msg))+ ]+ +++ dapdThreads dapd++ dapdAfterRegister dapd++destroyDebugSessionOnException :: LogAction IO DAPSessionLog+ -> ((Adaptor a r () -> IO ()) -> IO ())+ -> (Adaptor a r () -> IO ())+ -> IO ()+destroyDebugSessionOnException l k withAdaptor = do+ k withAdaptor+ `catchNoPropagate` \ x@(ExceptionWithContext _ctx e) -> do+ l <& DAPDebuggerLog (DebuggerSessionLog Debug $ (T.pack $ displayExceptionWithInfo (toException x)))+ case fromException e of+ -- TODO: would be better if destroyDebugSession from dap sent a custom exception, so we are sure we don't have to propagate it to the other threads.+ Just ThreadKilled -> return ()+ _ -> do+ withAdaptor $ do+ sendTerminatedEvent (TerminatedEvent False)+ safeDestroyDebugSession++initDAPDebuggee+ :: LogAction IO DAPSessionLog+ -> FilePath+ -> InterpreterChoice+ -> DebugAdaptor DAPDebuggee+initDAPDebuggee _ _ InterpreterChoice{runInTerminal = False, internal = True}+ = internalNoInTerminalDAPD+initDAPDebuggee _ hdbProg InterpreterChoice{runInTerminal = False, internal = False}+ = externalNoInTerminalDAPD hdbProg+initDAPDebuggee _ hdbProg InterpreterChoice{internal = False, runInTerminal = True}+ = externalInTerminalDAPD hdbProg+initDAPDebuggee l hdbProg InterpreterChoice{runInTerminal = True, internal = True}+ = internalInTerminalDAPD l hdbProg+++-- | The main debugger thread launches a GHC.Debugger session.+--+-- Then, forever:+-- 1. Reads commands from the given 'D.Command' 'MVar'+-- 2. Executes the command with `execute`+-- 3. Writes responses to the given 'D.Response' 'MVar'+--+-- Concurrently, it reads from the process's stderr forever and outputs it through OutputEvents.+--+debuggerThread :: LogAction IO Debugger.DebuggerLog+ -> Debugger.DebugRunner Ghc ()+ -> Debugger.RunDebuggerSettings -- ^ Settings for running the debugger+ -> MVar D.Command -- ^ Read commands+ -> MVar D.Response -- ^ Write reponses+ -> IO ()+debuggerThread l debugRunner runConf requests replies = do+ liftIO $ do+ tid <- myThreadId+ labelThread tid "Main Debugger Thread (before runDebugger)"+ Debugger.runDebugger l debugRunner runConf $ do+ liftIO $ do+ tid <- myThreadId+ labelThread tid "Main Debugger Thread"+ let loop = do+ req <- takeMVar requests & liftIO+ resp <- try (Debugger.execute req)+ case resp of+ Right x -> do+ liftIO (putMVar replies x)+ loop+ Left e | Just (Debugger.NonFatalException {Debugger.userMessage = userm,+ Debugger.debugMessage = dbgm}) <- fromException e -> do+ Debugger.logSDoc Logger.Error (text userm)+ Debugger.logSDoc Logger.Debug (text dbgm)+ liftIO $ putMVar replies (NonFatalError userm)+ Left e ->+ -- don't loop in this case! just exit.+ liftIO $ putMVar replies (Aborted ("Aborted debugger thread: " ++ displayExceptionWithInfo e))+ loop++--------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------+{-+Note [Debugger, debuggee, and DAP logs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Specification for the logger given to `Debugger`:++1. All -v3 DebuggerLog and GHCLog messages go to the normal stdout/stderr (this shows up in+ the OUTPUT console in VSCode, without having to send special messages)++2. All -v1 DebuggerLog, GHCLog, and all LogDebuggeeOut and LogDebuggeeErr output+ goes to the DAP console (this is DEBUG CONSOLE in VSCode)++3. All LogDebuggeeOut and LogDebuggeeErr output are forwarded to the proxy if+ the proxy is enabled.+-}++-- See Note [Debugger, debuggee, and DAP logs]+createDebuggerLogger+ :: LogAction IO DAPSessionLog+ -> LogAction IO T.Text -- ^ Logger that writes to to DAP output+ -> Handle -- ^ Handle to DAP output+ -> IO (LogAction IO Debugger.DebuggerLog)+createDebuggerLogger l dapLogger writeDAPOutput = do+ return $+ -- (1) (all output is logged to normal logger)+ contramap DAPDebuggerLog l <>+ -- (2) and (3) (log relevant output to DAP handle)+ LogAction (\case+ Debugger.DebuggerLog sev msg ->+ when (sev >= Info) $+ dapLogger <& T.pack (show msg)+ Debugger.GHCLog logflags msg_class srcSpan msg ->+ defaultLogActionWithHandles writeDAPOutput writeDAPOutput logflags msg_class srcSpan msg+ -- don't log other messages, already logged to (1)+ Debugger.DebuggerSessionLog{} -> pure ()+ )
+ hdb-dap/Development/Debug/Adapter/Interface.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE LambdaCase, RecordWildCards #-}+module Development.Debug.Adapter.Interface where++import qualified Data.Text as T+import Control.Concurrent.MVar+import Control.Monad.IO.Class++import DAP++import GHC.Debugger.Interface.Messages as D+import Development.Debug.Adapter+import qualified Development.Debug.Adapter.Output as Output++-- | Synchronously send a command to the debugger and await a response+sendSync :: D.Command -> DebugAdaptor Response+sendSync cmd = do+ DAS{..} <- getDebugSession+ liftIO $ putMVar syncRequests cmd+ liftIO (takeMVar syncResponses) >>= handleErrors++-- | Sends a command to the debugger, then runs the given action, and only after running the action it waits for the result of the debugger+sendInterleaved :: D.Command -> DebugAdaptor () -> DebugAdaptor Response+sendInterleaved cmd action = do+ DAS{..} <- getDebugSession+ liftIO $ putMVar syncRequests cmd+ () <- action+ liftIO (takeMVar syncResponses) >>= handleErrors++handleErrors :: Response -> DebugAdaptor Response+handleErrors (NonFatalError e) = do+ Output.console (T.pack e)+ -- reply still in this connection with "ErrorResponse" to pending request+ sendError (ErrorMessage (T.pack e)) Nothing+handleErrors (Aborted e) = do+ Output.console (T.pack e)+ sendTerminatedEvent (TerminatedEvent False)+ destroyDebugSession -- kill this debug session's threads+ -- reply still in this connection with "ErrorResponse" to pending request+ sendError (ErrorMessage (T.pack e)) Nothing+handleErrors r = return r
+ hdb-dap/Development/Debug/Adapter/Output.hs view
@@ -0,0 +1,55 @@+-- | Meant to be imported qualified:+--+-- @+-- import qualified Development.Debugger.Output as Output+--+-- Output.console "Category used for informational output from debugger, not debuggee"+-- Output.stdout "Standard out of debuggee"+-- Output.stderr "Standard err of debuggee"+-- ...+-- @+--+-- TODO:+-- [ ] ANSI Styling of output console messages?+--+module Development.Debug.Adapter.Output+ ( neutral, console, important, stdout, stderr )+ where++import Data.Text (Text)+import qualified Data.Text as T+import DAP (sendOutputEvent, defaultOutputEvent, OutputEvent(..), OutputEventCategory(..))+import Development.Debug.Adapter++-- | Default 'OutputEvent' without an explicit category.+neutral :: Text -> DebugAdaptorX r+neutral = send Nothing++-- | Show the output in the client's default message UI, e.g. a 'debug+-- console'. This category should only be used for informational output from+-- the debugger (as opposed to the debuggee).+console :: Text -> DebugAdaptorX r+console = send $ Just OutputEventCategoryConsole++-- | 'important': A hint for the client to show the output in the client's UI+-- for important and highly visible information, e.g. as a popup notification.+-- This category should only be used for important messages from the debugger+-- (as opposed to the debuggee).+important :: Text -> DebugAdaptorX r+important = send $ Just OutputEventCategoryImportant++-- | Show the output as normal program output from the debuggee.+stdout :: Text -> DebugAdaptorX r+stdout = send $ Just OutputEventCategoryStdout++-- | Show the output as error program output from the debuggee.+stderr :: Text -> DebugAdaptorX r+stderr = send $ Just OutputEventCategoryStderr++-- | Generic send output event given the category+send :: Maybe OutputEventCategory -> Text -> DebugAdaptorX r+send cat txt = do+ sendOutputEvent defaultOutputEvent+ { outputEventCategory = cat+ , outputEventOutput = txt <> T.pack "\n"+ }
+ hdb-dap/Development/Debug/Adapter/Proxy.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE BlockArguments, OverloadedStrings, DerivingStrategies, OrPatterns #-}+{-# LANGUAGE NondecreasingIndentation #-}+-- | Run the proxy mode, which forwards stdin/stdout to/from the DAP server and+-- is displayed in a terminal in the DAP client using 'runInTerminal'.+--+-- Note: the proxy program is only launched when 'runInTerminal' is supported+-- and we're using the internal interpreter (--internal-interpreter).+--+-- If the external interpreter is being used (the default), we launch the+-- external interpreter directly with 'runInTerminal' and don't need the proxy+-- at all.+module Development.Debug.Adapter.Proxy+ ( mkServerSideHdbProxy+ , runInTerminalHdbProxy+ , sendRunProxyInTerminal+ , openSocketAvailablePort+ ) where++#if !MIN_VERSION_ghc(9,15,0)+-- no longer needs to be imported in 9.15+import GHC.Conc.Sync (labelThread)+#endif++import DAP++import Control.Concurrent.Async+import System.IO+import System.Exit (exitSuccess)+import System.Environment+import System.FilePath+import Control.Exception.Base+import Control.Monad+import Control.Concurrent+import qualified Data.List.NonEmpty as NE++import qualified Data.Text as T+import Network.Socket hiding (Debug)+import Network.Run.TCP+import qualified Network.Socket.ByteString as NBS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.HashMap.Strict as H++import Colog.Core+import Development.Debug.Adapter+import qualified Control.Exception as E+import GHC.Debugger.Interface.Messages (unAbs)++-- | Fork a new thread to run the server-side of the proxy.+--+-- 1. To setup:+-- Ask the DAP client to launch a process running @hdb proxy --port <port>@+-- by sending a 'runInTerminal' DAP reverse request. This is done outside of+-- this function by signaling the given MVar (this is the case because we cannot use `network` with `DebugAdaptor`+--+-- 2. In a loop,+-- 2.1 Read stdin from the socket and push it to a Chan+-- 2.1 Read from a stdout Chan and write to the socket+mkServerSideHdbProxy :: LogAction IO (WithSeverity T.Text)+ -> Chan BS8.ByteString+ -> Chan BS8.ByteString+ -> Chan BS8.ByteString+ -> MVar ()+ -> IO (PortNumber, IO ())+mkServerSideHdbProxy l dbIn dbOut dbErr client_conn_signal =+ bracketOnError openSocketAvailablePort close $ \ sock -> do++ port <- socketPort sock++ return $ (port,) $ do+ ignoreIOException $ do+ myThreadId >>= \tid -> labelThread tid "Debug/Adapter/Proxy: TCP Server"+ runTCPServerWithSocket' sock $ \scket -> do++ infoMsg (T.pack $ "Connected to client on port " ++ show port ++ "...!")+ putMVar client_conn_signal () -- signal ready (see #95)++ race_+ (race_+ (-- Read stdout from chan and write to socket+ ignoreIOException $ do+ labelMe "Debug/Adapter/Proxy: Forward stdout"+ forever $ do+ bs <- readChan dbOut+ debugMsg (T.pack $ "Writing to socket: " ++ BS8.unpack bs)+ NBS.sendAll scket bs)+ (-- Read stderr from chan and write to socket+ ignoreIOException $ do+ labelMe "Debug/Adapter/Proxy: Forward stderr"+ forever $ do+ bs <- readChan dbErr+ debugMsg (T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs)+ NBS.sendAll scket bs))+ (-- Read stdin from socket and write to chan+ let+ loop = do+ bs <- NBS.recv scket 4096+ if BS8.null bs+ then do+ debugMsg (T.pack "Connection to client was closed.")+ close scket+ else do+ debugMsg (T.pack $ "Read from socket: " ++ BS8.unpack bs)+ writeChan dbIn bs >> loop+ in ignoreIOException $ do+ labelMe "Debug/Adapter/Proxy: Read stdin"+ loop)++ where+ ignoreIOException a = catch a $ \(e::IOException) ->+ infoMsg (T.pack $ "Ignoring connection broken to proxy client: " ++ show e)+ debugMsg msg = l <& WithSeverity msg Debug+ infoMsg msg = l <& WithSeverity msg Info++-- | A version of @runTCPServerWithSocket@ that kills the forked connection+-- handlers when killed.+runTCPServerWithSocket' :: Socket -> (Socket -> IO a1) -> IO a2+runTCPServerWithSocket' sock server = do+ let+ serverLoop = forever $ E.bracketOnError (accept sock) (close . fst) $+ \(conn, _peer) ->+ mask_ $ withAsyncWithUnmask+ (\ unmask ->+ unmask (labelMe "TCP Server handler" >> server conn)+ `finally` gracefulClose conn 5000)+ (const serverLoop)+ serverLoop++-- | Label the running thread+labelMe :: String -> IO ()+labelMe name = do+ tid <- myThreadId+ labelThread tid name++-- | Open a socket on an available port+openSocketAvailablePort :: IO Socket+openSocketAvailablePort = do+ let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV] ++ [AI_PASSIVE] -- For wildcard IP (0.0.0.0 or ::)+ , addrSocketType = Stream++ , addrFamily = AF_UNSPEC -- Allow IPv4 or IPv6+ }+ addr <- NE.head <$> getAddrInfo (Just hints) Nothing (Just "0")+ openTCPServerSocketFixed addr+ where+ openTCPServerSocketFixed addr = do+ bracketOnError (openSocket addr) Network.Socket.close $ \ sock -> do+ setSocketOption sock ReuseAddr 1+ -- openTCPServerSocket from network-run includes this commented out snippet which causes test failures ("runInTerminal: proxy forwards stdin correctly") on macOS.+ -- #if !defined(openbsd_HOST_OS)+ -- when (addrFamily addr == AF_INET6) $ setSocketOption sock IPv6Only 1+ -- #endif+ mapM_ (uncurry $ setSockOptValue sock) []+ withFdSocket sock setCloseOnExecIfNeeded+ bind sock $ addrAddress addr+ listen sock maxListenQueue+ return sock++-- | The proxy code running on the terminal in which the @hdb proxy@ process is launched.+--+-- This client-side proxy is responsible for+-- 1. Connecting to the given proxy-server port+-- 2. Forwarding stdin to the port it is connected to+-- 3. Read from the network the output and write it to stdout+runInTerminalHdbProxy :: LogAction IO (WithSeverity T.Text) -> Int -> IO ()+runInTerminalHdbProxy l port = do+ l <& WithSeverity (T.pack $ "Running in terminal on port " ++ show port ++ "...!") Info+ hSetBuffering stdin LineBuffering++ dbg_inv <- lookupEnv "DEBUGGEE_INVOCATION"+ case dbg_inv of+ Nothing -> pure ()+ Just inv ->+ putStrLn $ "Running the debugger input/output proxy for the following debuggee execution:\n\n\n " ++ inv ++ "\n\n"++ catch (+ runTCPClient "127.0.0.1" (show port) $ \sock -> do+ -- Forward stdin to sock+ concurrently_+ (catch (forever $ do+ str <- BS8.hGetLine stdin+ NBS.sendAll sock (str <> BS8.pack "\n")+ ) $ \(_e::IOException) -> return ()) -- connection dropped, just exit.++ (-- Forward stdout from sock+ catch (forever $ do+ msg <- NBS.recv sock 4096+ if BS8.null msg+ then do+ l <& WithSeverity (T.pack "Exiting...") Info+ close sock+ exitSuccess+ else BS8.hPut stdout msg >> hFlush stdout+ ) $ \(_e::IOException) -> return ()) -- connection dropped, just exit.++ ) $ \(_e::IOException) -> do+ hPutStrLn stderr "Failed to connect to debugger server proxy -- did the debuggee compile and start running successfully?"++-- | Send a 'runInTerminal' reverse request to the DAP client+-- with the @hdb proxy@ invocation+sendRunProxyInTerminal :: FilePath -> PortNumber -> DebugAdaptor ()+sendRunProxyInTerminal hdbProg port = do+ DAS { entryFile+ , entryPoint+ , entryArgs+ , projectRoot } <- getDebugSession+ let debuggee_inv = T.pack $ makeRelative (unAbs projectRoot) (unAbs entryFile) ++ ":" ++ entryPoint +++ (if null entryArgs then "" else " ") ++ unwords entryArgs+ sendRunInTerminalReverseRequest+ RunInTerminalRequestArguments+ { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated+ , runInTerminalRequestArgumentsTitle = Just debuggee_inv+ , runInTerminalRequestArgumentsCwd = ""+ , runInTerminalRequestArgumentsArgs = [T.pack hdbProg, "proxy", "--port", T.pack (show port)]+ , runInTerminalRequestArgumentsEnv = Just (H.singleton "DEBUGGEE_INVOCATION" debuggee_inv)+ , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False+ }
+ hdb-dap/Development/Debug/Adapter/Server.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-}+module Development.Debug.Adapter.Server+ (+ module Development.Debug.Adapter.Server,+ LogAction(..),+ )+ where+++import System.Environment+import Data.Maybe+import Text.Read+import Control.Monad+import Control.Monad.IO.Class+import Control.Concurrent (ThreadId, myThreadId)+import GHC.Conc.Sync (threadLabel)++import DAP++import Development.Debug.Adapter.Init+import Development.Debug.Adapter.Breakpoints+import Development.Debug.Adapter.Stepping+import Development.Debug.Adapter.Stopped+import Development.Debug.Adapter.Evaluation+import Development.Debug.Adapter.ExceptionInfo+import Development.Debug.Adapter.Exit+import Development.Debug.Adapter.Exit.Helpers+import Colog.Core++import Data.Time+import qualified DAP.Log as DAP+import Data.Text (Text)+import qualified Data.Text as T+import Data.Functor.Contravariant+++import Development.Debug.Adapter+++import qualified GHC.Utils.Logger as GHC+import GHC.Debugger.Debuggee (DebuggerLog(..))+import qualified GHC.Plugins as GHC+++-------------------------------------------------------------------------+-- * DAP lib config+-------------------------------------------------------------------------++-- | Fetch config from environment, fallback to sane defaults+getConfig :: Int -> IO ServerConfig+getConfig port = do+ let+ hostDefault = "0.0.0.0"+ portDefault = port+ capabilities = Capabilities+ { supportsConfigurationDoneRequest = True+ , supportsFunctionBreakpoints = True+ , supportsConditionalBreakpoints = True+ , supportsHitConditionalBreakpoints = True+ , supportsEvaluateForHovers = False+ -- Exception Breakpoints:+ , exceptionBreakpointFilters = [ defaultExceptionBreakpointsFilter+ { exceptionBreakpointsFilterLabel = "All exceptions"+ , exceptionBreakpointsFilterFilter = BREAK_ON_EXCEPTION+ }+ , defaultExceptionBreakpointsFilter+ { exceptionBreakpointsFilterLabel = "Uncaught exceptions"+ , exceptionBreakpointsFilterFilter = BREAK_ON_ERROR+ }+ ]+ , supportsStepBack = False+ , supportsSetVariable = False+ , supportsRestartFrame = False+ , supportsGotoTargetsRequest = False+ , supportsStepInTargetsRequest = False+ , supportsCompletionsRequest = False+ , completionTriggerCharacters = []+ , supportsModulesRequest = False+ , additionalModuleColumns = [ defaultColumnDescriptor+ { columnDescriptorAttributeName = "Extra"+ , columnDescriptorLabel = "Label"+ }+ ]+ , supportedChecksumAlgorithms = []+ , supportsRestartRequest = False+ , supportsExceptionOptions = True+ , supportsValueFormattingOptions = True+ , supportsExceptionInfoRequest = True+ , supportTerminateDebuggee = False -- for now, when debugger is disconnected, we always kill the debuggee+ , supportSuspendDebuggee = False+ , supportsDelayedStackTraceLoading = False+ , supportsLoadedSourcesRequest = False+ , supportsLogPoints = True+ , supportsTerminateThreadsRequest = False+ , supportsSetExpression = False+ , supportsTerminateRequest = True+ , supportsDataBreakpoints = False+ , supportsReadMemoryRequest = False+ , supportsWriteMemoryRequest = False+ , supportsDisassembleRequest = False+ , supportsCancelRequest = False+ -- Display which breakpoints are valid when user intends to set+ -- breakpoint on given line:+ , supportsBreakpointLocationsRequest = True+ , supportsClipboardContext = False+ , supportsSteppingGranularity = False+ , supportsInstructionBreakpoints = False+ , supportsExceptionFilterOptions = False+ , supportsSingleThreadExecutionRequests = False+ }+ ServerConfig+ <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST"+ <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT"+ <*> pure capabilities+ <*> pure True++--------------------------------------------------------------------------------+-- * Talk+--------------------------------------------------------------------------------++-- | Main function where requests are received and Events + Responses are returned.+-- The core logic of communicating between the client <-> adaptor <-> debugger+-- is implemented in this function.+talk :: LogAction IO DAPLog+ -> DAPServerConf+ -> Bool+ -- ^ Prefer internal interpreter+ -> Command -> DebugAdaptor ()+--------------------------------------------------------------------------------+talk l servConf prefer_internal_interpreter = \ case+ CommandInitialize -> do+ sendInitializeResponse+--------------------------------------------------------------------------------+ CommandLaunch -> do+ launch_args <- getArguments++ clientCaps <- getClientCapabilities+#ifdef mingw32_HOST_OS+ -- On Windows, runInTerminal is currently unsupported+ -- See #199+ let runInTerminal = False+#else+ let runInTerminal = fromMaybe False $ supportsRunInTerminalRequest =<< clientCaps+#endif++ initDebugger (cmapM (\ (sId,x) -> DAPSessionLog sId <$> myThreadId <*> pure x) l) servConf+ InterpreterChoice {runInTerminal, internal = prefer_internal_interpreter}+ launch_args++ sendLaunchResponse -- ack+ sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session++ liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info)+--------------------------------------------------------------------------------+ CommandAttach -> do+ sendTerminatedEvent (TerminatedEvent False)+ destroyDebugSession+ sendError (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing+--------------------------------------------------------------------------------+ CommandBreakpointLocations -> commandBreakpointLocations+ CommandSetBreakpoints -> commandSetBreakpoints+ CommandSetFunctionBreakpoints -> commandSetFunctionBreakpoints+ CommandSetExceptionBreakpoints -> commandSetExceptionBreakpoints+ CommandExceptionInfo -> commandExceptionInfo+ CommandSetDataBreakpoints -> undefined+ CommandSetInstructionBreakpoints -> undefined+----------------------------------------------------------------------------+ CommandLoadedSources -> undefined+----------------------------------------------------------------------------+ CommandConfigurationDone -> do+ sendConfigurationDoneResponse++ DAS{waitForDebuggee} <- getDebugSession+ liftIO $ waitForDebuggee++ -- Configuration is finished. Start executing until it halts.+ startExecution >>= handleEvalResult False+----------------------------------------------------------------------------+ CommandThreads -> commandThreads+ CommandStackTrace -> commandStackTrace+ CommandScopes -> commandScopes+ CommandVariables -> commandVariables+----------------------------------------------------------------------------+ CommandContinue -> commandContinue+----------------------------------------------------------------------------+ CommandNext -> commandNext+----------------------------------------------------------------------------+ CommandStepIn -> commandStepIn+ CommandStepOut -> commandStepOut+----------------------------------------------------------------------------+ CommandEvaluate -> commandEvaluate+----------------------------------------------------------------------------+ CommandTerminate -> commandTerminate+ CommandDisconnect -> commandDisconnect+----------------------------------------------------------------------------+ CommandModules -> sendModulesResponse (ModulesResponse [] Nothing)+ CommandSource -> undefined+ CommandPause -> pure () -- TODO+ (CustomCommand "mycustomcommand") -> undefined+ other -> do+ terminateWithError ("Unsupported command: " <> show other)++-- | Receive reverse request responses (such as runInTerminal response)+ack :: LogAction IO DAPLog+ -> ReverseRequestResponse -> DebugAdaptorCont ()+ack l rrr = case rrr.reverseRequestCommand of+ ReverseCommandRunInTerminal -> do++ RunInTerminalResponse{} <- getReverseRequestResponseBody rrr++ -- TODO: keep track of body.shellProcessId to then kill the proxy when the+ -- session is terminated:+ -- [stdout] [127.0.0.1:54427][DEBUG][RECEIVED]+ -- {+ -- "body": {+ -- "shellProcessId": 2092+ -- },+ -- "command": "runInTerminal",+ -- "seq": 14,+ -- "success": true,+ -- "type": "response"+ -- }+ when rrr.success $ do+ liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info)+ _ -> pure ()++-- | Starts a DAP server for haskell debugging.+--+-- INVARIANT: The initUniqSupply has already been initialized.+--+-- Users of hdb-as-a-library will have to call `initUniqSupply` at their leisure,+-- special care needed if they supply any loaded units/modules to us via the `DebugRunner`,+-- as those will contain `Unique`s.+--+-- See Note [UniqueSupply is process global].+runHDBServer :: LogAction IO DAPLog -> DAPServerConf -> IO ()+runHDBServer l servConf@DAPServerConf{ dapServerConfig = config } = do+ runDAPServerWithLogger (contramap DAPLibraryLog l) config+ (talk l servConf False)+ (ack l )++--------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------++data DAPLog+ = DAPSessionLog !SessionId !ThreadId DAPSessionLog+ | DAPLaunchLog (WithSeverity T.Text)+ | DAPLibraryLog DAP.DAPLog++logSessionLog :: Show a => LogAction IO Text -> Severity -> WithSeverity a -> IO ()+logSessionLog l threshold (WithSeverity msg sev)+ | sev >= threshold =+ l <& (renderSeverity sev <> T.pack (show msg))+ | otherwise = pure ()++logDebuggerLog :: GHC.LogAction -> LogAction IO Text -> Severity -> DebuggerLog -> IO ()+logDebuggerLog logGhcLog l threshold = \case+ DebuggerLog sev msg ->+ when (sev >= threshold) $+ l <&+ (renderSeverity sev <> T.pack (show msg))+ GHCLog logflags msg_class srcSpan msg ->+ logGhcLog logflags msg_class srcSpan msg+ DebuggerSessionLog sev msg ->+ when (sev >= threshold) $+ l <&+ (renderSeverity sev <> msg)++defaultLog :: LogAction IO Text -> Severity -> WithSeverity Text -> IO ()+defaultLog l threshold (WithSeverity msg sev)+ | sev >= threshold =+ l <& (renderSeverity sev <> msg)+ | otherwise = pure ()++renderSessionId :: Text -> Text+renderSessionId sId = "[SESSID=" <> sId <> "]"++renderThreadLabel :: ThreadId -> IO Text+renderThreadLabel thId = do+ let dropThreadId t = fromMaybe t $ T.stripPrefix "ThreadId " t+ lbl <- maybe (dropThreadId $ T.show thId) T.pack <$> threadLabel thId+ pure $ "[THREAD=" <> lbl <> "]"++renderWithDAPPrefix :: Text -> ThreadId -> Text -> IO Text+renderWithDAPPrefix sessionId thId msg = do+ lbl <- renderThreadLabel thId+ renderWithTimestamp (renderSessionId sessionId <> lbl <> msg)++-- | Main log action for the HDB DAP server. Takes a log action for ghc messages, a+-- Text log action for everything else, and a severity threshold.+logDAPLog :: GHC.LogAction -> LogAction IO Text -> Severity -> LogAction IO DAPLog+logDAPLog logGhcLog l threshold = LogAction $ \case+ DAPSessionLog sessionId threadId msg -> do+ let l1 = cmapM (renderWithDAPPrefix sessionId threadId) l+ logGhcLog1 f mc sp sdoc = do+ prefix <- renderWithDAPPrefix sessionId threadId ""+ logGhcLog f mc sp (GHC.text (T.unpack prefix) GHC.<> sdoc)++ case msg of+ (DAPSessionSetupLog sessionLog) -> logSessionLog l1 threshold sessionLog+ (DAPDebuggerLog debuggerLog) -> logDebuggerLog logGhcLog1 l1 threshold debuggerLog+ (RunProxyServerLog sev_msg) -> defaultLog l1 threshold sev_msg+ DAPLaunchLog sev_msg -> defaultLog (cmapM renderWithTimestamp l) threshold sev_msg+ DAPLibraryLog t | convert t.severity >= threshold ->+ l <& DAP.renderDAPLog t+ | otherwise -> pure ()+ where+ convert DAP.DEBUG = Debug+ convert DAP.INFO = Info+ convert DAP.WARN = Warning+ convert DAP.ERROR = Error++renderSeverity :: Severity -> Text+renderSeverity = \case+ Debug -> "[DEBUG] "+ Info -> "[INFO] "+ Warning -> "[WARNING] "+ Error -> "[ERROR] "++renderWithTimestamp :: Text -> IO Text+renderWithTimestamp msg = do+ t <- getCurrentTime+ let timeStamp = utcTimeToText t+ pure $ "[" <> timeStamp <> "] " <> msg+ where+ utcTimeToText utcTime = T.pack $+ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime
+ hdb-dap/Development/Debug/Adapter/Stepping.hs view
@@ -0,0 +1,45 @@+module Development.Debug.Adapter.Stepping where++import DAP++import GHC.Debugger.Interface.Messages hiding (Command, Response)++import Development.Debug.Adapter+import Development.Debug.Adapter.Interface+import Development.Debug.Adapter.Evaluation++commandContinue :: DebugAdaptor ()+commandContinue = do+ resetObjectReferences+ DidContinue er <- sendInterleaved DoContinue $+ sendContinueResponse (ContinueResponse True)+ handleEvalResult False er++commandNext :: DebugAdaptor ()+commandNext = do+ resetObjectReferences+ DidStep er <- sendInterleaved DoStepLocal sendNextResponse+ handleEvalResult True er++commandStepIn :: DebugAdaptor ()+commandStepIn = do+ resetObjectReferences+ DidStep er <- sendInterleaved DoSingleStep sendStepInResponse+ handleEvalResult True er++commandStepOut :: DebugAdaptor ()+commandStepOut = do+ resetObjectReferences+ DidStep er <- sendInterleaved DoStepOut sendStepOutResponse+ handleEvalResult True er++--------------------------------------------------------------------------------++-- | See "Lifetime of Objects References" in DAP specification.+resetObjectReferences :: DebugAdaptor ()+resetObjectReferences = do+ updateDebugSession $ \s ->+ s { stackFrameMap = mempty+ , breakpointMap = mempty+ , variablesMap = mempty+ }
+ hdb-dap/Development/Debug/Adapter/Stopped.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE RecordWildCards, OverloadedRecordDot, OverloadedStrings, LambdaCase #-}++-- | Getting information about where we're stopped at (current suspended state).+--+-- Includes the commands to execute the following requests on the debuggee state:+-- +-- @+-- Threads+-- StackTrace+-- Scopes+-- Variables+-- ...+-- Variables+-- @+module Development.Debug.Adapter.Stopped where++import Control.Monad+import qualified Data.IntMap as IM+import qualified Data.Text as T++import DAP++import GHC.Debugger.Interface.Messages+import Development.Debug.Adapter+import Development.Debug.Adapter.Interface++--------------------------------------------------------------------------------+-- * StackTrace+--------------------------------------------------------------------------------++-- | Command to get thread information at current stopped point+commandThreads :: DebugAdaptor ()+commandThreads = do+ GotThreads ts <- sendSync GetThreads+ sendThreadsResponse $+ map (\t ->+ Thread+ { threadId = remoteThreadIntRef t.tId+ , threadName = maybe (T.pack $ "Thread #" ++ show (remoteThreadIntRef t.tId)) T.pack t.tName+ }+ ) ts++--------------------------------------------------------------------------------+-- * StackTrace+--------------------------------------------------------------------------------++-- | Command to fetch stack trace at current stop point+commandStackTrace :: DebugAdaptor ()+commandStackTrace = do+ StackTraceArguments{..} <- getArguments+ let threadId = RemoteThreadId stackTraceArgumentsThreadId+ GotStacktrace stackFrames <- sendSync (GetStacktrace threadId)+ (responseFrames, newStackFrameMap) <- fmap (unzip . concat) $+ forM (zip stackFrames [0..]) $ \(stackFrame, stackFrameIx) -> do+ freshId <- getFreshId+ source <- fileToSource stackFrame.sourceSpan.file+ let responseFrame = defaultStackFrame+ { stackFrameId = freshId+ , stackFrameName = T.pack stackFrame.name+ , stackFrameLine = stackFrame.sourceSpan.startLine+ , stackFrameColumn = stackFrame.sourceSpan.startCol+ , stackFrameEndLine = Just stackFrame.sourceSpan.endLine+ , stackFrameEndColumn = Just stackFrame.sourceSpan.endCol+ , stackFrameSource = Just source+ }+ let newMapEntry = (freshId, StackFrameIx threadId stackFrameIx)+ return [(responseFrame, newMapEntry)]++ updateDebugSession (\s -> s { stackFrameMap = s.stackFrameMap <> IM.fromList newStackFrameMap })++ sendStackTraceResponse StackTraceResponse+ { stackFrames = responseFrames+ , totalFrames = if null responseFrames then Nothing else Just (length responseFrames)+ }++--------------------------------------------------------------------------------+-- * Scopes+--------------------------------------------------------------------------------++-- | Command to get scopes for current stopped point+commandScopes :: DebugAdaptor ()+commandScopes = do+ ScopesArguments{..} <- getArguments+ let frameId = scopesArgumentsFrameId+ sfMap <- stackFrameMap <$> getDebugSession+ case IM.lookup frameId sfMap of+ Nothing -> do+ sendErrorResponse (ErrorMessage (T.pack $ "Could not find stack frame for id " ++ show frameId)) Nothing+ Just six@(StackFrameIx threadId frameIx) -> do+ GotScopes scopes <- sendSync (GetScopes threadId frameIx)+ sendScopesResponse . ScopesResponse =<<+ mapM (scopeInfoToScope six) scopes++-- | 'ScopeInfo' to 'Scope'+scopeInfoToScope :: StackFrameIx -> ScopeInfo -> DebugAdaptor Scope+scopeInfoToScope six ScopeInfo{..} = do++ -- Update vars map+ varId <- freshVarIx six (scopeToVarRef kind)++ source <- fileToSource sourceSpan.file+ return Scope+ { scopeName = case kind of+ LocalVariablesScope -> "Locals"+ ModuleVariablesScope -> "Module"+ GlobalVariablesScope -> "Globals"+ , scopePresentationHint = Just $ case kind of+ LocalVariablesScope -> ScopePresentationHintLocals+ ModuleVariablesScope -> ScopePresentationHint "module"+ GlobalVariablesScope -> ScopePresentationHint "globals"+ , scopeNamedVariables = numVars+ , scopeIndexedVariables = Nothing+ , scopeSource = Just source+ , scopeLine = Just sourceSpan.startLine+ , scopeColumn = Just sourceSpan.startCol+ , scopeEndLine = Just sourceSpan.endLine+ , scopeEndColumn = Just sourceSpan.endCol+ , scopeVariablesReference = varId+ , scopeExpensive = expensive+ }++--------------------------------------------------------------------------------+-- * Variables+--------------------------------------------------------------------------------++-- | Command to get variables by reference number+commandVariables :: DebugAdaptor ()+commandVariables = do+ VariablesArguments{..} <- getArguments++ vsMap <- variablesMap <$> getDebugSession+ case IM.lookup variablesArgumentsVariablesReference vsMap of+ Nothing -> sendErrorResponse (ErrorMessage (T.pack $ "Could not find variable reference " ++ show variablesArgumentsVariablesReference)) Nothing+ Just (VariablesIx six@(StackFrameIx threadId frameIx) varRef) -> do+ GotVariables vars <- sendSync (GetVariables threadId frameIx varRef)+ sendVariablesResponse . VariablesResponse =<<+ mapM (varInfoToVariables six) (variableResultToList vars)+ case vars of+ -- If the reply indicates this was an "inspect lazy variable" request+ -- (because the requested variable was forced instead of returning an+ -- expansion), invalidate the parent variables.+ --+ -- The client side seems to handle rendering only the bits which changed+ -- out very well, while preserving the variable tree expansion.+ -- In any case, we might have to pessimistically redo all variable+ -- responses because any value may be changed by an updated thunk, not only+ -- the parent variables.+ ForcedVariable _+ -> sendInvalidatedEvent defaultInvalidatedEvent+ { invalidatedEventAreas = [InvalidatedAreasVariables]+ }+ VariableFields _ -> return ()++-- | 'VarInfo' to 'Variable's.+varInfoToVariables :: StackFrameIx -> VarInfo -> DebugAdaptor Variable+varInfoToVariables six VarInfo{..} = do+ varId <- freshVarIx six varRef++ return defaultVariable+ { variableName = T.pack varName+ , variableValue = T.pack varValue+ , variableType = Just $ T.pack varType+ , variableEvaluateName = Just $ T.pack varName+ , variableVariablesReference = varId+ , variableNamedVariables = Nothing+ , variableIndexedVariables = Nothing+ , variablePresentationHint = Just defaultVariablePresentationHint+ { variablePresentationHintLazy = Just isThunk+ }+ }++--------------------------------------------------------------------------------+-- Variable ix references+--------------------------------------------------------------------------------++freshVarIx :: StackFrameIx -> VariableReference -> DebugAdaptor Int+freshVarIx _ NoVariables = pure 0 -- No variables means the reference should be 0, e.g. denoting the variable is not expandable+freshVarIx six vr = do+ varId <- getFreshId+ updateDebugSession (\s -> s { variablesMap = IM.insert varId (VariablesIx six vr) s.variablesMap })+ return varId
+ hdb-dap/Development/Debug/Session/Setup.hs view
@@ -0,0 +1,404 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Development.Debug.Session.Setup+ (+ -- * Setting up a hie-bios session+ HieBiosFlags(..)+ , hieBiosSetup++ -- * Logging+ , SessionSetupLog(..)+ , renderSessionSetupLog++ , GhcInvocation(..)+ , DebugRunnerProvider+ , hieDebugRunner+ , DebugRunnerConf(..)+ ) where++import Control.Applicative ((<|>))+import Control.Concurrent (newMVar, MVar, withMVar)+import Control.Exception (handleJust)+import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Data.Bifunctor+import Data.Function+import Data.Functor ((<&>))+import Data.Maybe+import Data.Version+import Data.Void+import System.Directory hiding (withCurrentDirectory, findFile)+import System.Directory qualified as D+import System.FilePath+import System.IO.Error+import Text.ParserCombinators.ReadP (readP_to_S)+import Data.Functor.Contravariant+import GHC.IO (unsafePerformIO)++import qualified Data.Text as T++import qualified HIE.Bios as HIE+import qualified HIE.Bios.Config as Config+import qualified HIE.Bios.Cradle as HIE+import qualified HIE.Bios.Environment as HIE+import qualified HIE.Bios.Types as HIE+import qualified Hie.Cabal.Parser as Implicit+import qualified Hie.Locate as Implicit+import qualified Hie.Yaml as Implicit++import Colog.Core+import Prettyprinter+import Prettyprinter.Render.Text++import qualified GHC.Debugger.Monad as Debugger+import GHC (Ghc)+import GHC.Debugger.Monad (ProjectDebugSpec(ProjectDebugSpec))++data GhcInvocation = GhcInvocation+ { gi_libdir :: FilePath+ , gi_units :: [String]+ , gi_args :: [String]+ -- ^ includes also the ghcExtraArgs that will be passed to the DebugSession by the DebugRunner.+ }++-- | When successful in setting up a DebugRunner it also returns the GhcInvocation used.+type DebugRunnerProvider a = LogAction IO (WithSeverity SessionSetupLog)+ -> DebugRunnerConf+ -> IO (Either String (GhcInvocation, Debugger.DebugRunner Ghc a))++data DebugRunnerConf = DebugRunnerConf+ { drcProjectRoot :: FilePath+ , drcEntryFile :: FilePath+ , drcExtraGhcArgs :: [String]+ , drcCradleFile :: Maybe FilePath+ -- ^ specified cradle file rather than letting be inferred from+ -- @drcEntryFile@, relative to @drcProjectRoot@ if so. @DebugRunnerProvider@s+ -- must WARN if this field is @Just@ but they do not use hie cradles.+ } deriving Show++data SessionSetupLog+ = HieBiosLog HIE.Log+ | LogCradle (HIE.Cradle Void)+ | LogSetupMsg T.Text+ deriving Show++renderSessionSetupLog :: SessionSetupLog -> T.Text+renderSessionSetupLog = \case+ HieBiosLog l -> renderStrict $ layoutPretty defaultLayoutOptions $ pretty l+ LogCradle c -> T.pack $ "Using cradle: " ++ show c+ LogSetupMsg m -> m++-- | Flags inferred by @hie-bios@ to invoke GHC+data HieBiosFlags = HieBiosFlags+ { ghcInvocation :: [String]+ , libdir :: FilePath+ , units :: [String]+ , rootDir :: FilePath+ -- ^ Root dir as reported by the 'Cradle'+ , componentDir :: FilePath+ -- ^ Root dir of the loaded 'ComponentOptions'.+ -- Important for multi-package cabal projects, as packages are not in the+ -- root of the cradle, but in some sub-directory.+ }++-- | Prepare a GHC session using hie-bios from scratch+hieBiosSetup :: LogAction IO (WithSeverity SessionSetupLog)+ -> FilePath -- ^ project root+ -> FilePath -- ^ entry file+ -> Maybe FilePath -- ^ cradle file+ -> ExceptT String IO (Either String HieBiosFlags)+hieBiosSetup logger projectRoot entryFile cradleFile = do++ logInfo "Figuring out the right flags to compile the project using hie-bios..."+ cradle <- hieBiosCradle logger projectRoot entryFile cradleFile & ExceptT++ -- GHC is found in PATH (by hie-bios as well).+ logInfo "Checking GHC version against debugger version..."+ _version <- hieBiosRuntimeGhcVersion cradle++ logInfo "Discovering session flags with hie-bios..."+ r <- hieBiosFlags cradle projectRoot entryFile & liftIO++ logInfo "Session setup with hie-bios was successful."+ return r++ where+ logInfo m = liftLogIO logger <& WithSeverity (LogSetupMsg (T.pack m)) Info++-- | Try implicit-hie and the builtin search to come up with a @'HIE.Cradle'@+hieBiosCradle :: LogAction IO (WithSeverity SessionSetupLog)+ -> FilePath -- ^ Project root+ -> FilePath -- ^ Entry file relative to root+ -> Maybe FilePath -- ^ Cradle file relative to root+ -> IO (Either String (HIE.Cradle Void))+hieBiosCradle logger root relTarget mrelCradle = runExceptT $ do+ let target = root </> relTarget+ explicitCradle <- case mrelCradle of+ Nothing -> HIE.findCradle target & liftIO+ Just ((root </>) -> cradleFile) -> do+ liftIO (doesFileExist cradleFile) >>= \case+ True -> return $ Just cradleFile+ False -> throwError $ "Specified Cradle file does not exist: " ++ cradleFile+ cradle <- maybe (loadImplicitCradle hieBiosLogger target)+ (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO+ liftLogIO logger <& WithSeverity (LogCradle cradle) Info+ pure cradle+ where+ hieBiosLogger = contramap (fmap HieBiosLog) logger++-- | Fetch the runtime GHC version, according to hie-bios, and check it is the+-- same as the compile time GHC version+hieBiosRuntimeGhcVersion :: HIE.Cradle Void+ -> ExceptT String IO Version+hieBiosRuntimeGhcVersion cradle = do+ out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version"++ case versionMaybe out of+ Nothing -> throwError $ "Failed to parse GHC version: " <> out+ Just actualVersion -> do++ -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1):+ when (compileTimeGhcWithoutPatchVersion /= forgetPatchVersion actualVersion) $ do+ throwError $+ "Aborting...! The GHC version must be the same which " +++ "ghc-debug-adapter was compiled against (" +++ showVersion compileTimeGhcWithoutPatchVersion+++ "). Instead, got " ++ (showVersion actualVersion) ++ "."++ pure actualVersion++-- | Make 'HieBiosFlags' from the given target file+hieBiosFlags :: HIE.Cradle Void {-^ Project cradle the entry file belongs to -}+ -> FilePath {-^ Project root -}+ -> FilePath {-^ Entry file relative to root -}+ -> IO (Either String HieBiosFlags)+hieBiosFlags cradle root relTarget = runExceptT $ do+ let target = root </> relTarget+ libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir"++ -- To determine the flags we MUST set the current directory to the root+ -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does)+ -- (HIE.getCompilerOptions depends on CWD being the proper root dir)+ let compilerOpts = liftIO $ withCurrentDirectory root $+ HIE.getCompilerOptions (HIE.TargetWithContext target [target]) HIE.LoadUnitsFromCradle cradle+ componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"+#if __GLASGOW_HASKELL__ >= 913+ -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading+ -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch.+ -- ["-fwrite-if-simplified-core"] +++#endif++ let (units', flags') = extractUnits (HIE.componentOptions componentOpts)+ return HieBiosFlags+ { ghcInvocation = flags' ++ ghcDebuggerFlags+ , libdir = libdir+ , units = units'+ , rootDir = HIE.cradleRootDir cradle+ , componentDir = HIE.componentRoot componentOpts+ }++unwrapCradleResult :: MonadError String m => [Char] -> HIE.CradleLoadResult a -> m a+unwrapCradleResult m = \case+ HIE.CradleNone -> throwError $ "HIE.CradleNone\n" ++ m+ HIE.CradleFail err -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m+ HIE.CradleSuccess x -> return x++extractUnits :: [String] -> ([String], [String])+extractUnits = go [] []+ where+ -- TODO: we should likely use the 'processCmdLineP' instead+ go units rest ("-unit" : x : xs) = go (x : units) rest xs+ go units rest (x : xs) = go units (x : rest) xs+ go units rest [] = (reverse units, reverse rest)++-- | Flags specific to haskell-debugger to append to all GHC invocations.+ghcDebuggerFlags :: [String]+ghcDebuggerFlags =+ [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt+ ]++hieDebugRunner+ :: LogAction IO (WithSeverity SessionSetupLog)+ -> DebugRunnerConf+ -> IO (Either String (GhcInvocation, Debugger.DebugRunner Ghc a))+hieDebugRunner l (DebugRunnerConf projectRoot entryFile extraGhcArgs cradleFile) = runExceptT $ do+ r <- hieBiosSetup l projectRoot entryFile cradleFile+ HieBiosFlags{..} <- case r of+ Left e -> throwError e+ Right f -> return f+ let absEntryFile = normalise $ projectRoot </> entryFile+ let gI = GhcInvocation libdir units (ghcInvocation ++ extraGhcArgs)+ pure $ (,) gI $ Debugger.withProjectDebugSession ProjectDebugSpec{..}++-- ----------------------------------------------------------------------------+-- Utilities+-- ----------------------------------------------------------------------------++versionMaybe :: String -> Maybe Version+versionMaybe xs = case reverse $ readP_to_S parseVersion xs of+ [] -> Nothing+ (x:_) -> Just (fst x)++-- ----------------------------------------------------------------------------+-- Implicit cradle discovery logic mirroring the one used by HLS.+-- The code itself is copy-pasted from HLS.+-- Obviously, we want to reuse the logic without having to depend on HLS.+-- We should factor out a common sub-component from HLS and use it here as well.+-- ----------------------------------------------------------------------------++loadImplicitCradle :: Show a => LogAction IO (WithSeverity HIE.Log) -> FilePath -> IO (HIE.Cradle a)+loadImplicitCradle l wfile = do+ is_dir <- doesDirectoryExist wfile+ let wdir | is_dir = wfile+ | otherwise = takeDirectory wfile+ cfg <- runMaybeT (implicitConfig wdir)+ case cfg of+ Just bc -> HIE.getCradle l absurd bc+ Nothing -> return $ HIE.defaultCradle l wdir++-- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies+implicitConfig :: FilePath -> MaybeT IO (Config.CradleConfig a, FilePath)+implicitConfig = (fmap . first) (Config.CradleConfig noDeps) . inferCradleTree+ where+ noDeps :: [FilePath]+ noDeps = []+++inferCradleTree :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)+inferCradleTree start_dir =+ maybeItsBios+ -- If we have both a config file (cabal.project/stack.yaml) and a work dir+ -- (dist-newstyle/.stack-work), prefer that+ <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir))+ <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir)+ -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal+ <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle)+ -- If we have a stack.yaml, use stack+ <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle)+ -- If we have a cabal file, use cabal+ <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle)++ where+ maybeItsBios = (\wdir -> (Config.Bios (Config.Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir++ cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir)++-- | Generate a stack cradle given a filepath.+--+-- Since we assume there was proof that this file belongs to a stack cradle+-- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files.+-- We do not look for package.yaml, as we assume the corresponding .cabal has+-- been generated already.+--+-- We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then+-- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to+-- component names.+stackCradle :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)+stackCradle fp = do+ pkgs <- Implicit.stackYamlPkgs fp+ pkgsWithComps <- liftIO $ catMaybes <$> mapM (Implicit.nestedPkg fp) pkgs+ let yaml = fp </> "stack.yaml"+ pure $ (,fp) $ case pkgsWithComps of+ [] -> Config.Stack (Config.StackType Nothing (Just yaml) Nothing)+ ps -> Config.StackMulti mempty $ do+ Implicit.Package n cs <- ps+ c <- cs+ let (prefix, comp) = Implicit.stackComponent n c+ pure (prefix, Config.StackType (Just comp) (Just yaml) Nothing)++-- | By default, we generate a simple cabal cradle which is equivalent to the+-- following hie.yaml:+--+-- @+-- cradle:+-- cabal:+-- @+--+-- Note, this only works reliable for reasonably modern cabal versions >= 3.2.+simpleCabalCradle :: FilePath -> (Config.CradleTree a, FilePath)+simpleCabalCradle fp = (Config.Cabal $ Config.CabalType Nothing Nothing Nothing, fp)++cabalExecutable :: MaybeT IO FilePath+cabalExecutable = MaybeT $ findExecutable "cabal"++stackExecutable :: MaybeT IO FilePath+stackExecutable = MaybeT $ findExecutable "stack"++biosWorkDir :: FilePath -> MaybeT IO FilePath+biosWorkDir = findFileUpwards (".hie-bios" ==)++cabalWorkDir :: FilePath -> MaybeT IO ()+cabalWorkDir wdir = do+ check <- liftIO $ doesDirectoryExist (wdir </> "dist-newstyle")+ unless check $ fail "No dist-newstyle"++stackWorkDir :: FilePath -> MaybeT IO ()+stackWorkDir wdir = do+ check <- liftIO $ doesDirectoryExist (wdir </> ".stack-work")+ unless check $ fail "No .stack-work"++cabalConfigDir :: FilePath -> MaybeT IO FilePath+cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local")++cabalFileDir :: FilePath -> MaybeT IO FilePath+cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal")++stackConfigDir :: FilePath -> MaybeT IO FilePath+stackConfigDir = findFileUpwards isStack+ where+ isStack name = name == "stack.yaml"++-- | Searches upwards for the first directory containing a file to match+-- the predicate.+findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath+findFileUpwards p dir = do+ cnts <-+ liftIO+ $ handleJust+ -- Catch permission errors+ (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)+ pure+ (findFile p dir)++ case cnts of+ [] | dir' == dir -> fail "No cabal files"+ | otherwise -> findFileUpwards p dir'+ _ : _ -> return dir+ where dir' = takeDirectory dir++-- | Sees if any file in the directory matches the predicate+findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findFile p dir = do+ b <- doesDirectoryExist dir+ if b then getFiles >>= filterM doesPredFileExist else return []+ where+ getFiles = filter p <$> getDirectoryContents dir+ doesPredFileExist file = doesFileExist $ dir </> file++--------------------------------------------------------------------------------++compileTimeGhcWithoutPatchVersion :: Version+compileTimeGhcWithoutPatchVersion =+ let+ versionNumber = __GLASGOW_HASKELL__ :: Int+ (major, minor) = divMod versionNumber 100+ in+ makeVersion [major, minor]++forgetPatchVersion :: Version -> Version+forgetPatchVersion v = case versionBranch v of+ (major:minor:_patches) -> makeVersion [major, minor]+ _ -> v++{-# NOINLINE cwdLock #-}+cwdLock :: MVar ()+cwdLock = unsafePerformIO $ newMVar ()++withCurrentDirectory :: FilePath -> IO b -> IO b+withCurrentDirectory fp m = withMVar cwdLock $ \ _ -> D.withCurrentDirectory fp m
− hdb/Development/Debug/Adapter.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Development.Debug.Adapter where--import Control.Concurrent.MVar-import Control.Concurrent.Chan-import qualified Data.IntSet as IS-import qualified Data.ByteString as BS-import qualified Data.Map as Map-import qualified Data.IntMap as IM-import qualified Data.Text as T-import System.FilePath--import DAP-import qualified GHC-import qualified GHC.Debugger.Interface.Messages as D (Command, Response, RemoteThreadId, VariableReference)-import Network.Socket (PortNumber)--type DebugAdaptor = Adaptor DebugAdaptorState Request-type DebugAdaptorCont = Adaptor DebugAdaptorState ()-type DebugAdaptorX r = Adaptor DebugAdaptorState r ()---- | Debugger state:------ * Keep a mapping from DAP breakpoint ids to internal breakpoint ids--- * Keep the MVar through which synchronous communication with the debugger is done.--- - The debugger main worker writes to this MVar responses (and, for now, events too)--- - The handler worker reads from this MVar and writes them to the client with the 'Adapter'.-data DebugAdaptorState = DAS- { syncRequests :: MVar D.Command- , syncResponses :: MVar D.Response- , nextFreshId :: !Int- , breakpointMap :: Map.Map GHC.InternalBreakpointId BreakpointSet- , stackFrameMap :: IM.IntMap StackFrameIx- , variablesMap :: IM.IntMap VariablesIx- , entryFile :: FilePath- , entryPoint :: String- , entryArgs :: [String]- , projectRoot :: FilePath- , runInTerminalProc :: RunInTerminalProc- -- ^ Potentially a process launched via 'runInTerminal'.- }--type BreakpointId = Int-type BreakpointSet = IS.IntSet--data StackFrameIx = StackFrameIx D.RemoteThreadId Int{-stack frame ix-}- deriving (Eq, Ord)-data VariablesIx = VariablesIx StackFrameIx D.VariableReference--instance MonadFail DebugAdaptor where- fail a = sendError (ErrorMessage (T.pack a)) Nothing------------------------------------------------------------------------------------- * Run in terminal------------------------------------------------------------------------------------- | A process launched via 'runInTerminal', which is attached to a user's terminal-data RunInTerminalProc- -- | We're not using 'runInTerminal', so we didn't request the DAP client to- -- launch a process on the user's terminal.- = NoRunInTerminal-- -- | Instead of launching the external interpreter ourselves, we requested- -- the DAP client to launch the external interpreter process- | RunExternalInterpreterInTerminal- { extInterpPort :: PortNumber- -- ^ The port on which the external interpreter is running.- --- -- The external interpreter is only connected to a port when we launch- -- it ourselves through 'runInTerminal'.- --- -- When 'NoRunInTerminal' but using external-interpreter, we'll still- -- launch the external interpreter but in the default GHC way using the- -- file descriptors directly.- }-- -- | We launched @hdb proxy ...@ on the user's terminal.- --- -- This process will forward all input the user types into the- -- debugger/debuggee process and be forwarded the debuggee's output to print.- --- -- We should always prefer to launch 'RunExternalInterpreterInTerminal'- -- directly, but is not possible if using the internal interpreter.- --- -- See 'Development.Debug.Adapter.Proxy' for more details on @hdb proxy@.- | RunProxyInTerminal- { syncProxyIn :: Chan BS.ByteString- -- ^ Read input to the debuggee from the proxy- , syncProxyOut :: Chan BS.ByteString- -- ^ Write output from the debuggee to the proxy- , syncProxyErr :: Chan BS.ByteString- -- ^ Write stderr from the debuggee to the proxy- , proxyClientReady :: MVar ()- -- ^ Wait for the runInTerminal proxy client to connect to the proxy- -- server (#95).- --- -- Prevent a race where the debug session finishes before the- -- 'runInTerminal' proxy has a chance to connect, so when it does- -- finally try to connect it crashes.- }------------------------------------------------------------------------------------- * Utilities------------------------------------------------------------------------------------- | Transform the given file into a DAP 'Source'. The file may be modified:------ * if the given filepath is absolute, it's returned unchanged--- * if it is relative to the project root, it's returned absolute (with the project root prepended)-fileToSource :: FilePath -> DebugAdaptor Source-fileToSource file = do- root <- projectRoot <$> getDebugSession- fullPath <- if isAbsolute file- then return file- else return (root </> file)- return defaultSource{sourcePath = Just (T.pack fullPath)}---- | Generate fresh Int identifier.-getFreshId :: DebugAdaptor Int-getFreshId = do- nid <- nextFreshId <$> getDebugSession- updateDebugSession $ \s -> s { nextFreshId = nextFreshId s + 1 }- pure nid
− hdb/Development/Debug/Adapter/Breakpoints.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, RecordWildCards, PatternSynonyms #-}-module Development.Debug.Adapter.Breakpoints where--import qualified Data.Text as T-import qualified Data.Map as Map-import qualified Data.IntSet as IS-import Text.Read-import Control.Monad-import Data.Maybe-import System.FilePath ((</>), normalise)--import qualified GHC--import DAP--import GHC.Debugger.Interface.Messages hiding (Command, Response)--import Development.Debug.Adapter-import Development.Debug.Adapter.Interface---- | BreakpointLocations command-commandBreakpointLocations :: DebugAdaptor ()-commandBreakpointLocations = do- BreakpointLocationsArguments{..} <- getArguments- filePath <- fileFromSourcePath breakpointLocationsArgumentsSource-- DidGetBreakpoints mspan <-- sendSync $ GetBreakpointsAt- ModuleBreak { path = filePath- , lineNum = breakpointLocationsArgumentsLine- , columnNum = breakpointLocationsArgumentsColumn- }-- let locs = case mspan of- Nothing -> []- Just SourceSpan {..} ->- [ BreakpointLocation- { breakpointLocationLine = startLine- , breakpointLocationColumn = Just startCol- , breakpointLocationEndLine = Just endLine- , breakpointLocationEndColumn = Just endCol- }- ]-- sendBreakpointLocationsResponse locs---- | Execute adaptor command set module breakpoints-commandSetBreakpoints :: DebugAdaptor ()-commandSetBreakpoints = do- SetBreakpointsArguments {..} <- getArguments- filePath <- fileFromSourcePath setBreakpointsArgumentsSource- let breaks_wanted = fromMaybe [] setBreakpointsArgumentsBreakpoints-- -- Clear existing module breakpoints- DidClearBreakpoints <- sendSync (ClearModBreakpoints filePath)-- -- Set requested ones- breaks <- forM breaks_wanted $ \bp -> do- DidSetBreakpoint bf <-- sendSync $ SetBreakpoint- ModuleBreak { path = filePath- , lineNum = DAP.sourceBreakpointLine bp- , columnNum = DAP.sourceBreakpointColumn bp- }- (readMaybe @Int =<< (T.unpack <$> DAP.sourceBreakpointHitCondition bp))- (T.unpack <$> DAP.sourceBreakpointCondition bp)- (T.unpack <$> DAP.sourceBreakpointLogMessage bp)- registerBreakFound bf-- sendSetBreakpointsResponse (concat breaks)---- | Execute adaptor command set function breakpoints-commandSetFunctionBreakpoints :: DebugAdaptor ()-commandSetFunctionBreakpoints = do- SetFunctionBreakpointsArguments{..} <- getArguments- let- breaks_wanted = setFunctionBreakpointsArgumentsBreakpoints-- -- Clear existing function breakpoints- DidClearBreakpoints <- sendSync ClearFunctionBreakpoints-- -- Set requested ones- breaks <- forM breaks_wanted $ \bp -> do- DidSetBreakpoint bf <-- sendSync $ SetBreakpoint- FunctionBreak { function = T.unpack $ DAP.functionBreakpointName bp }- (readMaybe @Int =<< (T.unpack <$> DAP.functionBreakpointHitCondition bp))- (T.unpack <$> DAP.functionBreakpointCondition bp)- Nothing- registerBreakFound bf-- sendSetFunctionBreakpointsResponse (concat breaks)---- | Execute adaptor command set exception breakpoints-commandSetExceptionBreakpoints :: DebugAdaptor ()-commandSetExceptionBreakpoints = do- SetExceptionBreakpointsArguments{..} <- getArguments-- -- Clear old exception breakpoints- DidRemoveBreakpoint _ <- sendSync (DelBreakpoint OnExceptionsBreak)- DidRemoveBreakpoint _ <- sendSync (DelBreakpoint OnUncaughtExceptionsBreak)-- let breakOnExceptions = BREAK_ON_EXCEPTION `elem` setExceptionBreakpointsArgumentsFilters- let breakOnError = BREAK_ON_ERROR `elem` setExceptionBreakpointsArgumentsFilters-- when breakOnExceptions $ do- DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak Nothing Nothing Nothing)- pure ()-- when breakOnError $ do- DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak Nothing Nothing Nothing)- pure ()-- sendSetExceptionBreakpointsResponse- [ defaultBreakpoint | True <- [breakOnError, breakOnExceptions] ]------------------------------------------------------------------------------------- * Aux-----------------------------------------------------------------------------------pattern BREAK_ON_EXCEPTION, BREAK_ON_ERROR :: T.Text-pattern BREAK_ON_EXCEPTION = "break-on-exception"-pattern BREAK_ON_ERROR = "break-on-error"---- | Turn a haskell-debugger 'BreakFound' into a DAP 'Breakpoint'.------ Additionally, gets a fresh Id for the breakpoint and registers it on the breakpoint map-registerBreakFound :: BreakFound -> DebugAdaptor [DAP.Breakpoint]-registerBreakFound b =- case b of- ManyBreaksFound bs -> concat <$> mapM registerBreakFound bs- BreakNotFound -> pure [ DAP.defaultBreakpoint { DAP.breakpointVerified = False } ]- BreakFoundNoLoc _ch -> pure [ DAP.defaultBreakpoint { DAP.breakpointVerified = True } ]- BreakFound _ch iid ss -> do- source <- fileToSource ss.file- bids <- mapM registerNewBreakpoint iid- pure $ map (\bid -> DAP.defaultBreakpoint- { DAP.breakpointVerified = True- , DAP.breakpointSource = Just source- , DAP.breakpointLine = Just ss.startLine- , DAP.breakpointEndLine = Just ss.endLine- , DAP.breakpointColumn = Just ss.startCol- , DAP.breakpointEndColumn = Just ss.endCol- , DAP.breakpointId = Just bid- }) bids---- | Adds new BreakpointId to the debug adapter mapping-registerNewBreakpoint :: GHC.InternalBreakpointId -> DebugAdaptor BreakpointId-registerNewBreakpoint breakpoint = do- bkpId <- getFreshId- updateDebugSession $ \das@DAS{..} -> das {breakpointMap = Map.insertWith mappend breakpoint (IS.singleton bkpId) breakpointMap}- pure bkpId---- | Get the file from a DAP Source------ TODO: Handles sourceReferences too-fileFromSourcePath :: Source -> DebugAdaptor FilePath-fileFromSourcePath source = do- prjRoot <- projectRoot <$> getDebugSession- let- file = T.unpack $- fromMaybe (error "sourceReference unsupported") $- sourcePath source- return $ normalise $ prjRoot </> file
− hdb/Development/Debug/Adapter/Evaluation.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE RecordWildCards, OverloadedRecordDot, DuplicateRecordFields #-}-module Development.Debug.Adapter.Evaluation where--import qualified Data.Text as T-import qualified Data.Map as M-import qualified Data.IntSet as IS-import qualified Data.IntMap as IM--import DAP--import GHC.Debugger.Interface.Messages-import Development.Debug.Adapter-import Development.Debug.Adapter.Interface-import qualified Development.Debug.Adapter.Output as Output------------------------------------------------------------------------------------- * Executing debuggee------------------------------------------------------------------------------------- | Start executing from entry point------ TODO:--- [ ] Consider using Output events for debuggee evaluation.-startExecution :: DebugAdaptor EvalResult-startExecution = do- DAS{entryFile, entryPoint, entryArgs} <- getDebugSession- let entry- | entryPoint == "main" = MainEntry Nothing- | otherwise = FunctionEntry entryPoint- DidExec er <- sendSync DebugExecution{entryPoint = entry, entryFile, runArgs = entryArgs}- return er------------------------------------------------------------------------------------- * Eval------------------------------------------------------------------------------------- | Command for evaluation (includes evaluation-on-hover)-commandEvaluate :: DebugAdaptor ()-commandEvaluate = do- EvaluateArguments {evaluateArgumentsFrameId=_todo{-evaluate expression in specific frame-}, ..} <- getArguments-- let simpleEvalResp res ty = EvaluateResponse- { evaluateResponseResult = res- , evaluateResponseType = ty- , evaluateResponsePresentationHint = Nothing- , evaluateResponseVariablesReference = 0- , evaluateResponseNamedVariables = Nothing- , evaluateResponseIndexedVariables = Nothing- , evaluateResponseMemoryReference = Nothing- }-- DidEval er <- sendSync (DoEval (T.unpack evaluateArgumentsExpression))- case er of- EvalStopped{} -> error "impossible, execution is resumed automatically for 'DoEval'"- EvalAbortedWith e ->- -- Evaluation failed, we report it but don't terminate.- sendEvaluateResponse (simpleEvalResp (T.pack e) (T.pack ""))- EvalException {resultVal, resultType} ->- sendEvaluateResponse (simpleEvalResp (T.pack resultVal) (T.pack resultType))- EvalCompleted{resultVal, resultType, resultSourceKind, resultStructureRef} -> do- varIx <- case resultStructureRef of- NoVariables -> pure 0- LocalVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"- ModuleVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"- GlobalVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"- SpecificVariable _ -> do- varId <- getFreshId- updateDebugSession $ \s ->- s { variablesMap =- IM.insert varId- (VariablesIx (StackFrameIx (RemoteThreadId (-1)) (-1) {- shouldn't be a problem bc it's not Local/Module/Global vars -}) resultStructureRef)- s.variablesMap- }- pure varId-- let orIfNoResult !x !y- | Just IsStmt <- resultSourceKind = y- | resultType == "()" = y- | otherwise = x-- sendEvaluateResponse EvaluateResponse- { evaluateResponseResult = T.pack resultVal `orIfNoResult` T.empty- , evaluateResponseType = T.pack resultType `orIfNoResult` T.empty- , evaluateResponsePresentationHint = Nothing- , evaluateResponseVariablesReference = varIx `orIfNoResult` 0- , evaluateResponseNamedVariables = Nothing- , evaluateResponseIndexedVariables = Nothing- , evaluateResponseMemoryReference = Nothing- }------------------------------------------------------------------------------------- * Utils------------------------------------------------------------------------------------- | Handle an EvalResult by sending a stopped or exited event.------ In particular, the result of evaluation is ignored by this function.--- The 'EvaluateRequest' handler inspects the EvalResult itself and reports on the result.-handleEvalResult :: Bool {-^ Whether we are "stepping" -} -> EvalResult -> DebugAdaptor ()-handleEvalResult stepping er = case er of- EvalAbortedWith e -> do- Output.console (T.pack e)- sendTerminatedEvent defaultTerminatedEvent- sendExitedEvent (ExitedEvent 43)- EvalCompleted{resultVal, resultType} -> do- Output.console (T.pack $ "Evaluation returned: " ++ resultVal ++ " :: " ++ resultType)- sendTerminatedEvent defaultTerminatedEvent- sendExitedEvent (ExitedEvent 0)- EvalException{resultVal, resultType} -> do- Output.stderr (T.pack $ "Uncaught exception of type " ++ resultType ++ " was thrown!")- Output.stderr (T.pack resultVal)- sendTerminatedEvent defaultTerminatedEvent- sendExitedEvent (ExitedEvent 42)- EvalStopped {breakId = Nothing, breakThread} ->- sendStoppedEvent- defaultStoppedEvent {- stoppedEventAllThreadsStopped = True- , stoppedEventReason = StoppedEventReasonException- , stoppedEventHitBreakpointIds = []- , stoppedEventThreadId = Just $ remoteThreadIntRef breakThread- }- EvalStopped {breakId = Just bid, breakThread} -> do- DAS{breakpointMap} <- getDebugSession- sendStoppedEvent- defaultStoppedEvent {- stoppedEventAllThreadsStopped = True- -- could be more precise here by saying "function breakpoint" rather than always "breakpoint"- , stoppedEventReason- = if stepping then StoppedEventReasonStep- else StoppedEventReasonBreakpoint- , stoppedEventHitBreakpointIds- = maybe [] IS.toList (M.lookup bid breakpointMap)- , stoppedEventThreadId = Just $ remoteThreadIntRef breakThread- }
− hdb/Development/Debug/Adapter/ExceptionInfo.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-module Development.Debug.Adapter.ExceptionInfo- ( commandExceptionInfo- ) where--import qualified Data.Text as T--import DAP--import Development.Debug.Adapter-import Development.Debug.Adapter.Interface-import qualified GHC.Debugger.Interface.Messages as D--commandExceptionInfo :: DebugAdaptor ()-commandExceptionInfo = do- ExceptionInfoArguments{..} <- getArguments- let remoteThread = D.RemoteThreadId exceptionInfoArgumentsThreadId- D.GotExceptionInfo info <- sendSync (D.GetExceptionInfo remoteThread)- sendExceptionInfoResponse (toDAPExceptionInfo info)---- | Convert the debugger's 'ExceptionInfo' into a DAP 'ExceptionInfoResponse'.-toDAPExceptionInfo :: D.ExceptionInfo -> ExceptionInfoResponse-toDAPExceptionInfo info =- let typeNameStr = exceptionTypeName info- typeNameText = T.pack typeNameStr- messageStr = exceptionMessage info- messageText = T.pack <$> messageStr- in ExceptionInfoResponse- { exceptionInfoResponseExceptionId = typeNameText- , exceptionInfoResponseDescription = messageText- , exceptionInfoResponseBreakMode = Always- , exceptionInfoResponseDetails = Just (exceptionInfoToDetails (Just "_exception") info)- }--exceptionInfoToDetails :: Maybe T.Text -> D.ExceptionInfo -> ExceptionDetails-exceptionInfoToDetails evalName info@D.ExceptionInfo{..} =- let typeNameText = T.pack (exceptionTypeName info)- fullTypeNameText = T.pack (exceptionFullTypeName info)- stackTraceText = T.pack <$> exceptionInfoContext- innerDetails = map (exceptionInfoToDetails Nothing) exceptionInfoInner- innerField = if null innerDetails then Nothing else Just innerDetails- in defaultExceptionDetails- { exceptionDetailsMessage = exceptionMessage info- , exceptionDetailstypeName = Just typeNameText- , exceptionDetailsFullTypeName = Just fullTypeNameText- , exceptionDetailsStackTrace = stackTraceText- , exceptionDetailsInnerException = innerField- , exceptionDetailsEvaluateName = evalName- }--exceptionTypeName :: D.ExceptionInfo -> String-exceptionTypeName D.ExceptionInfo{..}- | null exceptionInfoTypeName = "Exception"- | otherwise = exceptionInfoTypeName--exceptionFullTypeName :: D.ExceptionInfo -> String-exceptionFullTypeName info@D.ExceptionInfo{..}- | null exceptionInfoFullTypeName = exceptionTypeName info- | otherwise = exceptionInfoFullTypeName--exceptionMessage :: D.ExceptionInfo -> Maybe String-exceptionMessage D.ExceptionInfo{..}- | null exceptionInfoMessage = Nothing- | otherwise = Just exceptionInfoMessage
− hdb/Development/Debug/Adapter/Exit.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE LambdaCase #-}---- | Module concerning with reporting failures and exiting cleanly the--- debugging process. An overview of covered exit modes:------ == 1. The top-level DebugAdaptor process--- * Command Terminate--- * Command Disconnect--- * DebugAdaptor crashes while executing (handled by DAP library?)--- * One of the threads launched by registerNewDebugSession crash------ == 2. The haskell-debugger process--- * The debugger crashes while initializing (e.g. while compiling or when discovering flags)--- * The debugger crashes while executing a request------ == 3. The debuggee loaded in haskell-debugger and runs--- * The debuggee terminates successfully--- * The debuggee terminates with an exception--- * The debuggee crashes in another way------ Notes:--- * @'destroyDebugSession'@ kills all threads started for this session with @'registerNewDebugSession'@.-module Development.Debug.Adapter.Exit where--import Control.Monad.Except-import Control.Monad.IO.Class-import DAP-import Development.Debug.Adapter---- | Command terminate (1a)------ Terminate the *debuggee* gracefully-commandTerminate :: DebugAdaptor ()-commandTerminate = do- destroyDebugSession -- kills debugger GHC session (which handles stopping the debuggee ext-interp too)- sendTerminateResponse- sendTerminatedEvent (TerminatedEvent False) -- we're done debugging now!---- | Command disconnect (1b)------ Terminate the debuggee (and any child processes) forcefully.-commandDisconnect :: DebugAdaptor ()-commandDisconnect = do- -- kills debugger GHC session (which handles stopping the debuggee ext-interp too)- -- ignore error if session has already been destroyed (e.g. client sends disconnect after terminate)- destroyDebugSession `catchError` \ e -> liftIO $ putStrLn ("terminateSessionCleanly: ignoring missing session: " ++ show e)- sendDisconnectResponse
− hdb/Development/Debug/Adapter/Exit/Helpers.hs
@@ -1,47 +0,0 @@-module Development.Debug.Adapter.Exit.Helpers where--import DAP-import Data.Function-import System.IO-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.Text as T-import qualified Data.Text.IO as T--import Development.Debug.Adapter-import qualified Development.Debug.Adapter.Output as Output----- Exit Cleanly ------------------------------------------------------------------- | Outputs a message notification ('Output.important'), sends a terminated--- event, destroys the debug session, and dies.------ ::WARNING::------ This function should not be called if the debugsession with the debugger--- threads haven't yet been registered because it WILL block on the call to--- @'destroyDebugSession'@.-exitCleanupWithMsg- :: Handle- -- ^ Handle to finalize reading as OutputEvents before exiting (but after- -- killing the output thread with @destroyDebugSession@)- -> String- -- ^ Error message, logged with notification- -> DebugAdaptor ()-exitCleanupWithMsg final_handle msg = do- 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- terminateWithError msg---- | Abruptly terminate a session in the middle of a Request/Response cycle by--- sending a Terminated event (meaning the debug session is over), destroying--- the debug session threads, and replying to the response with 'ErrorResponse'-terminateWithError :: String -> DebugAdaptor ()-terminateWithError msg = do- Output.important (T.pack msg)- destroyDebugSession- sendTerminatedEvent (TerminatedEvent False)- sendError (ErrorMessage (T.pack msg)) Nothing
− hdb/Development/Debug/Adapter/Handles.hs
@@ -1,136 +0,0 @@-{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, CPP, DeriveAnyClass, DeriveGeneric, DerivingVia, LambdaCase, RecordWildCards #-}-module Development.Debug.Adapter.Handles- ( handleLogger- , withInterceptedStdout- , withInterceptedStderr- , withInterceptedStdoutForwarding- , withInterceptedStderrForwarding- ) where--import DAP--import System.IO ()-import DAP.Log-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Control.Concurrent.MVar-import GHC.IO.Handle.FD-import GHC.IO.Handle-import System.Process-import Control.Exception-import Control.Concurrent.Async--handleLogger :: Handle -> IO (LogAction IO T.Text)-handleLogger out_handle = do- handleLock <- newMVar ()- return $ LogAction $ \msg -> do- withLock handleLock $ do- T.hPutStrLn out_handle msg---- | Redirect stdout globally, run the continuation with a bypass handle for real stdout.-withInterceptedStdout :: (Handle -- ^ realStdout, write to this handle sends output to stdout- -> Handle -- ^ interceptedStdout, stdout captured from attempting to write to stdout handle.- -> IO ()) -> IO ()-withInterceptedStdout k = do- withPipe $ \readOutHandle writeOutHandle -> do- hSetBuffering readOutHandle NoBuffering- hSetBuffering writeOutHandle LineBuffering- withStdoutBypass writeOutHandle $ \realStdout -> do- k realStdout readOutHandle---- | Redirect stderr globally, run the continuation with a bypass handle for real stderr.-withInterceptedStderr :: (Handle -- ^ realStderr, write to this handle sends output to stderr- -> Handle -- ^ interceptedStderr, stdout captured from attempting to write to stderr handle.- -> IO ()) -> IO ()-withInterceptedStderr k = do- withPipe $ \readErrHandle writeErrHandle -> do- hSetBuffering readErrHandle NoBuffering- hSetBuffering writeErrHandle LineBuffering- withStderrBypass writeErrHandle $ \realStderr -> do- k realStderr readErrHandle---- | Intercept stderr, and spawn a thread which forwards the input--- onwards using the supplied IO action.-withInterceptedStderrForwarding :: (T.Text -> IO ())- -- ^ All stderr input that is intercepted is forwarded to this thread- -> (Handle -> IO ())- -- ^ The continuation receives the REAL STDERR- -> IO ()-withInterceptedStderrForwarding write_stderr k = do- withInterceptedStderr $ \realStderr interceptedStderr -> do- withAsync (forwardingThread write_stderr interceptedStderr) $ \_ -> do- k realStderr---- | Intercept stdout, and spawn a thread which forwards the input--- onwards using the supplied IO action.-withInterceptedStdoutForwarding :: (T.Text -> IO ())- -- ^ All stdout input that is intercepted is forwarded to this thread- -> (Handle -> IO ())- -- ^ The continuation receives the REAL STDOUT- -> IO ()-withInterceptedStdoutForwarding write_stdout k = do- withInterceptedStdout $ \realStdout interceptedStdout -> do- withAsync (forwardingThread write_stdout interceptedStdout) $ \_ ->- k realStdout------------------------------------------------------------------------------------- Auxiliary------------------------------------------------------------------------------------- | Temporarily bypass the intercepted stdout/stderr to write directly to the original stdout/stderr.--- This is useful for debugging or for sending output that should not be intercepted.-withStdoutBypass, withStderrBypass- :: Handle- -> (Handle -> IO r)- -> IO r-withStdoutBypass interceptH = withHandleBypass stdout interceptH-withStderrBypass interceptH = withHandleBypass stderr interceptH---- | Capture all output written to a given handle and redirect it to the other--- one; the continuation can use the "real" copy of the first handle to write--- to it while bypassing the redirection.------ This is useful for debugging or for sending output that should not be intercepted.-withHandleBypass :: Handle- -- ^ Text written to this handle...- -> Handle- -- ^ ...will be redirected to this handle- -> (Handle -> IO r)- -- ^ Continuation receives as an argument a "real" copy of the handle that is now being redirected.- -- If you write to this Handle, it will write to the original one and *bypass* the redirection (ie it will not be redirected)- -> IO r-withHandleBypass originalHandle interceptWriteHandle action =- bracket setup clean action- where- setup = do- realHandle <- hDuplicate originalHandle- hFlush originalHandle- hDuplicateTo interceptWriteHandle originalHandle- hSetBuffering originalHandle LineBuffering- return realHandle-- clean realHandle = do- hFlush originalHandle- hDuplicateTo realHandle originalHandle- hClose realHandle---- | Thread to read from the intercepted stdout pipe and forward onwards-forwardingThread :: (T.Text -> IO ()) -> Handle -> IO ()-forwardingThread write_action fromPipe = loop- where- loop = do- eof <- hIsEOF fromPipe- if eof- then return ()- else do- line <- T.hGetLine fromPipe- write_action line- loop--withPipe :: (Handle -> Handle -> IO r) -> IO r-withPipe action = bracket createPipe closeBoth (uncurry action)- where- closeBoth (readH, writeH) = do- hClose readH- hClose writeH-
− hdb/Development/Debug/Adapter/Init.hs
@@ -1,431 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}---- | TODO: This module should be called Launch.-module Development.Debug.Adapter.Init where--#if !MIN_VERSION_ghc(9,15,0)--- no longer needs to be imported from here in 9.15-import GHC.Conc.Sync (labelThread)-#endif--import GHC.IO.Handle-import System.Process-import qualified Data.ByteString as BS-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Encoding as T-import qualified System.Process as P-import Control.Exception (displayExceptionWithInfo)-import Control.Monad.Except-import Control.Monad.Trans-import Data.Function-import Data.Functor-import Data.Maybe-import Data.UUID.V4 qualified as UUID-import System.IO-import GHC.IO.Encoding-import Control.Monad.Catch-import Control.Exception (throwIO, IOException)-import Control.Concurrent-import Control.Monad-import Data.Aeson as Aeson-import GHC.Generics-import System.Directory-import System.FilePath-import Data.Functor.Contravariant--import Development.Debug.Adapter-import Colog.Core as Logger-import qualified Development.Debug.Adapter.Output as Output--import GHC.Utils.Logger (defaultLogActionWithHandles)-import GHC.Debugger.Utils (forwardHandleToLogger)-import qualified GHC.Debugger as Debugger-import qualified GHC.Debugger.Monad as Debugger-import qualified GHC.Debugger.Interface.Messages as D (Command, Response)-import GHC.Debugger.Interface.Messages hiding (Command, Response)--import DAP-import Development.Debug.Adapter.Handles-import Development.Debug.Session.Setup-import Development.Debug.Adapter.Proxy-import System.Environment-import Network.Socket (socketPort)-import qualified Network.Socket as Socket------------------------------------------------------------------------------------- * Client------------------------------------------------------------------------------------- | Client arguments are custom for launch-data LaunchArgs- = LaunchArgs- { __sessionId :: Maybe String- -- ^ SessionID, set by VSCode client- , projectRoot :: Maybe FilePath- -- ^ Absolute path to the project root- , entryFile :: Maybe FilePath- -- ^ The file with the entry point e.g. @app/Main.hs@- , entryPoint :: Maybe String- -- ^ Either @main@ or a function name- , entryArgs :: Maybe [String]- -- ^ The arguments to either set as environment arguments when @entryPoint = "main"@- -- or function arguments otherwise.- , extraGhcArgs :: Maybe [String]- -- ^ Additional arguments to pass to the GHC invocation inferred by hie-bios for this project- } deriving stock (Show, Eq, Generic)- deriving anyclass FromJSON------------------------------------------------------------------------------------- * Logging-----------------------------------------------------------------------------------data DAPLog- = DAPSessionSetupLog (WithSeverity SessionSetupLog)- | DAPDebuggerLog Debugger.DebuggerLog- | RunProxyServerLog (WithSeverity T.Text)------------------------------------------------------------------------------------- * Launch Debugger------------------------------------------------------------------------------------- | Initialize debugger------ Returns @()@ if successful, throws @InitFailed@ otherwise-initDebugger :: LogAction IO DAPLog -> Bool -> Bool- -> LaunchArgs -> DebugAdaptor ()-initDebugger l supportsRunInTerminal preferInternalInterpreter- LaunchArgs{ __sessionId- , projectRoot = givenRoot- , entryFile = entryFileMaybe- , entryPoint = fromMaybe "main" -> entryPoint- , entryArgs = fromMaybe [] -> entryArgs- , extraGhcArgs = fromMaybe [] -> extraGhcArgs- } = do- syncRequests <- liftIO newEmptyMVar- syncResponses <- liftIO newEmptyMVar-- entryFile <- case entryFileMaybe of- Nothing -> throwError ("Missing \"entryFile\" key in debugger configuration", Nothing)- Just ef -> pure ef-- projectRoot <- maybe (liftIO getCurrentDirectory) pure givenRoot-- -- Create a pipe to which messages to send to the DAP console are written and read.- -- todo: This could just be a Haskell channel now...- (readDAPOutput, writeDAPOutput) <- liftIO P.createPipe- liftIO $ do- hSetBuffering readDAPOutput LineBuffering- hSetBuffering writeDAPOutput NoBuffering- -- GHC output uses utf8- hSetEncoding readDAPOutput utf8- hSetEncoding writeDAPOutput utf8- setLocaleEncoding utf8-- dapLogger <- liftIO $ handleLogger writeDAPOutput-- let hieBiosLogger = contramap DAPSessionSetupLog l <> logHieBiosToDAP-- logHieBiosToDAP = LogAction $ \case- WithSeverity msg sev- | sev >= Info -> dapLogger <& renderSessionSetupLog msg- | otherwise -> mempty-- liftIO (runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile)) >>= \case- Left e -> throwError (ErrorMessage (T.pack e), Nothing)- Right (Left e) -> throwError (ErrorMessage (T.pack e), Nothing)- Right (Right flags) -> do-- let- nextFreshId = 0- breakpointMap = mempty- stackFrameMap = mempty- variablesMap = mempty-- mkRunInTerminalProc- | not supportsRunInTerminal- = pure NoRunInTerminal- | not preferInternalInterpreter- = do- sock <- openSocketAvailablePort- port <- socketPort sock- -- Close socket again to make sure we can open the server socket- -- later again.- Socket.close sock- pure RunExternalInterpreterInTerminal- { extInterpPort = port- }- | otherwise- = do- (syncProxyIn, syncProxyOut, syncProxyErr)- <- (,,) <$> newChan <*> newChan <*> newChan- proxyClientReady <- newEmptyMVar- pure RunProxyInTerminal{..}-- runInTerminalProc <- liftIO mkRunInTerminalProc-- dbgLog <- liftIO $- createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc-- (runInTerminalThreads, afterRegisterActions) <-- mkRunInTerminalThreads l runInTerminalProc preferInternalInterpreter-- let- defaultRunConf = Debugger.RunDebuggerSettings- { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap- , supportsANSIHyperlinks = False -- VSCode does not support this- , preferInternalInterpreter- , externalInterpreterCustomProc = case runInTerminalProc of- RunExternalInterpreterInTerminal{extInterpPort}- -> Right extInterpPort- _ -> Left CreatePipe -- if not runInTerminal, just create a new pipe for stdin- }- absEntryFile = normalise $ projectRoot </> entryFile- daState = DAS{entryFile=absEntryFile,..}-- sessionId <- liftIO $ maybe (("debug-session:" <>) . T.show <$> UUID.nextRandom) (pure . T.pack) __sessionId- registerNewDebugSession sessionId daState $- [ debuggerThread dbgLog flags extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses- , \withAdaptor -> forwardHandleToLogger readDAPOutput $- LogAction (\msg -> withAdaptor (Output.neutral msg))- ]- ++- runInTerminalThreads-- afterRegisterActions---- | Additional threads to register for this session depending on the process--- we're running through `runInTerminal` (see 'RunInTerminalProc').-mkRunInTerminalThreads- :: LogAction IO DAPLog- -> RunInTerminalProc- -> Bool -- ^ Use internal interpreter- -> DebugAdaptor ([(DebugAdaptorCont () -> IO ()) -> IO ()], DebugAdaptor ())- -- ^ Threads to register in this debug session and additional commands to- -- run after registering the session.--mkRunInTerminalThreads _ NoRunInTerminal useInternalInterp- -- Not using the terminal proxy, but we still want to output our own- -- stdout/err (from the internal interpreter) as console events.- | True <- useInternalInterp- = pure ([ stdoutCaptureThread Nothing, stderrCaptureThread Nothing ], pure ())-- | otherwise- = pure ([], pure ())--mkRunInTerminalThreads _ RunExternalInterpreterInTerminal{..} _- -- No additional bookkeeping is needed in this case because GHC will- -- naturally have to wait for the external interpreter in order to start execution- = do- thisProg <- liftIO getExecutablePath -- run the same `hdb` executable in `proxy` mode- pure ([],- sendRunInTerminalReverseRequest- RunInTerminalRequestArguments- { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated- , runInTerminalRequestArgumentsTitle = Nothing- , runInTerminalRequestArgumentsCwd = ""- , runInTerminalRequestArgumentsArgs =- [T.pack thisProg, "external-interpreter", "--port", T.pack (show extInterpPort)]- , runInTerminalRequestArgumentsEnv = Nothing- , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False- })--mkRunInTerminalThreads l RunProxyInTerminal{..} _- = do- (serverPort, serverProxyThread) <-- mkServerSideHdbProxy (contramap RunProxyServerLog l)- syncProxyIn syncProxyOut syncProxyErr proxyClientReady-- pure (- [ ($ serverProxyThread)-- -- Setup capturing of the process' own stdout and forwarding of the process' own stdin,- -- but only because we're using the internal interpreter!- , stdinForwardThread syncProxyIn- , stdoutCaptureThread (Just syncProxyOut)- , stderrCaptureThread (Just syncProxyErr)- ],-- -- When using the internal interpreter and 'runInTerminal' is supported- -- (the 'RunProxyInTerminal' case), we ask the DAP client to launch the- -- `hdb proxy` attached to the user's terminal. The proxy forwards- -- input/output from the user terminal to the debugger+debuggee shared process- sendRunProxyInTerminal serverPort- )---- | The main debugger thread launches a GHC.Debugger session.------ Then, forever:--- 1. Reads commands from the given 'D.Command' 'MVar'--- 2. Executes the command with `execute`--- 3. Writes responses to the given 'D.Response' 'MVar'------ Concurrently, it reads from the process's stderr forever and outputs it through OutputEvents.----debuggerThread :: LogAction IO Debugger.DebuggerLog- -> HieBiosFlags -- ^ GHC Invocation flags- -> [String] -- ^ Extra ghc args- -> FilePath- -> Debugger.RunDebuggerSettings -- ^ Settings for running the debugger- -> MVar D.Command -- ^ Read commands- -> MVar D.Response -- ^ Write reponses- -> (DebugAdaptorCont () -> IO ())- -- ^ Allows unlifting DebugAdaptor actions to IO. See 'registerNewDebugSession'.- -> IO ()-debuggerThread l HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do-- -- Log haskell-debugger invocation- withAdaptor $- Output.console $ T.pack $- "libdir: " <> libdir <> "\n" <>- "units: " <> unwords units <> "\n" <>- "args: " <> unwords (ghcInvocation ++ extraGhcArgs)-- Debugger.runDebugger l rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do- liftIO $ do- tid <- myThreadId- labelThread tid "Main Debugger Thread"- let loop = do- req <- takeMVar requests & liftIO- resp <- (Debugger.execute req <&> Right)- `catch` \(e :: SomeException) -> do- pure (Left (displayExceptionWithInfo e))- case resp of- Right x -> do- liftIO (putMVar replies x)- loop- Left m ->- -- don't loop in this case! just exit.- liftIO $ putMVar replies (Aborted ("Aborted debugger thread: " ++ m))- loop------------------------------------------------------------------------------------- * Logging----------------------------------------------------------------------------------{--Note [Debugger, debuggee, and DAP logs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Specification for the logger given to `Debugger`:--1. All -v3 DebuggerLog and GHCLog messages go to the normal stdout/stderr (this shows up in- the OUTPUT console in VSCode, without having to send special messages)--2. All -v1 DebuggerLog, GHCLog, and all LogDebuggeeOut and LogDebuggeeErr output- goes to the DAP console (this is DEBUG CONSOLE in VSCode)--3. All LogDebuggeeOut and LogDebuggeeErr output are forwarded to the proxy if- the proxy is enabled.--}---- See Note [Debugger, debuggee, and DAP logs]-createDebuggerLogger- :: LogAction IO DAPLog- -> LogAction IO T.Text -- ^ Logger that writes to to DAP output- -> Handle -- ^ Handle to DAP output- -> RunInTerminalProc- -> IO (LogAction IO Debugger.DebuggerLog)-createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc = do- return $- -- (1) (all output is logged to normal logger)- contramap DAPDebuggerLog l <>- -- (2) and (3) (log relevant output to DAP handle)- LogAction (\case- Debugger.DebuggerLog sev msg- | sev >= Info -> do- dapLogger <& T.pack (show msg)- Debugger.GHCLog logflags msg_class srcSpan msg ->- defaultLogActionWithHandles writeDAPOutput writeDAPOutput logflags msg_class srcSpan msg- Debugger.LogDebuggeeOut txt -> debuggeeOut dapLogger msyncProxyOut txt- Debugger.LogDebuggeeErr txt -> debuggeeOut dapLogger msyncProxyErr txt- _ -> pure () -- don't log other messages, already logged to (1)- )- where- debuggeeOut l' mproxyChan txt = do- -- (2)- l' <& txt- -- (3)- case mproxyChan of- Nothing -> pure ()- Just proxyChan ->- writeChan proxyChan $- T.encodeUtf8 (txt <> "\n")-- (msyncProxyOut, msyncProxyErr)- | RunProxyInTerminal{syncProxyOut, syncProxyErr} <- runInTerminalProc- = (Just syncProxyOut, Just syncProxyErr)- | otherwise- = (Nothing, Nothing)------------------------------------------------------------------------------------- * Capturing stdout, stderr, and writing to self stdin------------------------------------------------------------------------------------- | Hijack the current process stdin and forward to it the messages from the given channel-stdinForwardThread :: Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()-stdinForwardThread syncIn _withAdaptor = do- tid <- myThreadId- labelThread tid "Stdin Forward Thread"-- -- We need to hijack stdin to write to it-- -- 1. Create a new pipe from writeEnd->readEnd- (readEnd, writeEnd) <- createPipe-- -- 2. Substitute the read-end of the pipe by stdin- _ <- hDuplicateTo readEnd stdin- hClose readEnd -- we'll never need to read from readEnd-- forever $ do- i <- readChan syncIn- -- 3. Write to write-end of the pipe- BS.hPut writeEnd i >> hFlush writeEnd---- | This thread captures stdout from the debuggee and sends it to the client.--- NOTE, redirecting the stdout handle is a process-global operation. So this thread--- will capture ANY stdout the debuggee emits. Therefore you should never directly--- write to stdout, but always write to the appropiate handle.-stdoutCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO ()-stdoutCaptureThread msyncOut withAdaptor = do- tid <- myThreadId- labelThread tid "Stdout Capture Thread"- withInterceptedStdout $ \_ interceptedStdout -> do- forever $ do- line <- liftIO $ T.hGetLine interceptedStdout- case msyncOut of- Nothing -> pure ()- Just syncOut -> writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n")-- -- Always output to Debug Console- catch- (withAdaptor $ Output.stdout line)- (\(_ :: IOException) ->- throwIO (FailedToWriteToAdaptor line))---- | Like 'stdoutCaptureThread' but for stderr-stderrCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO ()-stderrCaptureThread msyncErr withAdaptor = do- tid <- myThreadId- labelThread tid "Stderr Capture Thread"- withInterceptedStderr $ \_ interceptedStderr -> do- forever $ do- line <- liftIO $ T.hGetLine interceptedStderr- case msyncErr of- Nothing -> pure ()- Just syncErr -> writeChan syncErr $ T.encodeUtf8 (line <> "\n")-- -- Always output to Debug Console- catch- (withAdaptor $ Output.stderr line)- (\(_ :: IOException) ->- 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
− hdb/Development/Debug/Adapter/Interface.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE LambdaCase, RecordWildCards #-}-module Development.Debug.Adapter.Interface where--import qualified Data.Text as T-import Control.Concurrent.MVar-import Control.Monad.IO.Class--import DAP--import GHC.Debugger.Interface.Messages as D-import Development.Debug.Adapter-import qualified Development.Debug.Adapter.Output as Output---- | Synchronously send a command to the debugger and await a response-sendSync :: D.Command -> DebugAdaptor Response-sendSync cmd = do- DAS{..} <- getDebugSession- liftIO $ putMVar syncRequests cmd- liftIO (takeMVar syncResponses) >>= handleAbort---- | Sends a command to the debugger, then runs the given action, and only after running the action it waits for the result of the debugger-sendInterleaved :: D.Command -> DebugAdaptor () -> DebugAdaptor Response-sendInterleaved cmd action = do- DAS{..} <- getDebugSession- liftIO $ putMVar syncRequests cmd- () <- action- liftIO (takeMVar syncResponses) >>= handleAbort--handleAbort :: Response -> DebugAdaptor Response-handleAbort (Aborted e) = do- Output.console (T.pack e)- sendTerminatedEvent (TerminatedEvent False)- destroyDebugSession -- kill this debu session's threads- -- reply still in thia connection with "ErrorResponse" to pending request- sendError (ErrorMessage (T.pack e)) Nothing-handleAbort r = return r
− hdb/Development/Debug/Adapter/Output.hs
@@ -1,55 +0,0 @@--- | Meant to be imported qualified:------ @--- import qualified Development.Debugger.Output as Output------ Output.console "Category used for informational output from debugger, not debuggee"--- Output.stdout "Standard out of debuggee"--- Output.stderr "Standard err of debuggee"--- ...--- @------ TODO:--- [ ] ANSI Styling of output console messages?----module Development.Debug.Adapter.Output- ( neutral, console, important, stdout, stderr )- where--import Data.Text (Text)-import qualified Data.Text as T-import DAP (sendOutputEvent, defaultOutputEvent, OutputEvent(..), OutputEventCategory(..))-import Development.Debug.Adapter---- | Default 'OutputEvent' without an explicit category.-neutral :: Text -> DebugAdaptorX r-neutral = send Nothing---- | Show the output in the client's default message UI, e.g. a 'debug--- console'. This category should only be used for informational output from--- the debugger (as opposed to the debuggee).-console :: Text -> DebugAdaptorX r-console = send $ Just OutputEventCategoryConsole---- | 'important': A hint for the client to show the output in the client's UI--- for important and highly visible information, e.g. as a popup notification.--- This category should only be used for important messages from the debugger--- (as opposed to the debuggee).-important :: Text -> DebugAdaptorX r-important = send $ Just OutputEventCategoryImportant---- | Show the output as normal program output from the debuggee.-stdout :: Text -> DebugAdaptorX r-stdout = send $ Just OutputEventCategoryStdout---- | Show the output as error program output from the debuggee.-stderr :: Text -> DebugAdaptorX r-stderr = send $ Just OutputEventCategoryStderr---- | Generic send output event given the category-send :: Maybe OutputEventCategory -> Text -> DebugAdaptorX r-send cat txt = do- sendOutputEvent defaultOutputEvent- { outputEventCategory = cat- , outputEventOutput = txt <> T.pack "\n"- }
− hdb/Development/Debug/Adapter/Proxy.hs
@@ -1,201 +0,0 @@-{-# LANGUAGE BlockArguments, OverloadedStrings, DerivingStrategies, OrPatterns #-}-{-# LANGUAGE NondecreasingIndentation #-}--- | Run the proxy mode, which forwards stdin/stdout to/from the DAP server and--- is displayed in a terminal in the DAP client using 'runInTerminal'.------ Note: the proxy program is only launched when 'runInTerminal' is supported--- and we're using the internal interpreter (--internal-interpreter).------ If the external interpreter is being used (the default), we launch the--- external interpreter directly with 'runInTerminal' and don't need the proxy--- at all.-module Development.Debug.Adapter.Proxy- ( mkServerSideHdbProxy- , runInTerminalHdbProxy- , sendRunProxyInTerminal- , openSocketAvailablePort- ) where--#if !MIN_VERSION_ghc(9,15,0)--- no longer needs to be imported in 9.15-import GHC.Conc.Sync (labelThread)-#endif--import DAP--import Control.Concurrent.Async-import System.IO-import System.Exit (exitSuccess)-import System.Environment-import System.FilePath-import Control.Exception.Base-import Control.Monad-import Control.Monad.IO.Class-import Control.Concurrent-import qualified Data.List.NonEmpty as NE--import qualified Data.Text as T-import Network.Socket hiding (Debug)-import Network.Run.TCP-import qualified Network.Socket.ByteString as NBS-import qualified Data.ByteString.Char8 as BS8-import qualified Data.HashMap.Strict as H--import Colog.Core-import Development.Debug.Adapter-import qualified Control.Exception as E---- | Fork a new thread to run the server-side of the proxy.------ 1. To setup:--- Ask the DAP client to launch a process running @hdb proxy --port <port>@--- by sending a 'runInTerminal' DAP reverse request. This is done outside of--- this function by signaling the given MVar (this is the case because we cannot use `network` with `DebugAdaptor`------ 2. In a loop,--- 2.1 Read stdin from the socket and push it to a Chan--- 2.1 Read from a stdout Chan and write to the socket-mkServerSideHdbProxy :: LogAction IO (WithSeverity T.Text)- -> Chan BS8.ByteString- -> Chan BS8.ByteString- -> Chan BS8.ByteString- -> MVar ()- -> Adaptor DebugAdaptorState r (PortNumber, Adaptor DebugAdaptorState s ())-mkServerSideHdbProxy l dbIn dbOut dbErr client_conn_signal = do-- sock <- liftIO $ openSocketAvailablePort- port <- liftIO $ socketPort sock-- return $ (port,) $ liftIO $ do- ignoreIOException $ do- myThreadId >>= \tid -> labelThread tid "Debug/Adapter/Proxy: TCP Server"- runTCPServerWithSocket' sock $ \scket -> do-- infoMsg (T.pack $ "Connected to client on port " ++ show port ++ "...!")- putMVar client_conn_signal () -- signal ready (see #95)-- race_- (race_- (-- Read stdout from chan and write to socket- ignoreIOException $ do- labelMe "Debug/Adapter/Proxy: Forward stdout"- forever $ do- bs <- readChan dbOut- debugMsg (T.pack $ "Writing to socket: " ++ BS8.unpack bs)- NBS.sendAll scket bs)- (-- Read stderr from chan and write to socket- ignoreIOException $ do- labelMe "Debug/Adapter/Proxy: Forward stderr"- forever $ do- bs <- readChan dbErr- debugMsg (T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs)- NBS.sendAll scket bs))- (-- Read stdin from socket and write to chan- let- loop = do- bs <- NBS.recv scket 4096- if BS8.null bs- then do- debugMsg (T.pack "Connection to client was closed.")- close scket- else do- debugMsg (T.pack $ "Read from socket: " ++ BS8.unpack bs)- writeChan dbIn bs >> loop- in ignoreIOException $ do- labelMe "Debug/Adapter/Proxy: Read stdin"- loop)-- where- ignoreIOException a = catch a $ \(e::IOException) ->- infoMsg (T.pack $ "Ignoring connection broken to proxy client: " ++ show e)- debugMsg msg = l <& WithSeverity msg Debug- infoMsg msg = l <& WithSeverity msg Info---- | A version of @runTCPServerWithSocket@ that kills the forked connection--- handlers when killed.-runTCPServerWithSocket' :: Socket -> (Socket -> IO a1) -> IO a2-runTCPServerWithSocket' sock server = do- let- serverLoop = forever $ E.bracketOnError (accept sock) (close . fst) $- \(conn, _peer) ->- mask_ $ withAsyncWithUnmask- (\ unmask ->- unmask (labelMe "TCP Server handler" >> server conn)- `finally` gracefulClose conn 5000)- (const serverLoop)- serverLoop---- | Label the running thread-labelMe :: String -> IO ()-labelMe name = do- tid <- myThreadId- labelThread tid name---- | Open a socket on an available port-openSocketAvailablePort :: IO Socket-openSocketAvailablePort = do- let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream }- addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0")- -- Bind on "0" to let the OS pick a free port- openTCPServerSocket addr---- | The proxy code running on the terminal in which the @hdb proxy@ process is launched.------ This client-side proxy is responsible for--- 1. Connecting to the given proxy-server port--- 2. Forwarding stdin to the port it is connected to--- 3. Read from the network the output and write it to stdout-runInTerminalHdbProxy :: LogAction IO (WithSeverity T.Text) -> Int -> IO ()-runInTerminalHdbProxy l port = do- l <& WithSeverity (T.pack $ "Running in terminal on port " ++ show port ++ "...!") Info- hSetBuffering stdin LineBuffering-- dbg_inv <- lookupEnv "DEBUGGEE_INVOCATION"- case dbg_inv of- Nothing -> pure ()- Just inv ->- putStrLn $ "Running the debugger input/output proxy for the following debuggee execution:\n\n\n " ++ inv ++ "\n\n"-- catch (- runTCPClient "127.0.0.1" (show port) $ \sock -> do- -- Forward stdin to sock- concurrently_- (catch (forever $ do- str <- BS8.hGetLine stdin- NBS.sendAll sock (str <> BS8.pack "\n")- ) $ \(_e::IOException) -> return ()) -- connection dropped, just exit.-- (-- Forward stdout from sock- catch (forever $ do- msg <- NBS.recv sock 4096- if BS8.null msg- then do- l <& WithSeverity (T.pack "Exiting...") Info- close sock- exitSuccess- else BS8.hPut stdout msg >> hFlush stdout- ) $ \(_e::IOException) -> return ()) -- connection dropped, just exit.-- ) $ \(_e::IOException) -> do- hPutStrLn stderr "Failed to connect to debugger server proxy -- did the debuggee compile and start running successfully?"---- | Send a 'runInTerminal' reverse request to the DAP client--- with the @hdb proxy@ invocation-sendRunProxyInTerminal :: PortNumber -> DebugAdaptor ()-sendRunProxyInTerminal port = do- DAS { entryFile- , entryPoint- , entryArgs- , projectRoot } <- getDebugSession- let debuggee_inv = T.pack $ makeRelative projectRoot entryFile ++ ":" ++ entryPoint ++- (if null entryArgs then "" else " ") ++ unwords entryArgs- thisProg <- liftIO getExecutablePath -- run the same `hdb` executable in `proxy` mode- sendRunInTerminalReverseRequest- RunInTerminalRequestArguments- { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated- , runInTerminalRequestArgumentsTitle = Just debuggee_inv- , runInTerminalRequestArgumentsCwd = ""- , runInTerminalRequestArgumentsArgs = [T.pack thisProg, "proxy", "--port", T.pack (show port)]- , runInTerminalRequestArgumentsEnv = Just (H.singleton "DEBUGGEE_INVOCATION" debuggee_inv)- , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False- }
− hdb/Development/Debug/Adapter/Stepping.hs
@@ -1,45 +0,0 @@-module Development.Debug.Adapter.Stepping where--import DAP--import GHC.Debugger.Interface.Messages hiding (Command, Response)--import Development.Debug.Adapter-import Development.Debug.Adapter.Interface-import Development.Debug.Adapter.Evaluation--commandContinue :: DebugAdaptor ()-commandContinue = do- resetObjectReferences- DidContinue er <- sendInterleaved DoContinue $- sendContinueResponse (ContinueResponse True)- handleEvalResult False er--commandNext :: DebugAdaptor ()-commandNext = do- resetObjectReferences- DidStep er <- sendInterleaved DoStepLocal sendNextResponse- handleEvalResult True er--commandStepIn :: DebugAdaptor ()-commandStepIn = do- resetObjectReferences- DidStep er <- sendInterleaved DoSingleStep sendStepInResponse- handleEvalResult True er--commandStepOut :: DebugAdaptor ()-commandStepOut = do- resetObjectReferences- DidStep er <- sendInterleaved DoStepOut sendStepOutResponse- handleEvalResult True er-------------------------------------------------------------------------------------- | See "Lifetime of Objects References" in DAP specification.-resetObjectReferences :: DebugAdaptor ()-resetObjectReferences = do- updateDebugSession $ \s ->- s { stackFrameMap = mempty- , breakpointMap = mempty- , variablesMap = mempty- }
− hdb/Development/Debug/Adapter/Stopped.hs
@@ -1,181 +0,0 @@-{-# LANGUAGE RecordWildCards, OverloadedRecordDot, OverloadedStrings, LambdaCase #-}---- | Getting information about where we're stopped at (current suspended state).------ Includes the commands to execute the following requests on the debuggee state:--- --- @--- Threads--- StackTrace--- Scopes--- Variables--- ...--- Variables--- @-module Development.Debug.Adapter.Stopped where--import Control.Monad-import qualified Data.IntMap as IM-import qualified Data.Text as T--import DAP--import GHC.Debugger.Interface.Messages-import Development.Debug.Adapter-import Development.Debug.Adapter.Interface------------------------------------------------------------------------------------- * StackTrace------------------------------------------------------------------------------------- | Command to get thread information at current stopped point-commandThreads :: DebugAdaptor ()-commandThreads = do- GotThreads ts <- sendSync GetThreads- sendThreadsResponse $- map (\t ->- Thread- { threadId = remoteThreadIntRef t.tId- , threadName = maybe (T.pack $ "Thread #" ++ show (remoteThreadIntRef t.tId)) T.pack t.tName- }- ) ts------------------------------------------------------------------------------------- * StackTrace------------------------------------------------------------------------------------- | Command to fetch stack trace at current stop point-commandStackTrace :: DebugAdaptor ()-commandStackTrace = do- StackTraceArguments{..} <- getArguments- let threadId = RemoteThreadId stackTraceArgumentsThreadId- GotStacktrace stackFrames <- sendSync (GetStacktrace threadId)- (responseFrames, newStackFrameMap) <- fmap (unzip . concat) $- forM (zip stackFrames [0..]) $ \(stackFrame, stackFrameIx) -> do- freshId <- getFreshId- source <- fileToSource stackFrame.sourceSpan.file- let responseFrame = defaultStackFrame- { stackFrameId = freshId- , stackFrameName = T.pack stackFrame.name- , stackFrameLine = stackFrame.sourceSpan.startLine- , stackFrameColumn = stackFrame.sourceSpan.startCol- , stackFrameEndLine = Just stackFrame.sourceSpan.endLine- , stackFrameEndColumn = Just stackFrame.sourceSpan.endCol- , stackFrameSource = Just source- }- let newMapEntry = (freshId, StackFrameIx threadId stackFrameIx)- return [(responseFrame, newMapEntry)]-- updateDebugSession (\s -> s { stackFrameMap = s.stackFrameMap <> IM.fromList newStackFrameMap })-- sendStackTraceResponse StackTraceResponse- { stackFrames = responseFrames- , totalFrames = if null responseFrames then Nothing else Just (length responseFrames)- }------------------------------------------------------------------------------------- * Scopes------------------------------------------------------------------------------------- | Command to get scopes for current stopped point-commandScopes :: DebugAdaptor ()-commandScopes = do- ScopesArguments{..} <- getArguments- let frameId = scopesArgumentsFrameId- sfMap <- stackFrameMap <$> getDebugSession- case IM.lookup frameId sfMap of- Nothing -> do- sendErrorResponse (ErrorMessage (T.pack $ "Could not find stack frame for id " ++ show frameId)) Nothing- Just six@(StackFrameIx threadId frameIx) -> do- GotScopes scopes <- sendSync (GetScopes threadId frameIx)- sendScopesResponse . ScopesResponse =<<- mapM (scopeInfoToScope six) scopes---- | 'ScopeInfo' to 'Scope'-scopeInfoToScope :: StackFrameIx -> ScopeInfo -> DebugAdaptor Scope-scopeInfoToScope six ScopeInfo{..} = do-- -- Update vars map- varId <- freshVarIx six (scopeToVarRef kind)-- source <- fileToSource sourceSpan.file- return Scope- { scopeName = case kind of- LocalVariablesScope -> "Locals"- ModuleVariablesScope -> "Module"- GlobalVariablesScope -> "Globals"- , scopePresentationHint = Just $ case kind of- LocalVariablesScope -> ScopePresentationHintLocals- ModuleVariablesScope -> ScopePresentationHint "module"- GlobalVariablesScope -> ScopePresentationHint "globals"- , scopeNamedVariables = numVars- , scopeIndexedVariables = Nothing- , scopeSource = Just source- , scopeLine = Just sourceSpan.startLine- , scopeColumn = Just sourceSpan.startCol- , scopeEndLine = Just sourceSpan.endLine- , scopeEndColumn = Just sourceSpan.endCol- , scopeVariablesReference = varId- , scopeExpensive = expensive- }------------------------------------------------------------------------------------- * Variables------------------------------------------------------------------------------------- | Command to get variables by reference number-commandVariables :: DebugAdaptor ()-commandVariables = do- VariablesArguments{..} <- getArguments-- vsMap <- variablesMap <$> getDebugSession- case IM.lookup variablesArgumentsVariablesReference vsMap of- Nothing -> sendErrorResponse (ErrorMessage (T.pack $ "Could not find variable reference " ++ show variablesArgumentsVariablesReference)) Nothing- Just (VariablesIx six@(StackFrameIx threadId frameIx) varRef) -> do- GotVariables vars <- sendSync (GetVariables threadId frameIx varRef)- sendVariablesResponse . VariablesResponse =<<- mapM (varInfoToVariables six) (variableResultToList vars)- case vars of- -- If the reply indicates this was an "inspect lazy variable" request- -- (because the requested variable was forced instead of returning an- -- expansion), invalidate the parent variables.- --- -- The client side seems to handle rendering only the bits which changed- -- out very well, while preserving the variable tree expansion.- -- In any case, we might have to pessimistically redo all variable- -- responses because any value may be changed by an updated thunk, not only- -- the parent variables.- ForcedVariable _- -> sendInvalidatedEvent defaultInvalidatedEvent- { invalidatedEventAreas = [InvalidatedAreasVariables]- }- VariableFields _ -> return ()---- | 'VarInfo' to 'Variable's.-varInfoToVariables :: StackFrameIx -> VarInfo -> DebugAdaptor Variable-varInfoToVariables six VarInfo{..} = do- varId <- freshVarIx six varRef-- return defaultVariable- { variableName = T.pack varName- , variableValue = T.pack varValue- , variableType = Just $ T.pack varType- , variableEvaluateName = Just $ T.pack varName- , variableVariablesReference = varId- , variableNamedVariables = Nothing- , variableIndexedVariables = Nothing- , variablePresentationHint = Just defaultVariablePresentationHint- { variablePresentationHintLazy = Just isThunk- }- }------------------------------------------------------------------------------------- Variable ix references-----------------------------------------------------------------------------------freshVarIx :: StackFrameIx -> VariableReference -> DebugAdaptor Int-freshVarIx _ NoVariables = pure 0 -- No variables means the reference should be 0, e.g. denoting the variable is not expandable-freshVarIx six vr = do- varId <- getFreshId- updateDebugSession (\s -> s { variablesMap = IM.insert varId (VariablesIx six vr) s.variablesMap })- return varId
hdb/Development/Debug/Interactive.hs view
@@ -7,8 +7,6 @@ import System.Directory import System.Console.Haskeline -- import System.Console.Haskeline.Completion-import System.FilePath-import Control.Monad.Except import Control.Monad.State import Control.Monad.Reader import Control.Monad.RWS@@ -24,11 +22,13 @@ import Control.Monad import Data.List (intercalate) import qualified Data.Maybe as Maybe+import GHC.Debugger.Debuggee (DebuggerLog) data RunOptions = RunOptions- { runEntryFile :: FilePath+ { runEntryFile :: AbsFilePath , runEntryPoint :: String , runEntryArgs :: [String]+ , runProjectRoot :: AbsFilePath } data RunContext = RunContext@@ -49,27 +49,30 @@ -> FilePath -- ^ entryFile -> [String] -- ^ entryArgs -> [String] -- ^ extraGhcArgs+ -> Maybe FilePath -> RunDebuggerSettings -> InteractiveDM a -> IO a-runIDM logger entryPoint entryFile entryArgs extraGhcArgs runConf act = do- projectRoot <- getCurrentDirectory+runIDM logger runEntryPoint entryFile runEntryArgs extraGhcArgs cradleFile runConf act = do+ runProjectRoot <- mkAbsolute <$> getCurrentDirectory let hieBiosLogger = contramap ISessionSetupLog logger- runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile) >>= \case+ let runEntryFile = runProjectRoot /> entryFile++ entryFileExists <- doesFileExist (unAbs runEntryFile)+ when (not entryFileExists) $ do+ exitWithMsg $ "Entry file \"" ++ (unAbs runEntryFile) ++ "\" does not exist or is a directory."++ hieDebugRunner hieBiosLogger (DebugRunnerConf (unAbs runProjectRoot) entryFile extraGhcArgs cradleFile) >>= \case Left e -> exitWithMsg e- Right (Left e) -> exitWithMsg e- Right (Right flags)- | HieBiosFlags{..} <- flags+ Right (_ghcInvocation, debugRunner) -> do-- let absEntryFile = normalise $ projectRoot </> entryFile let debugRec = contramap IDebuggerLog logger - runDebugger debugRec rootDir componentDir libdir units ghcInvocation extraGhcArgs absEntryFile runConf $+ runDebugger debugRec debugRunner runConf $ fmap fst $ evalRWST (runInputT (setComplete noCompletion defaultSettings) act)- (RunOptions { runEntryFile = entryFile, runEntryPoint = entryPoint, runEntryArgs = entryArgs })+ (RunOptions { runProjectRoot, runEntryFile, runEntryPoint, runEntryArgs }) (RunContext { runLastCommand = Nothing, runCurrentThread = Nothing } ) where exitWithMsg txt = do@@ -145,6 +148,7 @@ GotVariables vis -> outputVariables vis GotExceptionInfo exc_info -> outputStrLn $ renderExceptionInfo exc_info Aborted err_str -> outputStrLn ("Aborted: " ++ err_str)+ NonFatalError err_str -> outputStrLn ("Encountered error: " ++ err_str) Initialised -> pure () where outputEvalResult er = do@@ -208,7 +212,7 @@ renderSourceSpan :: SourceSpan -> String renderSourceSpan SourceSpan{..} =- file ++ ":" ++ show startLine ++ ":" ++ show startCol+ unAbs file ++ ":" ++ show startLine ++ ":" ++ show startCol renderExceptionInfo :: ExceptionInfo -> String renderExceptionInfo = unlines . go 0@@ -233,10 +237,10 @@ -- Command parser -------------------------------------------------------------------------------- -breakpointParser :: Parser Breakpoint-breakpointParser =+breakpointParser :: AbsFilePath -> Parser Breakpoint+breakpointParser root = ( ModuleBreak- <$> argument str+ <$> argument ((root />) <$> str) ( metavar "PATH" -- todo: accept module breaks using module name <> help "Path to module to break at" ) <*> argument auto@@ -306,7 +310,7 @@ cmdParser opts ctx = hsubparser ( Options.Applicative.command "delete"- ( info (Do . DelBreakpoint <$> breakpointParser)+ ( info (Do . DelBreakpoint <$> breakpointParser (runProjectRoot opts)) ( progDesc "Delete a breakpoint" ) ) <> Options.Applicative.command "run"@@ -350,7 +354,7 @@ ( info (Do <$> variablesParser ctx <**> helper) ( progDesc "Print local variables" ) ) <> Options.Applicative.command "break"- ( info (Do <$> (SetBreakpoint <$> breakpointParser <*> hitCountBreakParser <*> conditionalBreakParser <*> logMessageParser))+ ( info (Do <$> (SetBreakpoint <$> breakpointParser (runProjectRoot opts) <*> hitCountBreakParser <*> conditionalBreakParser <*> logMessageParser)) ( progDesc "Set a breakpoint" ) ) )
hdb/Development/Debug/Options.hs view
@@ -21,6 +21,7 @@ , entryFile :: FilePath , entryArgs :: [String] , extraGhcArgs :: [String]+ , cradleFile :: Maybe FilePath , verbosity :: Severity , internalInterpreter :: Bool , disableIpeBacktraces :: Bool@@ -68,10 +69,12 @@ | HdbExternalInterpreter { writeFd :: Int , readFd :: Int+ , verbosity :: Severity } -- | Launch the custom-for-the-debugger external interpreter and connect it -- to the debugger through a TCP socket. | HdbExternalInterpreterPort { port :: Int+ , verbosity :: Severity }
hdb/Development/Debug/Options/Parser.hs view
@@ -54,6 +54,12 @@ <> metavar "GHC_ARGS" <> value [] <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" )+ <*> option (Just <$> str)+ (long "cradle-file"+ <> metavar "HIE_PATH"+ <> value Nothing+ <> help "Path to .yaml file to use as cradle configuration. Location inferred from ENTRY_POINT otherwise."+ ) <*> verbosityParser Warning <*> internalInterpreterParser <*> disableIpeBacktracesParser@@ -100,6 +106,7 @@ <> short 'p' <> metavar "PORT" <> help "port on which the external interpreter should connect to the debugger" )+ <*> verbosityParser Error <|> HdbExternalInterpreter <$> argument auto ( metavar "WRITE_FD"@@ -107,6 +114,7 @@ <*> argument auto ( metavar "READ_FD" <> help "external interpreter read file descriptor" )+ <*> verbosityParser Error -- | Combined parser for HdbOptions hdbOptionsParser :: Parser HdbOptions
− hdb/Development/Debug/Session/Setup.hs
@@ -1,357 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Development.Debug.Session.Setup- (- -- * Setting up a hie-bios session- HieBiosFlags(..)- , hieBiosSetup-- -- * Logging- , SessionSetupLog(..)- , renderSessionSetupLog- ) where--import Control.Applicative ((<|>))-import Control.Concurrent (newMVar, MVar, withMVar)-import Control.Exception (handleJust)-import Control.Monad-import Control.Monad.Except-import Control.Monad.IO.Class-import Control.Monad.Trans.Maybe-import Data.Bifunctor-import Data.Function-import Data.Functor ((<&>))-import Data.Maybe-import Data.Version-import Data.Void-import System.Directory hiding (withCurrentDirectory, findFile)-import System.Directory qualified as D-import System.FilePath-import System.IO.Error-import Text.ParserCombinators.ReadP (readP_to_S)-import Data.Functor.Contravariant-import GHC.IO (unsafePerformIO)--import qualified Data.Text as T--import qualified HIE.Bios as HIE-import qualified HIE.Bios.Config as Config-import qualified HIE.Bios.Cradle as HIE-import qualified HIE.Bios.Environment as HIE-import qualified HIE.Bios.Types as HIE-import qualified Hie.Cabal.Parser as Implicit-import qualified Hie.Locate as Implicit-import qualified Hie.Yaml as Implicit--import Colog.Core-import Prettyprinter-import Prettyprinter.Render.Text--data SessionSetupLog- = HieBiosLog HIE.Log- | LogCradle (HIE.Cradle Void)- | LogSetupMsg T.Text- deriving Show--renderSessionSetupLog :: SessionSetupLog -> T.Text-renderSessionSetupLog = \case- HieBiosLog l -> renderStrict $ layoutPretty defaultLayoutOptions $ pretty l- LogCradle c -> T.pack $ "Using cradle: " ++ show c- LogSetupMsg m -> m---- | Flags inferred by @hie-bios@ to invoke GHC-data HieBiosFlags = HieBiosFlags- { ghcInvocation :: [String]- , libdir :: FilePath- , units :: [String]- , rootDir :: FilePath- -- ^ Root dir as reported by the 'Cradle'- , componentDir :: FilePath- -- ^ Root dir of the loaded 'ComponentOptions'.- -- Important for multi-package cabal projects, as packages are not in the- -- root of the cradle, but in some sub-directory.- }---- | Prepare a GHC session using hie-bios from scratch-hieBiosSetup :: LogAction IO (WithSeverity SessionSetupLog)- -> FilePath -- ^ project root- -> FilePath -- ^ entry file- -> ExceptT String IO (Either String HieBiosFlags)-hieBiosSetup logger projectRoot entryFile = do-- logInfo "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).- logInfo "Checking GHC version against debugger version..."- _version <- hieBiosRuntimeGhcVersion cradle-- logInfo "Discovering session flags with hie-bios..."- r <- hieBiosFlags cradle projectRoot entryFile & liftIO-- logInfo "Session setup with hie-bios was successful."- return r-- where- logInfo m = liftLogIO logger <& WithSeverity (LogSetupMsg (T.pack m)) Info---- | Try implicit-hie and the builtin search to come up with a @'HIE.Cradle'@-hieBiosCradle :: LogAction IO (WithSeverity SessionSetupLog)- -> FilePath -- ^ Project root- -> FilePath -- ^ Entry file relative to root- -> IO (Either String (HIE.Cradle Void))-hieBiosCradle logger root relTarget = runExceptT $ do- let target = root </> relTarget- explicitCradle <- HIE.findCradle target & liftIO- cradle <- maybe (loadImplicitCradle hieBiosLogger target)- (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO- liftLogIO logger <& WithSeverity (LogCradle cradle) Info- pure cradle- where- hieBiosLogger = contramap (fmap HieBiosLog) logger---- | Fetch the runtime GHC version, according to hie-bios, and check it is the--- same as the compile time GHC version-hieBiosRuntimeGhcVersion :: HIE.Cradle Void- -> ExceptT String IO Version-hieBiosRuntimeGhcVersion cradle = do- out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version"-- case versionMaybe out of- Nothing -> throwError $ "Failed to parse GHC version: " <> out- Just actualVersion -> do-- -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1):- when (compileTimeGhcWithoutPatchVersion /= forgetPatchVersion actualVersion) $ do- throwError $- "Aborting...! The GHC version must be the same which " ++- "ghc-debug-adapter was compiled against (" ++- showVersion compileTimeGhcWithoutPatchVersion++- "). Instead, got " ++ (showVersion actualVersion) ++ "."-- pure actualVersion---- | Make 'HieBiosFlags' from the given target file-hieBiosFlags :: HIE.Cradle Void {-^ Project cradle the entry file belongs to -}- -> FilePath {-^ Project root -}- -> FilePath {-^ Entry file relative to root -}- -> IO (Either String HieBiosFlags)-hieBiosFlags cradle root relTarget = runExceptT $ do- let target = root </> relTarget- libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir"-- -- To determine the flags we MUST set the current directory to the root- -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does)- -- (HIE.getCompilerOptions depends on CWD being the proper root dir)- let compilerOpts = liftIO $ withCurrentDirectory root $-#if MIN_VERSION_hie_bios(0,14,0)- HIE.getCompilerOptions target (HIE.LoadWithContext [target]) cradle-#else- HIE.getCompilerOptions target [] cradle-#endif- componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"-#if __GLASGOW_HASKELL__ >= 913- -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading- -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch.- -- ["-fwrite-if-simplified-core"] ++-#endif-- let (units', flags') = extractUnits (HIE.componentOptions componentOpts)- return HieBiosFlags- { ghcInvocation = flags' ++ ghcDebuggerFlags- , libdir = libdir- , units = units'- , rootDir = HIE.cradleRootDir cradle- , componentDir = HIE.componentRoot componentOpts- }--unwrapCradleResult :: MonadError String m => [Char] -> HIE.CradleLoadResult a -> m a-unwrapCradleResult m = \case- HIE.CradleNone -> throwError $ "HIE.CradleNone\n" ++ m- HIE.CradleFail err -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m- HIE.CradleSuccess x -> return x--extractUnits :: [String] -> ([String], [String])-extractUnits = go [] []- where- -- TODO: we should likely use the 'processCmdLineP' instead- go units rest ("-unit" : x : xs) = go (x : units) rest xs- go units rest (x : xs) = go units (x : rest) xs- go units rest [] = (reverse units, reverse rest)---- | Flags specific to haskell-debugger to append to all GHC invocations.-ghcDebuggerFlags :: [String]-ghcDebuggerFlags =- [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt- ]----- ------------------------------------------------------------------------------- Utilities--- ------------------------------------------------------------------------------versionMaybe :: String -> Maybe Version-versionMaybe xs = case reverse $ readP_to_S parseVersion xs of- [] -> Nothing- (x:_) -> Just (fst x)---- ------------------------------------------------------------------------------- Implicit cradle discovery logic mirroring the one used by HLS.--- The code itself is copy-pasted from HLS.--- Obviously, we want to reuse the logic without having to depend on HLS.--- We should factor out a common sub-component from HLS and use it here as well.--- ------------------------------------------------------------------------------loadImplicitCradle :: Show a => LogAction IO (WithSeverity HIE.Log) -> FilePath -> IO (HIE.Cradle a)-loadImplicitCradle l wfile = do- is_dir <- doesDirectoryExist wfile- let wdir | is_dir = wfile- | otherwise = takeDirectory wfile- cfg <- runMaybeT (implicitConfig wdir)- case cfg of- Just bc -> HIE.getCradle l absurd bc- Nothing -> return $ HIE.defaultCradle l wdir---- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies-implicitConfig :: FilePath -> MaybeT IO (Config.CradleConfig a, FilePath)-implicitConfig = (fmap . first) (Config.CradleConfig noDeps) . inferCradleTree- where- noDeps :: [FilePath]- noDeps = []---inferCradleTree :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)-inferCradleTree start_dir =- maybeItsBios- -- If we have both a config file (cabal.project/stack.yaml) and a work dir- -- (dist-newstyle/.stack-work), prefer that- <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir))- <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir)- -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal- <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle)- -- If we have a stack.yaml, use stack- <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle)- -- If we have a cabal file, use cabal- <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle)-- where- maybeItsBios = (\wdir -> (Config.Bios (Config.Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir-- cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir)---- | Generate a stack cradle given a filepath.------ Since we assume there was proof that this file belongs to a stack cradle--- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files.--- We do not look for package.yaml, as we assume the corresponding .cabal has--- been generated already.------ We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then--- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to--- component names.-stackCradle :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)-stackCradle fp = do- pkgs <- Implicit.stackYamlPkgs fp- pkgsWithComps <- liftIO $ catMaybes <$> mapM (Implicit.nestedPkg fp) pkgs- let yaml = fp </> "stack.yaml"- pure $ (,fp) $ case pkgsWithComps of- [] -> Config.Stack (Config.StackType Nothing (Just yaml))- ps -> Config.StackMulti mempty $ do- Implicit.Package n cs <- ps- c <- cs- let (prefix, comp) = Implicit.stackComponent n c- pure (prefix, Config.StackType (Just comp) (Just yaml))---- | By default, we generate a simple cabal cradle which is equivalent to the--- following hie.yaml:------ @--- cradle:--- cabal:--- @------ Note, this only works reliable for reasonably modern cabal versions >= 3.2.-simpleCabalCradle :: FilePath -> (Config.CradleTree a, FilePath)-simpleCabalCradle fp = (Config.Cabal $ Config.CabalType Nothing Nothing, fp)--cabalExecutable :: MaybeT IO FilePath-cabalExecutable = MaybeT $ findExecutable "cabal"--stackExecutable :: MaybeT IO FilePath-stackExecutable = MaybeT $ findExecutable "stack"--biosWorkDir :: FilePath -> MaybeT IO FilePath-biosWorkDir = findFileUpwards (".hie-bios" ==)--cabalWorkDir :: FilePath -> MaybeT IO ()-cabalWorkDir wdir = do- check <- liftIO $ doesDirectoryExist (wdir </> "dist-newstyle")- unless check $ fail "No dist-newstyle"--stackWorkDir :: FilePath -> MaybeT IO ()-stackWorkDir wdir = do- check <- liftIO $ doesDirectoryExist (wdir </> ".stack-work")- unless check $ fail "No .stack-work"--cabalConfigDir :: FilePath -> MaybeT IO FilePath-cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local")--cabalFileDir :: FilePath -> MaybeT IO FilePath-cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal")--stackConfigDir :: FilePath -> MaybeT IO FilePath-stackConfigDir = findFileUpwards isStack- where- isStack name = name == "stack.yaml"---- | Searches upwards for the first directory containing a file to match--- the predicate.-findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath-findFileUpwards p dir = do- cnts <-- liftIO- $ handleJust- -- Catch permission errors- (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)- pure- (findFile p dir)-- case cnts of- [] | dir' == dir -> fail "No cabal files"- | otherwise -> findFileUpwards p dir'- _ : _ -> return dir- where dir' = takeDirectory dir---- | Sees if any file in the directory matches the predicate-findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]-findFile p dir = do- b <- doesDirectoryExist dir- if b then getFiles >>= filterM doesPredFileExist else return []- where- getFiles = filter p <$> getDirectoryContents dir- doesPredFileExist file = doesFileExist $ dir </> file------------------------------------------------------------------------------------compileTimeGhcWithoutPatchVersion :: Version-compileTimeGhcWithoutPatchVersion =- let- versionNumber = __GLASGOW_HASKELL__ :: Int- (major, minor) = divMod versionNumber 100- in- makeVersion [major, minor]--forgetPatchVersion :: Version -> Version-forgetPatchVersion v = case versionBranch v of- (major:minor:_patches) -> makeVersion [major, minor]- _ -> v--{-# NOINLINE cwdLock #-}-cwdLock :: MVar ()-cwdLock = unsafePerformIO $ newMVar ()--withCurrentDirectory :: FilePath -> IO b -> IO b-withCurrentDirectory fp m = withMVar cwdLock $ \ _ -> D.withCurrentDirectory fp m
hdb/Main.hs view
@@ -5,29 +5,16 @@ import System.Process import System.Environment-import Data.Maybe-import Data.IORef-import Text.Read-import Control.Concurrent-import Control.Monad-import Control.Monad.IO.Class import Control.Exception (bracket, uninterruptibleMask, bracketOnError) import Control.Exception.Backtrace import DAP import Development.Debug.Adapter.Init-import Development.Debug.Adapter.Breakpoints-import Development.Debug.Adapter.Stepping-import Development.Debug.Adapter.Stopped-import Development.Debug.Adapter.Evaluation-import Development.Debug.Adapter.ExceptionInfo-import Development.Debug.Adapter.Exit-import Development.Debug.Adapter.Exit.Helpers import Development.Debug.Adapter.Handles+import Development.Debug.Adapter.Server import Colog.Core -import Data.Time import System.IO ( hFlush , hClose@@ -35,11 +22,9 @@ , hSetBuffering , BufferMode(..) , Handle- , openFile- , IOMode(ReadMode, ReadWriteMode)++ , IOMode(ReadWriteMode) )-import qualified DAP.Log as DAP-import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Handle.FD@@ -51,14 +36,16 @@ import qualified GHCi.Utils as GHCi import qualified GHCi.Message as GHCi -import GHC.Utils.Logger (defaultLogActionWithHandles)-import GHC.Debugger.Monad (DebuggerLog(..), RunDebuggerSettings(..))+import GHC.Debugger.Monad (RunDebuggerSettings(..)) import Development.Debug.Options (HdbOptions(..)) import Development.Debug.Options.Parser (parseHdbOptions)-import Development.Debug.Adapter import Development.Debug.Adapter.Proxy import Development.Debug.Interactive import GHC.Stack.Annotation (annotateCallStackIO)+import GHC.Utils.Logger (defaultLogActionWithHandles)+import Development.Debug.Session.Setup (hieDebugRunner)+import GHC.Debugger.Debuggee (mkCliInterpreterSettings)+import GHC.Debugger.Session (initUniqSupplyIO) #if MIN_VERSION_ghc(9,15,0) import GHC.Debugger.Runtime.Interpreter.Custom (dbgInterpCmdHandler)@@ -77,32 +64,42 @@ -- Special case to detect --external-interpreter in the third -- position. If we could specify -opti options to put *before* the -- descriptors we could get rid of this.- pure (HdbExternalInterpreter (read writeFd) (read readFd))+ pure (HdbExternalInterpreter (read writeFd) (read readFd) Error) _ -> parseHdbOptions case hdbOpts of HdbDAPServer{port, internalInterpreter, disableIpeBacktraces} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) config <- getConfig port+ -- the same program invoked with `external-interpreter` serves as the external interpreter+ hdbProgram <- getExecutablePath++ -- See Note [UniqueSupply is process global]+ initUniqSupplyIO++ let servConf = DAPServerConf+ { getDebugRunner = hieDebugRunner+ , hdbProgram+ , dapServerConfig = config+ } redirectRealStdout internalInterpreter $ \realStdout -> do hSetBuffering realStdout LineBuffering- l <- mainLogger hdbOpts.verbosity realStdout- init_var <- liftIO (newIORef False{-not supported by default-})+ l <- contramap DAPLog <$> mainLogger hdbOpts.verbosity realStdout runDAPServerWithLogger (contramap DAPLibraryLog l) config- (talk l init_var internalInterpreter)+ (talk l servConf internalInterpreter) (ack l ) HdbCLI{..} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces)++ -- See Note [UniqueSupply is process global]+ initUniqSupplyIO+ l <- mainLogger hdbOpts.verbosity stdout- stdinStream <- case debuggeeStdin of- Just fp -> UseHandle <$> System.IO.openFile fp ReadMode- Nothing -> pure Inherit+ cliInterpSettings <- mkCliInterpreterSettings internalInterpreter debuggeeStdin let runConf = RunDebuggerSettings { supportsANSIStyling = True -- todo: check!! , supportsANSIHyperlinks = False- , preferInternalInterpreter = internalInterpreter- , externalInterpreterCustomProc = Left stdinStream- }- runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs+ , interpreterSettings = cliInterpSettings }+ runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs cradleFile runConf debugInteractive HdbProxy{port} -> do setBacktraceMechanismState IPEBacktrace True@@ -111,20 +108,20 @@ HdbExternalInterpreter{writeFd, readFd} -> do inh <- GHCi.readGhcHandle (show readFd) outh <- GHCi.readGhcHandle (show writeFd)- runExternalInterpreterServer inh outh+ runExternalInterpreterServer inh outh hdbOpts.verbosity HdbExternalInterpreterPort{port} -> do pid <- getCurrentPid withExternalInterpreterPort (fromIntegral port) $ \h -> do hPutStrLn h (show pid) hFlush h- runExternalInterpreterServer h h+ runExternalInterpreterServer h h hdbOpts.verbosity where- runExternalInterpreterServer inh outh = do+ runExternalInterpreterServer inh outh verbosity = do GHCi.installSignalHandlers pipe <- GHCi.mkPipeFromHandles inh outh- let verbose = False-#if MIN_VERSION_ghc(9,15,0)- uninterruptibleMask $ \restore ->+ let verbose = verbosity <= Info -- Debug || Info+#if MIN_VERSION_ghc(9,14,2)+ uninterruptibleMask $ \restore -> do GHCi.servWithCustom verbose hook pipe restore dbgInterpCmdHandler #else uninterruptibleMask $ GHCi.serv verbose hook pipe@@ -173,211 +170,15 @@ | otherwise = k stdout --- | Fetch config from environment, fallback to sane defaults-getConfig :: Int -> IO ServerConfig-getConfig port = do- let- hostDefault = "0.0.0.0"- portDefault = port- capabilities = Capabilities- { supportsConfigurationDoneRequest = True- , supportsFunctionBreakpoints = True- , supportsConditionalBreakpoints = True- , supportsHitConditionalBreakpoints = True- , supportsEvaluateForHovers = False- -- Exception Breakpoints:- , exceptionBreakpointFilters = [ defaultExceptionBreakpointsFilter- { exceptionBreakpointsFilterLabel = "All exceptions"- , exceptionBreakpointsFilterFilter = BREAK_ON_EXCEPTION- }- , defaultExceptionBreakpointsFilter- { exceptionBreakpointsFilterLabel = "Uncaught exceptions"- , exceptionBreakpointsFilterFilter = BREAK_ON_ERROR- }- ]- , supportsStepBack = False- , supportsSetVariable = False- , supportsRestartFrame = False- , supportsGotoTargetsRequest = False- , supportsStepInTargetsRequest = False- , supportsCompletionsRequest = False- , completionTriggerCharacters = []- , supportsModulesRequest = False- , additionalModuleColumns = [ defaultColumnDescriptor- { columnDescriptorAttributeName = "Extra"- , columnDescriptorLabel = "Label"- }- ]- , supportedChecksumAlgorithms = []- , supportsRestartRequest = False- , supportsExceptionOptions = True- , supportsValueFormattingOptions = True- , supportsExceptionInfoRequest = True- , supportTerminateDebuggee = False -- for now, when debugger is disconnected, we always kill the debuggee- , supportSuspendDebuggee = False- , supportsDelayedStackTraceLoading = False- , supportsLoadedSourcesRequest = False- , supportsLogPoints = True- , supportsTerminateThreadsRequest = False- , supportsSetExpression = False- , supportsTerminateRequest = True- , supportsDataBreakpoints = False- , supportsReadMemoryRequest = False- , supportsWriteMemoryRequest = False- , supportsDisassembleRequest = False- , supportsCancelRequest = False- -- Display which breakpoints are valid when user intends to set- -- breakpoint on given line:- , supportsBreakpointLocationsRequest = True- , supportsClipboardContext = False- , supportsSteppingGranularity = False- , supportsInstructionBreakpoints = False- , supportsExceptionFilterOptions = False- , supportsSingleThreadExecutionRequests = False- }- ServerConfig- <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST"- <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT"- <*> pure capabilities- <*> pure True ----------------------------------------------------------------------------------- * Talk------------------------------------------------------------------------------------- | Main function where requests are received and Events + Responses are returned.--- The core logic of communicating between the client <-> adaptor <-> debugger--- is implemented in this function.-talk :: LogAction IO MainLog- -> IORef Bool- -- ^ Whether the client supports runInTerminal- -> Bool- -- ^ Prefer internal interpreter- -> Command -> DebugAdaptor ()----------------------------------------------------------------------------------talk l support_rit_var prefer_internal_interpreter = \ case- CommandInitialize -> do- InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments-#ifdef mingw32_HOST_OS- -- On Windows, runInTerminal is currently unsupported- -- See #199- let runInTerminal = False-#else- let runInTerminal = fromMaybe False supportsRunInTerminalRequest-#endif- -- This global variable is wrong. Even though we only register the session- -- and the per-session state on Launch (which gives us __sessionId), the- -- *initialize* command is run once per new session on a new connection and- -- two different clients which may differ in their support for- -- 'runInTerminal'.- --- -- The `dap` library should likely keep track of the client capabilities- -- per connection.- liftIO $ writeIORef support_rit_var runInTerminal- sendInitializeResponse---------------------------------------------------------------------------------- CommandLaunch -> do- launch_args <- getArguments-- -- Wrong-ish. See above where this variable is written- supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var-- initDebugger (contramap DAPLog l)- supportsRunInTerminalRequest prefer_internal_interpreter- launch_args-- sendLaunchResponse -- ack- sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session-- liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info)---------------------------------------------------------------------------------- CommandAttach -> do- sendTerminatedEvent (TerminatedEvent False)- destroyDebugSession- sendError (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing---------------------------------------------------------------------------------- CommandBreakpointLocations -> commandBreakpointLocations- CommandSetBreakpoints -> commandSetBreakpoints- CommandSetFunctionBreakpoints -> commandSetFunctionBreakpoints- CommandSetExceptionBreakpoints -> commandSetExceptionBreakpoints- CommandExceptionInfo -> commandExceptionInfo- CommandSetDataBreakpoints -> undefined- CommandSetInstructionBreakpoints -> undefined------------------------------------------------------------------------------ CommandLoadedSources -> undefined------------------------------------------------------------------------------ CommandConfigurationDone -> do- sendConfigurationDoneResponse-- DAS{runInTerminalProc} <- getDebugSession- case runInTerminalProc of- RunProxyInTerminal{proxyClientReady} -> liftIO $ do- -- Only start executing after proxy client connects succesfully (#95)- takeMVar proxyClientReady- _ ->- pure ()-- -- Configuration is finished. Start executing until it halts.- startExecution >>= handleEvalResult False------------------------------------------------------------------------------ CommandThreads -> commandThreads- CommandStackTrace -> commandStackTrace- CommandScopes -> commandScopes- CommandVariables -> commandVariables------------------------------------------------------------------------------ CommandContinue -> commandContinue------------------------------------------------------------------------------ CommandNext -> commandNext------------------------------------------------------------------------------ CommandStepIn -> commandStepIn- CommandStepOut -> commandStepOut------------------------------------------------------------------------------ CommandEvaluate -> commandEvaluate------------------------------------------------------------------------------ CommandTerminate -> commandTerminate- CommandDisconnect -> commandDisconnect------------------------------------------------------------------------------ CommandModules -> sendModulesResponse (ModulesResponse [] Nothing)- CommandSource -> undefined- CommandPause -> pure () -- TODO- (CustomCommand "mycustomcommand") -> undefined- other -> do- terminateWithError ("Unsupported command: " <> show other)---- | Receive reverse request responses (such as runInTerminal response)-ack :: LogAction IO MainLog- -> ReverseRequestResponse -> DebugAdaptorCont ()-ack l rrr = case rrr.reverseRequestCommand of- ReverseCommandRunInTerminal -> do-- RunInTerminalResponse{} <- getReverseRequestResponseBody rrr-- -- TODO: keep track of body.shellProcessId to then kill the proxy when the- -- session is terminated:- -- [stdout] [127.0.0.1:54427][DEBUG][RECEIVED]- -- {- -- "body": {- -- "shellProcessId": 2092- -- },- -- "command": "runInTerminal",- -- "seq": 14,- -- "success": true,- -- "type": "response"- -- }- when rrr.success $ do- liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info)- _ -> pure ()---------------------------------------------------------------------------------- -- * Logging -------------------------------------------------------------------------------- data MainLog- = DAPLog DAPLog- | InteractiveLog InteractiveLog+ = InteractiveLog InteractiveLog | RunProxyClientLog (WithSeverity T.Text)- | DAPLaunchLog (WithSeverity T.Text)- | DAPLibraryLog DAP.DAPLog+ | DAPLog DAPLog -- | Given the severity threshold from which we start logging, create a base -- logger for consuming the top-level debugger logs ('MainLog').@@ -385,54 +186,9 @@ mainLogger :: Severity -> Handle -> IO (LogAction IO MainLog) mainLogger threshold h = do l <- handleLogger h- let- logSessionLog (WithSeverity msg sev)- | sev >= threshold =- cmapM renderWithTimestamp l <& (renderSeverity sev <> T.pack (show msg))- | otherwise = pure ()-- logDebuggerLog = \case- DebuggerLog sev msg- | sev >= threshold ->- cmapM renderWithTimestamp l <&- (renderSeverity sev <> T.pack (show msg))- GHCLog logflags msg_class srcSpan msg ->- defaultLogActionWithHandles h h logflags msg_class srcSpan msg- LogDebuggeeOut out ->- -- If we wanted, we could log the debuggee output differently if we are- -- on the DAP debug mode vs, say, hdb.- l <& out- LogDebuggeeErr err -> l <& err- _ -> pure ()-- defaultLog (WithSeverity msg sev)- | sev >= threshold =- cmapM renderWithTimestamp l <& (renderSeverity sev <> msg)- | otherwise = pure ()-+ let logGhcLog = defaultLogActionWithHandles h h pure $ LogAction $ \case- DAPLog (DAPSessionSetupLog sessionLog) -> logSessionLog sessionLog- DAPLog (DAPDebuggerLog debuggerLog) -> logDebuggerLog debuggerLog- DAPLog (RunProxyServerLog sev_msg) -> defaultLog sev_msg- InteractiveLog (ISessionSetupLog sessionLog) -> logSessionLog sessionLog- InteractiveLog (IDebuggerLog debuggerLog) -> logDebuggerLog debuggerLog- RunProxyClientLog sev_msg -> defaultLog sev_msg- DAPLaunchLog sev_msg -> defaultLog sev_msg- DAPLibraryLog t ->- l <& DAP.renderDAPLog t- where- renderSeverity :: Severity -> Text- renderSeverity = \ case- Debug -> "[DEBUG] "- Info -> "[INFO] "- Warning -> "[WARNING] "- Error -> "[ERROR] "-- renderWithTimestamp :: Text -> IO Text- renderWithTimestamp msg = do- t <- getCurrentTime- let timeStamp = utcTimeToText t- pure $ "[" <> timeStamp <> "] " <> msg- where- utcTimeToText utcTime = T.pack $- formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime+ InteractiveLog (ISessionSetupLog sessionLog) -> logSessionLog l threshold sessionLog+ InteractiveLog (IDebuggerLog debuggerLog) -> logDebuggerLog logGhcLog l threshold debuggerLog+ RunProxyClientLog sev_msg -> defaultLog l threshold sev_msg+ DAPLog dapLog -> logDAPLog logGhcLog l threshold <& dapLog
+ test/golden/T130/T130.ghc-1001.hdb-stdout view
@@ -0,0 +1,1 @@+Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3)
test/golden/T130/T130.ghc-914.hdb-stdout view
@@ -1,2 +1,1 @@ Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3)-While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3)
test/golden/T130/T130.hdb-test view
@@ -5,7 +5,7 @@ # which is not supported by this debugger version. # (Note: drop the output because the callstack is hard to normalize) -if ($HDB app/Main.hs 2>&1 | grep "Cannot use unsupported") < T130.hdb-stdin; then+if ($HDB app/Main.hs 2>&1 | grep -v 'While handling' | grep "Cannot use unsupported") < T130.hdb-stdin; then exit 0 fi
+ test/golden/T130b/T130b.ghc-1001.hdb-stdout view
@@ -0,0 +1,5 @@+[1 of 3] Compiling Lib ( <TEMPORARY-DIRECTORY>/lib/Lib.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Lib.gbc )[T130b-0.1.0.0-inplace]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[T130b-0.1.0.0-inplace-T130b]+(hdb) MyType+()+(hdb) Exiting...
test/golden/T130b/T130b.ghc-914.hdb-stdout view
@@ -1,4 +1,5 @@-[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b]+[1 of 3] Compiling Lib ( <TEMPORARY-DIRECTORY>/lib/Lib.hs, interpreted )[T130b-0.1.0.0-inplace]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b] (hdb) MyType () (hdb) Exiting...
+ test/golden/T130c/T130c.ghc-1001.hdb-stdout view
@@ -0,0 +1,7 @@+[1 of 1] Compiling Lib ( <TEMPORARY-DIRECTORY>/lib/Lib.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Lib.gbc )[T130c-0.1.0.0-inplace]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/lib/Lib.hs", startLine = 16, endLine = 16, startCol = 3, endCol = 14}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : ColonList = _+ value : ColonList = alpha:beta:gamma+(hdb) Exiting...
+ test/golden/T135/T135.ghc-1001.hdb-stdout view
@@ -0,0 +1,12 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/myapp/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[myapp-0.1.0.0-inplace-myapp]+[;1m<TEMPORARY-DIRECTORY>/myapp/app/Main.hs:3:1: [;1m[35mwarning[0m[0m[;1m: [GHC-66111] [[;1m[35m-Wunused-imports[0m[0m[;1m][0m[0m[;1m+ The import of ‘MyLib’ is redundant+ except perhaps to import instances from ‘MyLib’+ To import instances alone, use: import MyLib()[0m[0m+[;1m[34m |[0m[0m+[;1m[34m3 |[0m[0m [;1m[35mimport MyLib (someFunc)[0m[0m+[;1m[34m |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^[0m[0m++(hdb) Hello, Haskell!+()+(hdb) Exiting...
test/golden/T135/T135.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp] [;1m<TEMPORARY-DIRECTORY>/myapp/app/Main.hs:3:1: [;1m[35mwarning[0m[0m[;1m: [GHC-66111] [[;1m[35m-Wunused-imports[0m[0m[;1m][0m[0m[;1m The import of ‘MyLib’ is redundant except perhaps to import instances from ‘MyLib’
test/golden/T135/hie.yaml view
@@ -1,6 +1,5 @@ cradle: cabal:- - path: "./mylib"- component: "lib:mylib"+ #we want mylib to be an external package, so we don't list it in the cradle. - path: "./myapp/" component: "myapp"
+ test/golden/T154/T154.external.ghc-1001.hdb-stdout view
@@ -0,0 +1,4 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) hello+()+(hdb) Exiting...
+ test/golden/T154/T154.external.ghc-914.hdb-stdout view
@@ -0,0 +1,4 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) hello+()+(hdb) Exiting...
+ test/golden/T154/T154.external.ghc-915.hdb-stdout view
@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) hello+()+(hdb) Exiting...
+ test/golden/T154/T154.external.hdb-test view
@@ -0,0 +1,3 @@+#!/bin/sh++echo "run" | $HDB -v0 Main.hs --extra-ghc-args -fexternal-interpreter 2>&1
− test/golden/T154/T154.ghc-914.hdb-stdout
@@ -1,5 +0,0 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]-(hdb) hello-()-(hdb) Exiting...
− test/golden/T154/T154.ghc-915.hdb-stdout
@@ -1,5 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]-(hdb) hello-()-(hdb) Exiting...
− test/golden/T154/T154.hdb-test
@@ -1,3 +0,0 @@-#!/bin/sh--echo "run" | $HDB -v0 Main.hs --extra-ghc-args -fexternal-interpreter 2>&1
+ test/golden/T159/T159.ghc-1001.hdb-stdout view
@@ -0,0 +1,5 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T159.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}+(hdb) Stopped at breakpoint+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16, args = Just (DbgStackFrameBCOArgs {bcoArgs = <noshow>, bcoArgsOffset = Just 2})},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 7, endLine = 7, startCol = 7, endCol = 28}, breakId = Nothing, args = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 6, endLine = 6, startCol = 5, endCol = 24}, breakId = Nothing, args = Nothing},DbgStackFrame {name = "annotateCallStackIO", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 5, endLine = 5, startCol = 3, endCol = 22}, breakId = Nothing, args = Nothing}]+(hdb) Exiting...
test/golden/T159/T159.ghc-914.hdb-stdout view
@@ -1,6 +1,5 @@-[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 ( <TEMPORARY-DIRECTORY>/T159.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T159.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}} (hdb) Stopped at breakpoint-(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}]+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16, args = Just (DbgStackFrameBCOArgs {bcoArgs = <noshow>, bcoArgsOffset = Just 2})},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing, args = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing, args = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing, args = Nothing}] (hdb) Exiting...
+ test/golden/T159b/T159b.ghc-1001.hdb-stdout view
@@ -0,0 +1,5 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T159b.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}+(hdb) Stopped at breakpoint+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16, args = Just (DbgStackFrameBCOArgs {bcoArgs = <noshow>, bcoArgsOffset = Just 2})},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 7, endLine = 7, startCol = 7, endCol = 28}, breakId = Nothing, args = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 6, endLine = 6, startCol = 5, endCol = 24}, breakId = Nothing, args = Nothing},DbgStackFrame {name = "annotateCallStackIO", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 5, endLine = 5, startCol = 3, endCol = 22}, breakId = Nothing, args = Nothing}]+(hdb) Exiting...
+ test/golden/T159b/T159b.ghc-914.hdb-stdout view
@@ -0,0 +1,5 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T159b.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}+(hdb) Stopped at breakpoint+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16, args = Just (DbgStackFrameBCOArgs {bcoArgs = <noshow>, bcoArgsOffset = Just 2})},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing, args = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing, args = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159b.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing, args = Nothing}]+(hdb) Exiting...
+ test/golden/T159b/T159b.ghc-915.hdb-stdout view
@@ -0,0 +1,6 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/T159b.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}+(hdb) Stopped at breakpoint+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation, called at <TEMPORARY-DIRECTORY>/T159b.hs:7:7 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4], called at <TEMPORARY-DIRECTORY>/T159b.hs:6:5 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159b.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}]+(hdb) Exiting...
+ test/golden/T159b/T159b.hdb-stdin view
@@ -0,0 +1,3 @@+break T159b.hs 12+run+backtrace
+ test/golden/T159b/T159b.hdb-test view
@@ -0,0 +1,3 @@+#!/bin/sh++$HDB -v0 T159b.hs < T159b.hdb-stdin 2>&1 || true
+ test/golden/T159b/T159b.hs view
@@ -0,0 +1,12 @@+import GHC.Stack.Annotation.Experimental (annotateCallStackIO,annotateStackShowIO,annotateStackStringIO)++main :: IO ()+main = do+ annotateCallStackIO $ do+ annotateStackShowIO ([1..4] :: [Int]) $ do+ annotateStackStringIO "Lovely annotation" $ do+ foo 500++foo :: Int -> IO ()+foo arg =+ putStrLn $ "foo: " <> show (arg * arg * arg)
+ test/golden/T159b/hie.yaml view
@@ -0,0 +1,8 @@+cradle:+ direct:+ arguments: + - -i+ - -i.+ - T159b.hs+ - -package base+ - -package ghc-experimental
+ test/golden/T164/T164.ghc-1001.hdb-stdout view
@@ -0,0 +1,24 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+existentialFoo : Foo = Foo+ _1 : r0 = _+ _2 : [Char] = "value"+existentialFoo2 : Foo2 = Foo2+ _1 : r0 = _+ foo : [Char] = "value2"+foo3 : Foo3 = Foo3+ _1 : Int = 0+ _2 : Word = 1+ _3 : Int = 2+ _4 : Int = 3+foo4 : Foo4 = Foo4+ _1 : Word32 = 0+ _2 : Word16 = 1+ _3 : Word64 = 2+ _4 : Word16 = 3+foo5 : Foo5 = Foo5+ _1 : ?impl::String = _+ _2 : String = _+(hdb) Exiting...
test/golden/T164/T164.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}} (hdb) Stopped at breakpoint (hdb) _result : IO () = <fn> :: IO ()
+ test/golden/T166/T166.ghc-1001.hdb-stdout view
@@ -0,0 +1,16 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) 1+(hdb) 1+(hdb) Prelude.undefined++HasCallStack backtrace:+ undefined, called at <interactive>:1:1 in interactive:Ghci3++(hdb) Prelude.undefined++HasCallStack backtrace:+ undefined, called at <interactive>:1:1 in interactive:Ghci3++(hdb) _+(hdb) [...]+(hdb) Exiting...
test/golden/T166/T166.ghc-914.hdb-stdout view
@@ -1,16 +1,15 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main] (hdb) 1 (hdb) 1 (hdb) Prelude.undefined HasCallStack backtrace:- undefined, called at <interactive>:1:1 in interactive:Ghci4+ undefined, called at <interactive>:1:1 in interactive:Ghci3 (hdb) Prelude.undefined HasCallStack backtrace:- undefined, called at <interactive>:1:1 in interactive:Ghci4+ undefined, called at <interactive>:1:1 in interactive:Ghci3 (hdb) _ (hdb) [...]
− test/golden/T169/T169.ghc-914.hdb-stdout
@@ -1,5 +0,0 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]-(hdb) hello-()-(hdb) Exiting...
− test/golden/T169/T169.ghc-915.hdb-stdout
@@ -1,5 +0,0 @@-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]-[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]-(hdb) hello-()-(hdb) Exiting...
− test/golden/T169/T169.hdb-test
@@ -1,3 +0,0 @@-#!/bin/sh--echo "run" | $HDB -v0 Main.hs --extra-ghc-args -fno-external-interpreter 2>&1
+ test/golden/T169/T169.internal.ghc-1001.hdb-stdout view
@@ -0,0 +1,4 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) hello+()+(hdb) Exiting...
+ test/golden/T169/T169.internal.ghc-914.hdb-stdout view
@@ -0,0 +1,4 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) hello+()+(hdb) Exiting...
+ test/golden/T169/T169.internal.ghc-915.hdb-stdout view
@@ -0,0 +1,5 @@+[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) hello+()+(hdb) Exiting...
+ test/golden/T169/T169.internal.hdb-test view
@@ -0,0 +1,3 @@+#!/bin/sh++echo "run" | $HDB -v0 Main.hs --extra-ghc-args -fno-external-interpreter 2>&1
+ test/golden/T169/T169b.ghc-1001.hdb-stdout view
@@ -0,0 +1,7 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T169b.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}}+(hdb) Stopped at breakpoint+(hdb) Debuggee writing something to stdout+(hdb) Debuggee writing something to stderr+()+(hdb) Exiting...
test/golden/T169/T169b.ghc-914.hdb-stdout view
@@ -1,10 +1,7 @@-[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 ( <TEMPORARY-DIRECTORY>/T169b.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T169b.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}} (hdb) Stopped at breakpoint-(hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}] (hdb) Debuggee writing something to stdout-[ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}] (hdb) Debuggee writing something to stderr () (hdb) Exiting...
test/golden/T169/T169b.hdb-stdin view
@@ -1,4 +1,4 @@-break --name main+break --name Main.main run next next
test/golden/T169/T169b.hdb-test view
@@ -1,3 +1,5 @@ #!/bin/sh -$HDB -v0 T169b.hs < T169b.hdb-stdin 2>&1+# We don't care to see ScopeInfos when we stop at a breakpoint, just care about+# the debuggee outputting+$HDB -v0 T169b.hs < T169b.hdb-stdin 2>&1 | grep -v 'ScopeInfo'
+ test/golden/T169/T169c.external.ghc-1001.hdb-stdout view
@@ -0,0 +1,4 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T169c.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) "hello there"+()+(hdb) Exiting...
test/golden/T169/T169c.external.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/T169c.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T169c.hs, interpreted )[main] (hdb) "hello there" () (hdb) Exiting...
+ test/golden/T169/T169c.internal.ghc-1001.hdb-stdout view
@@ -0,0 +1,4 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T169c.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) "hello world"+()+(hdb) Exiting...
test/golden/T169/T169c.internal.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/T169c.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/T169c.hs, interpreted )[main] (hdb) "hello world" () (hdb) Exiting...
+ test/golden/T217/T217.ghc-1001.hdb-stdout view
@@ -0,0 +1,11 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 13], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 17, endLine = 17, startCol = 3, endCol = 10}}+(hdb) helio+Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+doit : forall {b}. b -> IO () = <fn> :: forall {b}. b -> IO ()+y : D Char = <fn> :: D Char+x : forall a. (a ~ IO ()) => a = <fn> :: forall a. (a ~ IO ()) => a+ix : B = _+ ix : B = B (Left _)+(hdb) Exiting...
test/golden/T217/T217.ghc-914.hdb-stdout view
@@ -1,12 +1,11 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 13], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 17, endLine = 17, startCol = 3, endCol = 10}} (hdb) helio Stopped at breakpoint (hdb) _result : IO () = <fn> :: IO ()-x : forall a. (a ~ IO ()) => a = <fn> :: forall a. (a ~ IO ()) => a-y : D Char -> Char = <fn> :: D Char -> Char doit : forall {b}. b -> IO () = <fn> :: forall {b}. b -> IO ()+y : D Char -> Char = <fn> :: D Char -> Char+x : forall a. (a ~ IO ()) => a = <fn> :: forall a. (a ~ IO ()) => a ix : B = _ ix : B = B (Left _) (hdb) Exiting...
+ test/golden/T218/T218.ghc-1001.hdb-stdout view
@@ -0,0 +1,11 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) Aborted: <interactive>:1:1: error: [GHC-88464]+ Variable not in scope: isLetter+(hdb) +(hdb) <fn> :: Char -> Bool+(hdb) True+(hdb) False+(hdb) Aborted: <interactive>:1:1: error: [GHC-87110]+ Could not find module `Does.Not.Exist'.+ Use -v to see a list of the files searched for.+(hdb) Exiting...
test/golden/T218/T218.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main] (hdb) Aborted: <interactive>:1:1: error: [GHC-88464] Variable not in scope: isLetter (hdb)
+ test/golden/T225/T225.ghc-1001.hdb-stdout view
@@ -0,0 +1,5 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 12}}+(hdb) Stopped at breakpoint+(hdb) "List [1]"+(hdb) Exiting...
test/golden/T225/T225.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 12}} (hdb) Stopped at breakpoint (hdb) "List [1]"
+ test/golden/T225b/T225b.ghc-1001.hdb-stdout view
@@ -0,0 +1,7 @@+[1 of 2] Compiling B ( <TEMPORARY-DIRECTORY>/B.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/B.gbc )[main]+[2 of 2] Compiling A ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/A.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId B 3], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/B.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 19}}+(hdb) 1+Stopped at breakpoint+(hdb) "fromList [1,2,3]"+(hdb) Exiting...
test/golden/T225b/T225b.ghc-914.hdb-stdout view
@@ -1,8 +1,6 @@-[1 of 4] Compiling B ( <TEMPORARY-DIRECTORY>/B.hs, interpreted )[main]-[2 of 4] Compiling A ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]-[3 of 4] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[4 of 4] Compiling GHC.Debugger.View.Containers ( in-memory:GHC.Debugger.View.Containers, interpreted )[haskell-debugger-view-in-memory]-(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId B 3], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/./B.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 19}}+[1 of 2] Compiling B ( <TEMPORARY-DIRECTORY>/B.hs, interpreted )[main]+[2 of 2] Compiling A ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId B 3], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/B.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 19}} (hdb) 1 Stopped at breakpoint (hdb) "fromList [1,2,3]"
+ test/golden/T234/T234.ghc-1001.hdb-stdout view
@@ -0,0 +1,7 @@+[1 of 1] Compiling Lib ( <TEMPORARY-DIRECTORY>/lib/Lib.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Lib.gbc )[T234-0.1.0.0-inplace]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/lib/Lib.hs", startLine = 16, endLine = 16, startCol = 3, endCol = 14}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : ColonList = _+ value : ColonList = alpha:beta:gamma+(hdb) Exiting...
+ test/golden/T234b/T234b.ghc-1001.hdb-stdout view
@@ -0,0 +1,7 @@+[1 of 1] Compiling Lib ( <TEMPORARY-DIRECTORY>/lib/Lib.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Lib.gbc )[T234b-0.1.0.0-inplace]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/lib/Lib.hs", startLine = 18, endLine = 18, startCol = 3, endCol = 14}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : ColonList = _+ value : ColonList = This is an IORef!+(hdb) Exiting...
+ test/golden/T237/T237.ghc-1001.hdb-stdout view
@@ -0,0 +1,16 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[T237-0.1.0.0-inplace-T237]+[;1m<TEMPORARY-DIRECTORY>/app/Main.hs:8:1: [;1m[35mwarning[0m[0m[;1m: [GHC-90177] [[;1m[35m-Worphans[0m[0m[;1m][0m[0m[;1m+ Orphan class instance: instance DebugView MyType+ Suggested fix:+ Move the instance declaration to the module of the class or of the type, or+ wrap the type with a newtype and declare the instance on the new type.[0m[0m+[;1m[34m |[0m[0m+[;1m[34m8 |[0m[0m [;1m[35minstance DebugView MyType where[0m[0m+[;1m[34m |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...[0m[0m++(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/app/Main.hs", startLine = 15, endLine = 15, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : MyType = _+ value : MyType = alpha:beta:gamma+(hdb) Exiting...
+ test/golden/T237/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+ cabal:+ components:+ - path: "app/"+ component: "exe:T237"
+ test/golden/T237b/T237.cabal view
@@ -0,0 +1,24 @@+cabal-version: 3.14+name: T237+version: 0.1.0.0+license: NONE+author: Rodrigo Mesquita+maintainer: rodrigo.m.mesquita@gmail.com+build-type: Simple++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: MyType+ build-depends: base+ hs-source-dirs: lib+ default-language: Haskell2010++executable T237+ import: warnings+ main-is: Main.hs+ build-depends: base, T237, haskell-debugger-view+ hs-source-dirs: app+ default-language: Haskell2010
+ test/golden/T237b/T237.ghc-1001.hdb-stdout view
@@ -0,0 +1,16 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[T237-0.1.0.0-inplace-T237]+[;1m<TEMPORARY-DIRECTORY>/app/Main.hs:8:1: [;1m[35mwarning[0m[0m[;1m: [GHC-90177] [[;1m[35m-Worphans[0m[0m[;1m][0m[0m[;1m+ Orphan class instance: instance DebugView MyType+ Suggested fix:+ Move the instance declaration to the module of the class or of the type, or+ wrap the type with a newtype and declare the instance on the new type.[0m[0m+[;1m[34m |[0m[0m+[;1m[34m8 |[0m[0m [;1m[35minstance DebugView MyType where[0m[0m+[;1m[34m |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...[0m[0m++(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/app/Main.hs", startLine = 15, endLine = 15, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : MyType = _+ value : MyType = alpha:beta:gamma+(hdb) Exiting...
+ test/golden/T237b/T237.ghc-914.hdb-stdout view
@@ -0,0 +1,16 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T237-0.1.0.0-inplace-T237]+[;1m<TEMPORARY-DIRECTORY>/app/Main.hs:8:1: [;1m[35mwarning[0m[0m[;1m: [GHC-90177] [[;1m[35m-Worphans[0m[0m[;1m][0m[0m[;1m+ Orphan class instance: instance DebugView MyType+ Suggested fix:+ Move the instance declaration to the module of the class or of the type, or+ wrap the type with a newtype and declare the instance on the new type.[0m[0m+[;1m[34m |[0m[0m+[;1m[34m8 |[0m[0m [;1m[35minstance DebugView MyType where[0m[0m+[;1m[34m |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...[0m[0m++(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/app/Main.hs", startLine = 15, endLine = 15, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : MyType = _+ value : MyType = alpha:beta:gamma+(hdb) Exiting...
+ test/golden/T237b/T237.hdb-stdin view
@@ -0,0 +1,3 @@+break app/Main.hs 15+run+variables
+ test/golden/T237b/T237b.ghc-1001.hdb-stdout view
@@ -0,0 +1,17 @@+[1 of 3] Compiling MyType ( <TEMPORARY-DIRECTORY>/lib/MyType.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/MyType.gbc )[T237-0.1.0.0-inplace]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[T237-0.1.0.0-inplace-T237]+[;1m<TEMPORARY-DIRECTORY>/app/Main.hs:8:1: [;1m[35mwarning[0m[0m[;1m: [GHC-90177] [[;1m[35m-Worphans[0m[0m[;1m][0m[0m[;1m+ Orphan class instance: instance DebugView MyType+ Suggested fix:+ Move the instance declaration to the module of the class or of the type, or+ wrap the type with a newtype and declare the instance on the new type.[0m[0m+[;1m[34m |[0m[0m+[;1m[34m8 |[0m[0m [;1m[35minstance DebugView MyType where[0m[0m+[;1m[34m |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...[0m[0m++(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/app/Main.hs", startLine = 15, endLine = 15, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : MyType = _+ value : MyType = alpha:beta:gamma+(hdb) Exiting...
+ test/golden/T237b/T237b.ghc-914.hdb-stdout view
@@ -0,0 +1,17 @@+[1 of 3] Compiling MyType ( <TEMPORARY-DIRECTORY>/lib/MyType.hs, interpreted )[T237-0.1.0.0-inplace]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T237-0.1.0.0-inplace-T237]+[;1m<TEMPORARY-DIRECTORY>/app/Main.hs:8:1: [;1m[35mwarning[0m[0m[;1m: [GHC-90177] [[;1m[35m-Worphans[0m[0m[;1m][0m[0m[;1m+ Orphan class instance: instance DebugView MyType+ Suggested fix:+ Move the instance declaration to the module of the class or of the type, or+ wrap the type with a newtype and declare the instance on the new type.[0m[0m+[;1m[34m |[0m[0m+[;1m[34m8 |[0m[0m [;1m[35minstance DebugView MyType where[0m[0m+[;1m[34m |[0m[0m[;1m[35m ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...[0m[0m++(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/app/Main.hs", startLine = 15, endLine = 15, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+value : MyType = _+ value : MyType = alpha:beta:gamma+(hdb) Exiting...
+ test/golden/T237b/T237b.hdb-test view
@@ -0,0 +1,1 @@+$HDB -v0 app/Main.hs 2>&1 < T237.hdb-stdin || true
+ test/golden/T237b/app/Main.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import Data.List (intercalate)++import GHC.Debugger.View.Class+import MyType++instance DebugView MyType where+ debugValue (MyType xs) = simpleValue (intercalate ":" xs) False+ debugFields _ = pure (VarFields [])++main :: IO ()+main = do+ let value = mkValue+ const (print value) value
+ test/golden/T237b/hie.yaml view
@@ -0,0 +1,3 @@+#version with barebone cabal cradle, to make sure session structure is not important+cradle:+ cabal:
+ test/golden/T237b/lib/MyType.hs view
@@ -0,0 +1,11 @@+module MyType+ ( MyType(..)+ , mkValue+ ) where++newtype MyType = MyType [String]+ deriving Show++mkValue :: MyType+mkValue = MyType ["alpha", "beta", "gamma"]+{-# OPAQUE mkValue #-}
+ test/golden/T239/T239.fails-239.ghc-1001.hdb-stdout view
@@ -0,0 +1,10 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 27, endLine = 27, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+container : Container = Container+ containerBefore : Int = _+ containerPacked : Packed = Packed+ containerPacked2 : Packed = Packed+ containerAfter : Int = _+(hdb) (hdb) Exiting...
+ test/golden/T239/T239.ghc-1001.hdb-stdout view
@@ -0,0 +1,11 @@+[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 27, endLine = 27, startCol = 3, endCol = 28}}+(hdb) Stopped at breakpoint+(hdb) _result : IO () = <fn> :: IO ()+container : Container = Container+ containerBefore : Int = _+ containerPacked : Char# = 'a'+ containerPacked2 : Char# = 'b'+ containerAfter : Char# = 'c'+(hdb) Exiting...
+ test/golden/T242/T242.ghc-1001.hdb-stdout view
@@ -0,0 +1,13 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 9, endLine = 9, startCol = 3, endCol = 10}}+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 11], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 3, endLine = 3, startCol = 3, endCol = 10}}+(hdb) Stopped at breakpoint+(hdb) Aborted: <interactive>:1:8: error: [GHC-88464]+ Variable not in scope: sort :: [Integer] -> a0+(hdb) +(hdb) [4,5,6]+()+(hdb) Stopped at breakpoint+(hdb) [1,2,3]+()+(hdb) Exiting...
test/golden/T242/T242.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 9, endLine = 9, startCol = 3, endCol = 10}} (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 11], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 3, endLine = 3, startCol = 3, endCol = 10}} (hdb) Stopped at breakpoint
+ test/golden/T283/T283.ghc-1001.hdb-stdout view
@@ -0,0 +1,9 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[T283-0.1.0.0-inplace-T283]+(hdb) +(hdb) THIS IS A PACKAGE+()+(hdb) Aborted: <interactive>:1:1: error: [GHC-35235]+ Could not find module `Main'.+ It is not a module in the current program, or in any known package.+(hdb) "If an older version of T283 was installed, we'd now shadow the home-unit Main with the outdated installed Main!"+(hdb) Exiting...
test/golden/T283/T283.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T283-0.1.0.0-inplace-T283]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T283-0.1.0.0-inplace-T283] (hdb) (hdb) THIS IS A PACKAGE ()
+ test/golden/T358/T358.ghc-1001.hdb-stdout view
@@ -0,0 +1,1 @@+Entry file "<TEMPORARY-DIRECTORY>/app/Main.hs" does not exist or is a directory.
+ test/golden/T358/T358.ghc-914.hdb-stdout view
@@ -0,0 +1,1 @@+Entry file "<TEMPORARY-DIRECTORY>/app/Main.hs" does not exist or is a directory.
+ test/golden/T358/T358.hdb-test view
@@ -0,0 +1,5 @@+#!/bin/sh++# Running hdb on a non-existent entry file should yield readable error and not+# something internal/inscrutable down the line+$HDB -v0 app/Main.hs 2>&1 || true
+ test/golden/T61/T61.ghc-1001.hdb-stdout view
@@ -0,0 +1,4 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/x/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) wrks+()+(hdb) Exiting...
test/golden/T61/T61.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/x/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/x/Main.hs, interpreted )[main] (hdb) wrks () (hdb) Exiting...
+ test/golden/T79/T79.ghc-1001.hdb-stdout view
@@ -0,0 +1,6 @@+cabal init ... > cabal-init.log 2>1++[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[T79-tmp-0.1.0.0-inplace-T79-tmp]+(hdb) Hello, Haskell!+()+(hdb) Exiting...
test/golden/T79/T79.ghc-914.hdb-stdout view
@@ -1,14 +1,6 @@-[Info] Using cabal specification: <VERSION>-[Warn] unknown license type, you must put a copy in LICENSE yourself.-[Info] Creating fresh file CHANGELOG.md...-[Info] Creating fresh directory ./app...-[Info] Creating fresh file app/Main.hs...-[Info] Creating fresh file T79-tmp.cabal...-[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.+cabal init ... > cabal-init.log 2>1 -[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 ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp] (hdb) Hello, Haskell! () (hdb) Exiting...
test/golden/T79/T79.ghc-915.hdb-stdout view
@@ -1,11 +1,4 @@-[Info] Using cabal specification: <VERSION>-[Warn] unknown license type, you must put a copy in LICENSE yourself.-[Info] Creating fresh file CHANGELOG.md...-[Info] Creating fresh directory ./app...-[Info] Creating fresh file app/Main.hs...-[Info] Creating fresh file T79-tmp.cabal...-[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.+cabal init ... > cabal-init.log 2>1 [1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] [2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/app/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[T79-tmp-0.1.0.0-inplace-T79-tmp]
test/golden/T79/T79.hdb-test view
@@ -1,4 +1,6 @@-cabal init -m -n -d base -p T79-tmp && $HDB app/Main.hs <<'EOF'+#We don't care to test the output of cabal init, but it might be helpful for debugging.+LOGFILE=cabal-init.log+echo "cabal init ... > $LOGFILE 2>1\n" && cabal init -m -n -d base -p T79-tmp > $LOGFILE 2>1 && $HDB app/Main.hs <<'EOF' run exit EOF
+ test/golden/T83/T83.ghc-1001.hdb-stdout view
@@ -0,0 +1,4 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) Heli+()+(hdb) Exiting...
test/golden/T83/T83.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main] (hdb) Heli () (hdb) Exiting...
+ test/golden/exceptions-multiple/exceptions-multiple.ghc-1001.hdb-stdout view
@@ -0,0 +1,22 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/prog/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw first+Stopped at breakpoint+Exception: ErrorCall+Message: boom first+Call stack:+ HasCallStack backtrace:+ error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10+(hdb) Handled first exception: boom first+Continuing after first exception+Stopped at breakpoint+Exception: ErrorCall+Message: boom second+Call stack:+ HasCallStack backtrace:+ error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:10:3 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:10:3+(hdb) Exiting...
test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main] (hdb) BreakFoundNoLoc {changed = True} (hdb) About to throw first Stopped at breakpoint
+ test/golden/exceptions-uncaught/exceptions-uncaught.ghc-1001.hdb-stdout view
@@ -0,0 +1,26 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/prog/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw+Handling exception: boom outer+Stopped at breakpoint+Exception: ErrorCall+Message: boom while handling+Call stack:+ While handling ghc-internal:GHC.Internal.Exception.ErrorCall:+ |+ | boom outer+ |+ | HasCallStack backtrace:+ | error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main+ + HasCallStack backtrace:+ error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:14:3 in main:Main+Inner exceptions:+ Exception: ErrorCall+ Message: boom outer+ Call stack:+ HasCallStack backtrace:+ error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:8:10 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:14:3+(hdb) Exiting...
test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main] (hdb) BreakFoundNoLoc {changed = True} (hdb) About to throw Handling exception: boom outer
+ test/golden/exceptions/exceptions.ghc-1001.hdb-stdout view
@@ -0,0 +1,12 @@+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/prog/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFoundNoLoc {changed = True}+(hdb) About to throw+Stopped at breakpoint+Exception: ErrorCall+Message: boom+Call stack:+ HasCallStack backtrace:+ error, called at <TEMPORARY-DIRECTORY>/prog/Main.hs:6:3 in main:Main++Exception location: <TEMPORARY-DIRECTORY>/prog/Main.hs:6:3+(hdb) Exiting...
test/golden/exceptions/exceptions.ghc-914.hdb-stdout view
@@ -1,5 +1,4 @@-[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 ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main]+[1 of 2] Compiling Main ( <TEMPORARY-DIRECTORY>/prog/Main.hs, interpreted )[main] (hdb) BreakFoundNoLoc {changed = True} (hdb) About to throw Stopped at breakpoint
+ test/golden/self-debug-cli/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ test/golden/self-debug-cli/debuggee.cabal view
@@ -0,0 +1,20 @@+cabal-version: 3.0+name: debuggee+version: 0.1.0.0+-- synopsis:+-- description:+author: +maintainer: +-- copyright:+build-type: Simple+extra-doc-files: CHANGELOG.md+-- extra-source-files:+++executable debuggee+ main-is: Main.hs+ -- other-modules:+ -- other-extensions:+ build-depends: base+ hs-source-dirs: .+ default-language: Haskell2010
+ test/golden/self-debug-cli/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+ cabal:+ component: "all"
test/golden/self-debug-cli/self-debug-cli.hdb-stdin view
@@ -1,5 +1,6 @@-break --name runDebugger+break --name GHC.Debugger.Monad.runDebugger run cli test/golden/self-debug-cli/Main.hs+print import GHC.Data.FastString print mkFastString "this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS)." print mkFastString "We have a DebugView FastString instance at this breakpoint." exit
+ test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-1001.hdb-stdout view
@@ -0,0 +1,5 @@+(hdb) Stopped at breakpoint+(hdb) +(hdb) this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS).+(hdb) We have a DebugView FastString instance at this breakpoint.+(hdb) Exiting...
test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-914.hdb-stdout view
@@ -1,4 +1,5 @@ (hdb) Stopped at breakpoint+(hdb) (hdb) this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS). (hdb) We have a DebugView FastString instance at this breakpoint. (hdb) Exiting...
test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test view
@@ -19,20 +19,26 @@ # # 5) When testing the sdist (just the packaged things), the root doesn't have a hie.yaml. # Add one temporarily++# Dedicated HIE file for self-debug tests.++yaml_file=hie-self-debug-test.yaml+ created_yaml=false-if [ ! -f hie.yaml ]; then- echo 'cradle:\n cabal:\n component: "all"' > hie.yaml+if [ ! -f "$yaml_file" ]; then+ printf 'cradle:\n cabal:\n component: "all"\n' > "$yaml_file" created_yaml=true; fi -$HDB -v0 hdb/Main.hs < "test/golden/self-debug-cli/self-debug-cli.hdb-stdin" 2>&1 \+$HDB -v0 --cradle-file="$yaml_file" hdb/Main.hs < "test/golden/self-debug-cli/self-debug-cli.hdb-stdin" 2>&1 \ | grep -v "BreakFound" \ | grep -v "] Compiling" \+ | grep -v "ld: warning: -U option is redundant when using -undefined dynamic_lookup" \ | sed \ -e 's|[^ ]*/Paths_haskell_debugger.hs|<AUTOGEN-DIR>/Paths_haskell_debugger.hs|g' \ -e 's|haskell-debugger-[0-9.][0-9.]*-inplace|haskell-debugger-<VERSION>-inplace|g' \ -e 's|haskell-debugger-view-[0-9.][0-9.]*-inplace|haskell-debugger-view-<VERSION>-inplace|g' if [ $created_yaml = true ]; then- rm hie.yaml+ rm "$yaml_file" fi
+ test/golden/standalone-multi-module/standalone-multi-module.ghc-1001.hdb-stdout view
@@ -0,0 +1,8 @@+[1 of 3] Compiling Helper ( <TEMPORARY-DIRECTORY>/Helper.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Helper.gbc )[main]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 25}}+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Helper 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Helper.hs", startLine = 5, endLine = 5, startCol = 3, endCol = 38}}+(hdb) Stopped at breakpoint+(hdb) Starting...+Stopped at breakpoint+(hdb) Exiting...
test/golden/standalone-multi-module/standalone-multi-module.ghc-914.hdb-stdout view
@@ -1,8 +1,7 @@-[1 of 4] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]-[2 of 4] Compiling Helper ( <TEMPORARY-DIRECTORY>/Helper.hs, interpreted )[main]-[3 of 4] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]+[1 of 3] Compiling Helper ( <TEMPORARY-DIRECTORY>/Helper.hs, interpreted )[main]+[2 of 3] Compiling Main ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 25}}-(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Helper 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/./Helper.hs", startLine = 5, endLine = 5, startCol = 3, endCol = 38}}+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Helper 4], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Helper.hs", startLine = 5, endLine = 5, startCol = 3, endCol = 38}} (hdb) Stopped at breakpoint (hdb) Starting... Stopped at breakpoint
test/haskell/Main.hs view
@@ -75,8 +75,9 @@ let baseFlags = "--disable-ipe-backtraces" let default_goldens = map (mkTest baseFlags) testsForExternal let intinterp_goldens = map (mkTest ("--internal-interpreter " ++ baseFlags)) testsForInternal+ let individualTimeout = 5*60*1_000_000 - defaultMain $+ defaultMain $ localOption (mkTimeout individualTimeout) $ testGroup "Tests" [ testGroup "Golden tests" default_goldens ,@@ -120,7 +121,10 @@ noTmpDir = ".no-tmp-dir" `isInfixOf` testName topAction :: IO LBS.ByteString- topAction | noTmpDir = testAction path =<< getCurrentDirectory -- a bit dangerous! used in the self-debug-cli test+ topAction | noTmpDir = do+ cwd <- getCurrentDirectory -- a bit dangerous! used in the self-debug-cli test+ withTmpDirFromRepo keepTmpDirs cwd (testAction path)+ | otherwise = withHermeticDir keepTmpDirs (takeDirectory path) (testAction (takeFileName path))
test/haskell/Test/DAP.hs view
@@ -125,6 +125,7 @@ , lcEntryPoint :: Maybe String , lcEntryArgs :: [String] , lcExtraGhcArgs :: [String]+ , lcCradleFile :: Maybe FilePath , lcInternalInterpreter :: Maybe Bool } @@ -137,6 +138,7 @@ , lcEntryPoint = Just "main" , lcEntryArgs = [] , lcExtraGhcArgs = []+ , lcCradleFile = Nothing , lcInternalInterpreter = Nothing } @@ -150,8 +152,10 @@ [ "entryPoint" .= ep | Just ep <- [lcEntryPoint] ] ++ [ "entryArgs" .= lcEntryArgs ] ++ [ "extraGhcArgs" .= lcExtraGhcArgs ] +++ [ "cradleFile" .= file | Just file <- [lcCradleFile] ] ++ [ "internalInterpreter" .= b | Just b <- [lcInternalInterpreter] ] + -- | Set breakpoints in a particular source file of a project at the given -- lines. setLineBreakpoints :: FilePath -- ^ project root@@ -224,15 +228,19 @@ -- | Fetch all variables from the scope with the given name in the top-most -- frame of the first thread. fetchScopeVars :: T.Text -> TestDAP VarsView-fetchScopeVars scopeName_ = do+fetchScopeVars = fetchScopeVarsOfFrame 0++fetchScopeVarsOfFrame :: Int -> T.Text -> TestDAP VarsView+fetchScopeVarsOfFrame frameIx scopeName_ = do Response{responseBody=Just ThreadsResponse{threads=t:_}} <- sync threadsRequest- Response{responseBody=Just StackTraceResponse{stackFrames=fr:_}} <- sync $ stackTraceRequest $+ Response{responseBody=Just StackTraceResponse{stackFrames=frames}} <- sync $ stackTraceRequest $ StackTraceArguments { DAP.stackTraceArgumentsThreadId = threadId t , DAP.stackTraceArgumentsStartFrame = Nothing , DAP.stackTraceArgumentsLevels = Nothing , DAP.stackTraceArgumentsFormat = Nothing }+ Just fr <- pure $ frames List.!? frameIx Response{responseBody=Just ScopesResponse{scopes=scs}} <- sync $ scopesRequest $ ScopesArguments { DAP.scopesArgumentsFrameId = stackFrameId fr } case List.find ((== scopeName_) . scopeName) scs of
test/haskell/Test/Integration/Basic.hs view
@@ -46,7 +46,7 @@ waitFiltering_ EventTy "initialized" setBreakOnException _ <- sync configurationDone- assertStoppedLocation DAP.StoppedEventReasonException 66 -- FIXME WHY IS THIS 66? in the NodeJS testsuite we ignored the line.+ assertStoppedLocation DAP.StoppedEventReasonException 10 -- Line in the test file disconnect ] where@@ -81,6 +81,7 @@ , lcEntryArgs = [] , lcExtraGhcArgs = [] , lcInternalInterpreter = Nothing+ , lcCradleFile = Nothing } hitBreakpointWith cfg 2 disconnect
test/haskell/Test/Integration/Evaluate.hs view
@@ -8,7 +8,9 @@ import Test.DAP import Test.Tasty import Test.Tasty.HUnit+#ifdef mingw32_HOST_OS import Test.Tasty.ExpectedFailure+#endif import qualified DAP evaluateTests :: TestTree@@ -21,8 +23,7 @@ evaluateStructured , testCase "Imported module bindings available in evaluate context (issue #233)" evaluateImportedBindings- , expectFailBecause "#299" $- testCase "Bindings from other modules not available in evaluate context (issue #233)"+ , testCase "Bindings from other modules not available in evaluate context (issue #233)" evaluateImportedBindingsNotInOtherModule ] @@ -91,6 +92,7 @@ let result = DAP.evaluateResponseResult mapFailResp liftIO $ assertBool ("expected 'not in scope' error for Map.fromList, got: " ++ show result)- ("not in scope" `isInfixOf` show result)+ (or [not_in_scope `isInfixOf` show result+ | not_in_scope <- ["not in scope","Not in scope"]]) disconnect
test/haskell/Test/Integration/MultiHomeUnit.hs view
@@ -6,6 +6,7 @@ import Test.DAP import Test.Tasty import Test.Tasty.HUnit+import System.FilePath ((</>)) #ifdef mingw32_HOST_OS import Test.Tasty.ExpectedFailure #endif@@ -16,37 +17,38 @@ ignoreTestBecause "Needs to be fixed for Windows (#199)" $ #endif testGroup "DAP.Integration.MultiHomeUnit"- [ testCase "should run program to the end" runToTheEnd- , testCase "should stop at break-point in the same home unit" sameHomeUnitBP- , testCase "should stop at break-point in different home unit 1" otherHomeUnitBP1- , testCase "should stop at break-point in different home unit 2" otherHomeUnitBP2+ [testGroup dirname [ testCase "should run program to the end" $ runToTheEnd dirname+ , testCase "should stop at break-point in the same home unit" $ sameHomeUnitBP dirname+ , testCase "should stop at break-point in different home unit 1" $ otherHomeUnitBP1 dirname+ , testCase "should stop at break-point in different home unit 2" $ otherHomeUnitBP2 dirname+ ] |+ dirname <- ["cabal-mhu1","T38"] ]--withCommonSetup :: (FilePath -> TestDAP ()) -> Assertion-withCommonSetup test =- withTestDAPServer "test/integration/cabal-mhu1" [] $ \test_dir server ->+withCommonSetup :: (FilePath -> TestDAP ()) -> String -> Assertion+withCommonSetup test dirname =+ withTestDAPServer ("test/integration" </> dirname) [] $ \test_dir server -> withTestDAPServerClient server $ do test test_dir disconnect -runToTheEnd :: Assertion+runToTheEnd :: String -> Assertion runToTheEnd = withCommonSetup $ \test_dir -> do let cfg = mkLaunchConfig test_dir "bar/app/Main.hs" runToEnd cfg -sameHomeUnitBP :: Assertion+sameHomeUnitBP :: String -> Assertion sameHomeUnitBP = withCommonSetup $ \test_dir -> do let cfg = mkLaunchConfig test_dir "bar/app/Main.hs" hitBreakpointWith cfg 8 -otherHomeUnitBP1 :: Assertion+otherHomeUnitBP1 :: String -> Assertion otherHomeUnitBP1 = withCommonSetup $ \test_dir -> do -- Use bar/app/Main.hs as the entry file; set a breakpoint in a -- *different* home unit (bar/src/Bar.hs). let cfg = mkLaunchConfig test_dir "bar/app/Main.hs" hitBreakpointIn cfg "bar/src/Bar.hs" 8 -otherHomeUnitBP2 :: Assertion+otherHomeUnitBP2 :: String -> Assertion otherHomeUnitBP2 = withCommonSetup $ \test_dir -> do let cfg = mkLaunchConfig test_dir "bar/app/Main.hs" hitBreakpointIn cfg "foo/src/Foo.hs" 6
test/haskell/Test/Integration/SelfDebug.hs view
@@ -32,8 +32,9 @@ doesFileExist (test_dir </> "cabal.project") >>= \exists -> unless exists $ writeFile (test_dir </> "cabal.project") "packages: . haskell-debugger-view\nallow-newer: ghc-bignum,containers,time,ghc,base,template-haskell"- doesFileExist (test_dir </> "hie.yaml") >>= \exists ->- unless exists $ writeFile (test_dir </> "hie.yaml")+ let hieFileName = "hie-self-debug-test.yaml"+ doesFileExist (test_dir </> hieFileName) >>= \exists ->+ unless exists $ writeFile (test_dir </> hieFileName) "cradle:\n cabal:\n component: \"all\"" withTestDAPServerClient server $ do let cfg = LaunchConfig@@ -42,6 +43,7 @@ , lcEntryPoint = Just "main" , lcEntryArgs = ["cli", "test/golden/self-debug-cli/Main.hs"] , lcExtraGhcArgs = []+ , lcCradleFile = Just hieFileName , lcInternalInterpreter = Nothing } @@ -49,7 +51,7 @@ waitFiltering_ EventTy "initialized" _ <- sync $ setFunctionBreakpointsRequest @_ @Value $ object- [ "breakpoints" .= [ object [ "name" .= ("runDebugger" :: String) ] ] ]+ [ "breakpoints" .= [ object [ "name" .= ("GHC.Debugger.Monad.runDebugger" :: String) ] ] ] _ <- sync configurationDone
test/haskell/Test/Integration/StackTrace.hs view
@@ -10,6 +10,7 @@ #ifdef mingw32_HOST_OS import Test.Tasty.ExpectedFailure #endif+import qualified Data.Text as Text import DAP (threadId, stackFrameName) stackTraceTests :: TestTree@@ -52,8 +53,7 @@ liftIO $ do -- Contains the stack annotations assertBool ("should contain 'Lovely annotation': " ++ show names)- ("Lovely annotation" `elem` names)+ (any ("Lovely annotation" `Text.isPrefixOf`) names) assertBool ("should contain '[1,2,3,4]': " ++ show names)- ("[1,2,3,4]" `elem` names)+ (any ("[1,2,3,4]" `Text.isPrefixOf`) names) disconnect-
test/haskell/Test/Integration/Variables.hs view
@@ -12,6 +12,7 @@ import Test.Tasty.ExpectedFailure #endif import DAP (Variable, variableValue)+import GHC.Debugger.Runtime.FFIInspect (stack_bco_frame_selftest) variableTests :: TestTree variableTests =@@ -33,6 +34,14 @@ , testCase "hdv with containers (issue #47c)" hdvContainersDepTest , testCase "hdv in-memory with containers (issue #47d)" hdvContainersMemTest , testCase "hdv in-memory with text (issue #47e)" hdvTextMemTest+ , testCase "force thunk in IntMap value persists (issue #47f)" thunkIntMapTest+ , testGroup "variables from earlier stack frames (issue #160)"+ [ testCase "multiple stack frames" stackFramesTest+ , testCase "RetBCO waiting for unboxed tuple" stackFramesUnboxedTupleTest+ , testCase "stack_bco_frame_self_test"+ stackBCOFrameSelfTest+ ]+ , testCase "variables of stack frames work with shadowed module dep (issue #365)" stackFramesShadowingTest ] intsAndStringsTest :: Assertion@@ -319,3 +328,69 @@ action <- forceLazy (locals % "action") action @==? "\"this should be displayed as a simple string\"" disconnect++-- | An IntMap with lazy thunk values. The field value is the actual IntMap+-- elem heap value, so forcing it is persisted across refreshes (because we're+-- still referring to the same heap value, and now it happens to be forced)+thunkIntMapTest :: Assertion+thunkIntMapTest =+ withTestDAPServer "test/integration/T47f" [] $ \test_dir server ->+ withTestDAPServerClient server $ do+ let cfg = mkLaunchConfig test_dir "Main.hs"+ hitBreakpointWith cfg 12+ locals <- fetchLocalVars+ action <- forceLazy (locals % "action")+ action @==? "IntMap"+ ac <- expandVar action+ v1 <- forceLazy (ac % "1")+ v1 @==? "5050"++ -- Re-request the parent and check the previously-forced value remains+ -- evaluated (no force needed).+ locals2 <- fetchLocalVars+ ac2 <- expandVar (locals2 % "action")+ (ac2 % "1") @==? "5050"+ disconnect++stackFramesTest :: Assertion+stackFramesTest = stackFramesTestGen "test/integration/T160"++stackFramesShadowingTest :: Assertion+stackFramesShadowingTest = stackFramesTestGen "test/integration/T365"++stackFramesTestGen :: FilePath -> Assertion+stackFramesTestGen path =+ withTestDAPServer path [] $ \test_dir server ->+ withTestDAPServerClient server $ do+ let cfg = mkLaunchConfig test_dir "Main.hs"+ hitBreakpointIn cfg "X.hs" 22+ locals <- fetchScopeVarsOfFrame 1 "Locals"+ xs <- expandVar (locals % "xs")+ (xs % "0") @==? "1"++ locals2 <- fetchScopeVarsOfFrame 2 "Locals"+ s <- pure (locals2 % "s")+ s @==? "\"hello\""++ locals3 <- fetchScopeVarsOfFrame 3 "Locals"+ x <- pure (locals3 % "x")+ x @==? "5"++ disconnect++stackFramesUnboxedTupleTest :: Assertion+stackFramesUnboxedTupleTest =+ withTestDAPServer "test/integration/T160" [] $ \test_dir server ->+ withTestDAPServerClient server $ do+ let cfg = mkLaunchConfig test_dir "Main.hs"+ hitBreakpointIn cfg "X.hs" 27+ locals <- fetchScopeVarsOfFrame 1 "Locals"+ x <- pure (locals % "x")+ x @==? "1"++ disconnect++stackBCOFrameSelfTest :: Assertion+stackBCOFrameSelfTest = do+ b <- stack_bco_frame_selftest+ assertEqual "Errors, see stderr" b True
test/haskell/Test/Utils.hs view
@@ -2,7 +2,7 @@ import Control.Monad (when) import Data.List (isInfixOf)-import System.Directory (doesFileExist)+import System.Directory (doesFileExist,doesDirectoryExist) import System.FilePath import System.IO.Temp import qualified System.Process as P@@ -14,7 +14,7 @@ -> (FilePath -> IO r) -- ^ Continuation receives hermetic test dir (in temporary dir) -> IO r withHermeticDir keep src k = do- withTmpDir "hdb-test" $ \dest -> do+ withTestTmpDir keep $ \dest -> do P.callCommand $ "cp -r " ++ src ++ " " ++ dest let destTestDir = dest </> takeBaseName src -- Some test projects reference @./haskell-debugger-view@ in their@@ -24,14 +24,6 @@ cpHaskellDebuggerViewIfNeeded destTestDir k destTestDir where- withTmpDir | keep = withPersistentSystemTempDirectory- | otherwise = withSystemTempDirectory-- withPersistentSystemTempDirectory :: String -> (FilePath -> IO r) -> IO r- withPersistentSystemTempDirectory template k' = do- dir <- flip createTempDirectory template =<< getCanonicalTemporaryDirectory- k' dir- cpHaskellDebuggerViewIfNeeded testDir = do let cabalProject = testDir </> "cabal.project" existsCP <- doesFileExist cabalProject@@ -41,3 +33,37 @@ P.callCommand $ "cp -r haskell-debugger-view " ++ testDir </> "haskell-debugger-view" ++withTestTmpDir :: Bool -- ^ Whether to keep the temp dir around for inspection+ -> (FilePath -> IO r) -- ^ Continuation receives temporary dir+ -> IO r+withTestTmpDir keep k = do+ withTmpDir "hdb-test" k+ where+ withTmpDir | keep = withPersistentSystemTempDirectory+ | otherwise = withSystemTempDirectory++ withPersistentSystemTempDirectory :: String -> (FilePath -> IO r) -> IO r+ withPersistentSystemTempDirectory template k' = do+ dir <- flip createTempDirectory template =<< getCanonicalTemporaryDirectory+ k' dir+++withTmpDirFromRepo :: Bool -- ^ Whether to keep the temp dir around for inspection+ -> FilePath -- ^ Test dir+ -> (FilePath -> IO r) -- ^ Continuation receives temporary dir+ -> IO r+withTmpDirFromRepo keep src k = do+ b <- doesDirectoryExist $ src </> ".git"+ withTestTmpDir keep $ \ dest -> do+ case b of+ False -> do+ P.callCommand $ "cp -r " ++ src ++ "/. " ++ dest+ True -> do+ P.callCommand $ unwords+ [ "git ls-files -z --full-name --"+ , src+ , "| cpio -0 -pdm "+ , dest+ ]+ k dest
test/integration/T107a/hie.yaml view
@@ -1,3 +1,3 @@ cradle: cabal:- components: "exe:t3"+ component: "exe:t3"
test/integration/T159/T159.cabal view
@@ -9,4 +9,3 @@ ghc-experimental, hs-source-dirs: app, default-language: Haskell2010- ghc-options: -finfo-table-map
+ test/integration/T160/Main.hs view
@@ -0,0 +1,29 @@+module Main where++import X++main :: IO ()+main = do+ putStrLn "Testing stack frames:"+ print (h 1)+ print (function1 5)+ print (function2 "hello")++function1 :: Int -> String+function1 x =+ -- Call function2 as the case scrutinee and do extra processing so it's not a tail call+ case function2 (if x == 0 then "foo" else "hello") of+ "no" -> "function1 saw no"+ "yes" -> "function1 saw yes"+ other -> "f1-" ++ other++function2 :: String -> String+function2 s =+ -- Call function3 as the case scrutinee and transform its result+ case function3 (case s of+ "hello" -> [1,2]+ "foo" -> []+ other -> [length other]) of+ "no" -> "function2-no"+ "yes" -> "function2-yes"+ other -> other ++ "-f2"
+ test/integration/T160/T160-tmp.cabal view
@@ -0,0 +1,19 @@+cabal-version: 3.14+name: T160-tmp+version: 0.1.0.0+license: NONE+author: Andrea Vezzosi+maintainer: andrea@well-typed.com+build-type: Simple+extra-doc-files: CHANGELOG.md++common warnings+ ghc-options: -Wall++executable T160-tmp+ import: warnings+ main-is: Main.hs+ build-depends: base+ hs-source-dirs: .+ other-modules: X+ default-language: Haskell2010
+ test/integration/T160/X.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE UnboxedTuples #-}+module X where++-- preserves var in continuation+-- also workaround for "bitmap of size 0" bug.+{-# OPAQUE keep #-}+keep :: a -> b -> b+keep x y = seq x y++function3 :: [Int] -> String+function3 xs =+ -- Call function4 as the case scrutinee and add non-tail processing+ case function4 (sum xs > 0) of+ "no" -> keep xs "function3-no"+ "yes" -> keep xs "function3-yes"+ other -> "function3-" ++ other++function4 :: Bool -> String+function4 b = do+ -- Use a case expression on the Bool+ case b of+ True -> keep b "yes"+ False -> "no"++g :: Int -> (# Int, Int, Int #)+g x =+ (# x, x + 1, x + 2 #)++h :: Int -> Int+h x = case g x of -- alts frame expects an unboxed tuple+ (# a, b, _ #) -> a + b
+ test/integration/T160/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ test/integration/T160/hie.yaml view
@@ -0,0 +1,1 @@+{"cradle": {"cabal": null}}
+ test/integration/T365/GHC/Exts/Heap.hs view
@@ -0,0 +1,3 @@+module GHC.Exts.Heap where++
+ test/integration/T365/Main.hs view
@@ -0,0 +1,29 @@+module Main where++import X++main :: IO ()+main = do+ putStrLn "Testing stack frames:"+ print (h 1)+ print (function1 5)+ print (function2 "hello")++function1 :: Int -> String+function1 x =+ -- Call function2 as the case scrutinee and do extra processing so it's not a tail call+ case function2 (if x == 0 then "foo" else "hello") of+ "no" -> "function1 saw no"+ "yes" -> "function1 saw yes"+ other -> "f1-" ++ other++function2 :: String -> String+function2 s =+ -- Call function3 as the case scrutinee and transform its result+ case function3 (case s of+ "hello" -> [1,2]+ "foo" -> []+ other -> [length other]) of+ "no" -> "function2-no"+ "yes" -> "function2-yes"+ other -> other ++ "-f2"
+ test/integration/T365/T160-tmp.cabal view
@@ -0,0 +1,19 @@+cabal-version: 3.14+name: T160-tmp+version: 0.1.0.0+license: NONE+author: Andrea Vezzosi+maintainer: andrea@well-typed.com+build-type: Simple+extra-doc-files: CHANGELOG.md++common warnings+ ghc-options: -Wall++executable T160-tmp+ import: warnings+ main-is: Main.hs+ build-depends: base+ hs-source-dirs: .+ other-modules: X, GHC.Exts.Heap+ default-language: Haskell2010
+ test/integration/T365/X.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE UnboxedTuples #-}+module X where++-- preserves var in continuation+-- also workaround for "bitmap of size 0" bug.+{-# OPAQUE keep #-}+keep :: a -> b -> b+keep x y = seq x y++function3 :: [Int] -> String+function3 xs =+ -- Call function4 as the case scrutinee and add non-tail processing+ case function4 (sum xs > 0) of+ "no" -> keep xs "function3-no"+ "yes" -> keep xs "function3-yes"+ other -> "function3-" ++ other++function4 :: Bool -> String+function4 b = do+ -- Use a case expression on the Bool+ case b of+ True -> keep b "yes"+ False -> "no"++g :: Int -> (# Int, Int, Int #)+g x =+ (# x, x + 1, x + 2 #)++h :: Int -> Int+h x = case g x of -- alts frame expects an unboxed tuple+ (# a, b, _ #) -> a + b
+ test/integration/T365/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ test/integration/T365/hie.yaml view
@@ -0,0 +1,1 @@+{"cradle": {"cabal": null}}
+ test/integration/T38/bar/app/Main.hs view
@@ -0,0 +1,9 @@+module Main where++import Bar+import Foo++main :: IO ()+main = do+ myFibonacciTest+ print (fib 5)
+ test/integration/T38/bar/bar.cabal view
@@ -0,0 +1,20 @@+cabal-version: 3.8+name: bar+version: 0.1.0.0+build-type: Simple++library+ exposed-modules: Bar+ build-depends:+ base,+ foo,+ hs-source-dirs: src+ default-language: Haskell2010++executable bar-exe+ main-is: app/Main.hs+ build-depends:+ base,+ bar,+ foo,+ default-language: Haskell2010
+ test/integration/T38/bar/src/Bar.hs view
@@ -0,0 +1,10 @@+module Bar where++import Foo++myFibonacciTest :: IO ()+myFibonacciTest = do+ print (fib 1)+ print (fib 4)+ print (fib 8)+ print (fib 10)
+ test/integration/T38/cabal.project view
@@ -0,0 +1,3 @@+packages:+ ./foo+ ./bar
+ test/integration/T38/foo/foo.cabal view
@@ -0,0 +1,10 @@+cabal-version: 3.8+name: foo+version: 0.1.0.0+build-type: Simple++library+ exposed-modules: Foo+ build-depends: base+ hs-source-dirs: src+ default-language: Haskell2010
+ test/integration/T38/foo/src/Foo.hs view
@@ -0,0 +1,6 @@+module Foo where++fib :: Int -> Int+fib n+ | n <= 1 = 1+ | otherwise = fib (n - 1) + fib (n - 2)
+ test/integration/T47f/Main.hs view
@@ -0,0 +1,12 @@+module Main where+-- IntMap with lazy thunk values: the thunk lives in the real data+-- structure, so forcing it persists across debugFields calls.++import qualified Data.IntMap.Lazy as IM++main :: IO ()+main = f (IM.fromList [(1, sum [1 .. 100 :: Int]), (2, sum [1 .. 200 :: Int])])++f :: Show a => a -> IO ()+f action = do+ print action
+ test/integration/T47f/T47f.cabal view
@@ -0,0 +1,17 @@+cabal-version: 3.14+name: T47f+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 t47f+ import: warnings+ main-is: Main.hs+ build-depends: base, containers+ hs-source-dirs: .+ default-language: Haskell2010
test/integration/cabal1/app/Main.hs view
@@ -7,7 +7,7 @@ args <- getArgs putStrLn "hello" print args- fail "CATCH ME" `catch` (\(_::SomeException) -> putStrLn "caught it")+ throwIO (ErrorCall "CATCH ME") `catch` (\(_::SomeException) -> putStrLn "caught it") putStrLn "goodbye" putStrLn (f 2 4 "call_fxxx")
test/integration/simple/Main.hs view
@@ -7,6 +7,6 @@ args <- getArgs putStrLn "hello" print args- fail "CATCH ME" `catch` (\(_::SomeException) -> putStrLn "caught it")+ throwIO (ErrorCall "CATCH ME") `catch` (\(_::SomeException) -> putStrLn "caught it") putStrLn "goodbye" return ()