diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for haskell-debugger +## 0.12.2.0 -- 2026-03-09 + +* Bug fixes and improved progress reporting +* It's now possible interactively debug GHC itself! This works by simply: + 1. Using GHC 9.14 as the boot compiler + 2. Creating .vscode/launch.json in the GHC tree root with + * `entryFile: "ghc/Main.hs"` + * `entryArgs: "["-B${workspaceFolder}/_build/stage0/lib/", "Test.hs"]"` + ## 0.12.1.0 -- 2026-02-24 * Update range of supported runtime `haskell-debugger-view` versions to `0.2.*` diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -1,6 +1,6 @@ cabal-version: 3.12 name: haskell-debugger -version: 0.12.1.0 +version: 0.12.2.0 synopsis: A step-through debugger for GHC Haskell @@ -9,17 +9,17 @@ programs and can act as a Debug Adapter Protocol (DAP) server in the @server@ mode for debugging Haskell programs. - . + The Debug Adapter is implemented on top of the @haskell-debugger@ library which defines the primitive debugging capabilities. These debugger features are implemented by managing a GHC session and debugging it through the GHC API. - . + The @hdb@ is transparently compatible with most projects because it uses @hie-bios@ to figure out the right flags to invoke GHC with. - . + Additional information can be found [in the README](https://github.com/well-typed/haskell-debugger). license: BSD-3-Clause @@ -38,6 +38,13 @@ haskell-debugger-view/src/GHC/Debugger/View/Text.hs haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs + -- Should probably be extra extra-files but that requires cabal 3.14 + test/golden/**/*.hs + test/golden/**/*.hdb-stdin + test/golden/**/*.hdb-stdout + test/golden/**/*.hdb-test + test/golden/**/*.debuggee-stdin + homepage: https://github.com/well-typed/haskell-debugger bug-reports: https://github.com/well-typed/haskell-debugger/issues @@ -109,7 +116,7 @@ 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.18, + hie-bios >= 0.15 && < 0.19, file-embed >= 0.0.16 && < 0.1, attoparsec >= 0.13 && < 0.15, time >= 1.14 && < 2, @@ -159,6 +166,7 @@ haskell-debugger, hie-bios, + prettyprinter ^>= 1.7.0, co-log-core >= 0.3.2.5 && < 0.4, implicit-hie ^>=0.1.4.0, transformers >= 0.6 && < 0.7, diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -165,7 +165,8 @@ } -- | Run a 'Debugger' action on a session constructed from a given GHC invocation. -runDebugger :: LogAction IO DebuggerLog +runDebugger :: forall a + . LogAction IO DebuggerLog -> FilePath -- ^ Cradle root directory -> FilePath -- ^ Component root directory -> FilePath -- ^ The libdir (given with -B as an arg) @@ -268,135 +269,142 @@ } } - when (GHC.gopt GHC.Opt_ExternalInterpreter dflags2) $ liftIO $ void $ do - -- The external interpreter is spawned lazily, so we block waiting for - -- the handles to be available in a new thread. - forkIO $ do + 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)) - -- 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 + mainGhcThread :: Ghc a + mainGhcThread = do + -- Initializes interpreter! + _ <- GHC.setSessionDynFlags dflags2 - GHC.getSessionDynFlags >>= \df -> liftIO $ - GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df) + -- Initialise plugins here because the plugin author might already expect this + -- subsequent call to `getLogger` to be affected by a plugin. + GHC.initializeSessionPlugins - -- Discover the user-given flags and targets - flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir - buildWays <- liftIO $ validateUnitsWays flagsAndTargets + GHC.getSessionDynFlags >>= \df -> liftIO $ + GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df) - -- Setup base HomeUnitGraph - setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) - -- Downsweep user-given modules first - mod_graph_base <- doDownsweep Nothing + -- Discover the user-given flags and targets + flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir + buildWays <- liftIO $ validateUnitsWays flagsAndTargets - if_cache <- Just <$> liftIO newIfaceCache + -- Setup base HomeUnitGraph + setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) + -- Downsweep user-given modules first + mod_graph_base <- doDownsweep Nothing - -- Try to find or load the built-in classes from `haskell-debugger-view` - (hdv_uid, loadedBuiltinModNames) <- findHsDebuggerViewUnitId mod_graph_base >>= \case - Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do + if_cache <- Just <$> liftIO newIfaceCache - -- 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. + -- Try to find or load the built-in classes from `haskell-debugger-view` + (hdv_uid, loadedBuiltinModNames) <- findHsDebuggerViewUnitId mod_graph_base >>= \case + Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do - -- 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 + -- 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. - 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 + -- 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 - 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 + tryLoadHsDebuggerViewModule l if_cache (const False) debuggerViewClassModName debuggerViewClassContents + >>= \case + Failed -> do + -- Failed to load base debugger-view module! ghcLog <& DebuggerLog Logger.Debug - (LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids)) + (LogFailedToCompileDebugViewModule debuggerViewClassModName) return [] + Succeeded -> (debuggerViewClassModName:) . concat <$> do - 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) + 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 [] - -- 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 + 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) - -- Set interactive context to import all loaded modules - let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" - -- dbgView should always be available, either because we manually loaded it - -- or because it's in the transitive closure. - let dbgViewImps - -- Using in-memory hs-dbg-view. It's a home-unit, so refer to it directly - | hdv_uid == hsDebuggerViewInMemoryUnitId - = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames - -- It's available in a unit in the transitive closure. Resolve it. - | otherwise - = map (\mn -> - GHC.IIDecl (GHC.simpleImportDecl mn) - { ideclPkgQual = RawPkgQual - StringLiteral - { sl_st = NoSourceText - , sl_fs = mkFastString (unitIdString hdv_uid) - , sl_tc = Nothing - } - }) loadedBuiltinModNames + -- 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 - mss <- getAllLoadedModules + -- Set interactive context to import all loaded modules + let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" + -- dbgView should always be available, either because we manually loaded it + -- or because it's in the transitive closure. + let dbgViewImps + -- Using in-memory hs-dbg-view. It's a home-unit, so refer to it directly + | hdv_uid == hsDebuggerViewInMemoryUnitId + = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames + -- It's available in a unit in the transitive closure. Resolve it. + | otherwise + = map (\mn -> + GHC.IIDecl (GHC.simpleImportDecl mn) + { ideclPkgQual = RawPkgQual + StringLiteral + { sl_st = NoSourceText + , sl_fs = mkFastString (unitIdString hdv_uid) + , sl_tc = Nothing + } + }) loadedBuiltinModNames - GHC.setContext - (preludeImp : - dbgViewImps ++ - map (GHC.IIModule . GHC.ms_mod) mss) + mss <- getAllLoadedModules - -- 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 + GHC.setContext + (preludeImp : + dbgViewImps ++ + map (GHC.IIModule . GHC.ms_mod) mss) - runReaderT action - =<< initialDebuggerState dbgLog - (if loadedBuiltinModNames == [] - then Nothing - else Just hdv_uid) + -- 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 + + runReaderT action + =<< initialDebuggerState dbgLog + (if loadedBuiltinModNames == [] + then Nothing + else Just hdv_uid) + + fwd_thr <- liftIO $ async (void externalInterpFwdThread) + liftIO $ link fwd_thr + mainGhcThread {- Note [Custom external interpreter] diff --git a/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs b/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs @@ -211,8 +211,8 @@ 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 - Just (index_at 1#, index_at 2#, index_at 3#, index_at 4#, index_at 5#) - else Nothing""" + 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) diff --git a/haskell-debugger/GHC/Debugger/Stopped/Exception.hs b/haskell-debugger/GHC/Debugger/Stopped/Exception.hs --- a/haskell-debugger/GHC/Debugger/Stopped/Exception.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Exception.hs @@ -75,21 +75,23 @@ -- | This helper looks at the exception context for an exception, and retrieves -- the last entry of the HasCallStack backtrace. exceptionLocationExpr :: String -exceptionLocationExpr =""" +exceptionLocationExpr = """ let fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of - Just (_, loc) -> Just ( GHC.Exception.srcLocFile loc - , GHC.Exception.srcLocStartLine loc - , GHC.Exception.srcLocStartCol loc) + Data.Maybe.Just (_, loc) + -> Data.Maybe.Just + ( GHC.Exception.srcLocFile loc + , GHC.Exception.srcLocStartLine loc + , GHC.Exception.srcLocStartCol loc) go exc = let ctx = Control.Exception.someExceptionContext exc bts :: [Control.Exception.Backtrace.Backtraces] bts = Control.Exception.Context.getExceptionAnnotations ctx in case bts of bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of - Just cs -> fromCallStack cs - Nothing -> Nothing - [] -> Nothing + Data.Maybe.Just cs -> fromCallStack cs + Data.Maybe.Nothing -> Data.Maybe.Nothing + [] -> Data.Maybe.Nothing in go """ @@ -147,31 +149,31 @@ -- We need a specific datatype because ExceptionInfoNode is recursive. exceptionInfoData :: String exceptionInfoData = - "data ExceptionInfoNode = ExceptionInfoNode String String String (Maybe String) [ExceptionInfoNode]" + "data ExceptionInfoNode = ExceptionInfoNode String String String (Data.Maybe.Maybe String) [ExceptionInfoNode]" -- | Helper expression run in the debuggee that walks the exception context and -- populates the 'ExceptionInfoNode' structure. exceptionInfoExpr :: String exceptionInfoExpr = """ - let collectExceptionInfo :: SomeException -> ExceptionInfoNode + let collectExceptionInfo :: Control.Exception.SomeException -> ExceptionInfoNode collectExceptionInfo se' = case se' of - SomeException exc -> + Control.Exception.SomeException exc -> let ctx = Control.Exception.someExceptionContext se' rendered = Control.Exception.Context.displayExceptionContext ctx whileHandling = Control.Exception.Context.getExceptionAnnotations ctx - innerNodes = map (collectExceptionInfo . unwrap) whileHandling + innerNodes = Prelude.map (collectExceptionInfo Prelude.. unwrap) whileHandling simpleTypeName = Data.Typeable.tyConName tc modulePrefix = case Data.Typeable.tyConModule tc of - mdl | null mdl -> \"\" - | otherwise -> mdl ++ \".\" + mdl | Prelude.null mdl -> \"\" + | otherwise -> mdl Prelude.++ \".\" packagePrefix = case Data.Typeable.tyConPackage tc of - pkg | null pkg -> \"\" - | otherwise -> pkg ++ \":\" + pkg | Prelude.null pkg -> \"\" + | otherwise -> pkg Prelude.++ \":\" tc = Data.Typeable.typeRepTyCon (Data.Typeable.typeOf exc) - fullTypeName = packagePrefix ++ modulePrefix ++ simpleTypeName + fullTypeName = packagePrefix Prelude.++ modulePrefix Prelude.++ simpleTypeName unwrap (Control.Exception.WhileHandling inner) = inner - contextText = if null rendered then Nothing else Just rendered + contextText = if Prelude.null rendered then Data.Maybe.Nothing else Data.Maybe.Just rendered in ExceptionInfoNode simpleTypeName fullTypeName diff --git a/hdb/Development/Debug/Adapter/Handles.hs b/hdb/Development/Debug/Adapter/Handles.hs --- a/hdb/Development/Debug/Adapter/Handles.hs +++ b/hdb/Development/Debug/Adapter/Handles.hs @@ -18,7 +18,6 @@ import GHC.IO.Handle import System.Process import Control.Exception -import Control.Monad import Control.Concurrent.Async handleLogger :: Handle -> IO (LogAction IO T.Text) @@ -117,10 +116,16 @@ -- | Thread to read from the intercepted stdout pipe and forward onwards forwardingThread :: (T.Text -> IO ()) -> Handle -> IO () -forwardingThread write_action fromPipe = forever $ do - line <- T.hGetLine fromPipe - write_action line - +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) diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -24,7 +24,7 @@ import System.IO import GHC.IO.Encoding import Control.Monad.Catch -import Control.Exception (SomeAsyncException, throwIO) +import Control.Exception (SomeAsyncException, throwIO, IOException) import Control.Concurrent import GHC.Conc.Sync (labelThread) import Control.Monad @@ -114,7 +114,26 @@ projectRoot <- maybe (liftIO getCurrentDirectory) pure givenRoot - let hieBiosLogger = contramap DAPSessionSetupLog l + -- 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 $ InitFailed e Right (Left e) -> lift $ exitWithMsg e @@ -126,12 +145,6 @@ hSetBuffering writeExternalIntStdin NoBuffering hSetEncoding readExternalIntStdin utf8 hSetEncoding writeExternalIntStdin utf8 - when (not preferInternalInterpreter) $ liftIO $ void $ do - -- forward proxy in to external interpreter stdin - forkIO $ forever $ do - i <- readChan syncProxyIn - -- 3. Write to write-end of the pipe - BS.hPut writeExternalIntStdin i >> hFlush writeExternalIntStdin let nextFreshId = 0 breakpointMap = mempty @@ -144,21 +157,10 @@ , externalInterpreterStdinStream = UseHandle readExternalIntStdin } - -- 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 - finished_init <- liftIO $ newEmptyMVar dbgLog <- liftIO $ - createDebuggerLogger l writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr) + createDebuggerLogger l dapLogger writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr) let absEntryFile = normalise $ projectRoot entryFile lift $ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..} @@ -173,6 +175,14 @@ , if preferInternalInterpreter then stdinForwardThread supportsRunInTerminal syncProxyIn else mempty , if preferInternalInterpreter then stdoutCaptureThread supportsRunInTerminal syncProxyOut else mempty , if preferInternalInterpreter then stderrCaptureThread supportsRunInTerminal syncProxyErr else mempty + , if preferInternalInterpreter + then mempty + else const $ do + -- forward proxy in to external interpreter stdin + forever $ do + i <- readChan syncProxyIn + -- 3. Write to write-end of the pipe + BS.hPut writeExternalIntStdin i >> hFlush writeExternalIntStdin ] -- Do not return until the initialization is finished @@ -275,11 +285,11 @@ -- See Note [Debugger, debuggee, and DAP logs] createDebuggerLogger :: LogAction IO DAPLog - -> Handle -- ^ Handle to write to DAP output + -> LogAction IO T.Text -- ^ Logger that writes to to DAP output + -> Handle -- ^ Handle to DAP output -> (Bool, Chan BS.ByteString, Chan BS.ByteString) -- ^ Proxy channels, and whether is supported -> IO (LogAction IO Debugger.DebuggerLog) -createDebuggerLogger l writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr) = do - dapLogger <- handleLogger writeDAPOutput +createDebuggerLogger l dapLogger writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr) = do return $ -- (1) (all output is logged to normal logger) contramap DAPDebuggerLog l <> @@ -342,7 +352,10 @@ writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") -- Always output to Debug Console - withAdaptor $ Output.stdout line + catch + (withAdaptor $ Output.stdout line) + (\(_ :: IOException) -> + throwIO (FailedToWriteToAdaptor line)) -- | Like 'stdoutCaptureThread' but for stderr stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () @@ -358,7 +371,7 @@ -- Always output to Debug Console catch (withAdaptor $ Output.stderr line) - (\(_ :: SomeException) -> + (\(_ :: IOException) -> throwIO (FailedToWriteToAdaptor line)) newtype FailedToWriteToAdaptor = FailedToWriteToAdaptor T.Text diff --git a/hdb/Development/Debug/Adapter/Proxy.hs b/hdb/Development/Debug/Adapter/Proxy.hs --- a/hdb/Development/Debug/Adapter/Proxy.hs +++ b/hdb/Development/Debug/Adapter/Proxy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, DerivingStrategies #-} +{-# LANGUAGE BlockArguments, OverloadedStrings, DerivingStrategies #-} -- | 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' module Development.Debug.Adapter.Proxy @@ -8,6 +8,7 @@ import DAP +import Control.Concurrent.Async import System.IO import System.Exit (exitSuccess) import System.Environment @@ -55,33 +56,34 @@ port <- liftIO $ socketPort sock - _ <- liftIO $ forkIO $ ignoreIOException $ do + fwd_thr <- liftIO $ async $ 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) - -- -- Read stdout from chan and write to socket - _ <- forkIO $ ignoreIOException $ do - tid <- myThreadId - labelThread tid "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 - _ <- forkIO $ ignoreIOException $ do - tid <- myThreadId - labelThread tid "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 + race_ + (race_ + (-- Read stdout from chan and write to socket + ignoreIOException $ do + tid <- myThreadId + labelThread tid "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 + tid <- myThreadId + labelThread tid "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 @@ -90,8 +92,9 @@ else do debugMsg (T.pack $ "Read from socket: " ++ BS8.unpack bs) writeChan dbIn bs >> loop - in ignoreIOException loop + in ignoreIOException loop) + liftIO $ link fwd_thr sendRunProxyInTerminal port where @@ -120,22 +123,22 @@ catch ( runTCPClient "127.0.0.1" (show port) $ \sock -> do -- Forward stdin to sock - _ <- forkIO $ - catch (forever $ do + concurrently_ + (catch (forever $ do str <- BS8.hGetLine stdin NBS.sendAll sock (str <> BS8.pack "\n") - ) $ \(_e::IOException) -> return () -- connection dropped, just exit. + ) $ \(_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. + (-- 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?" @@ -150,12 +153,13 @@ , 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 = ["hdb", "proxy", "--port", T.pack (show port)] + , runInTerminalRequestArgumentsArgs = [T.pack thisProg, "proxy", "--port", T.pack (show port)] , runInTerminalRequestArgumentsEnv = Just (H.singleton "DEBUGGEE_INVOCATION" debuggee_inv) , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False } diff --git a/hdb/Development/Debug/Options.hs b/hdb/Development/Debug/Options.hs --- a/hdb/Development/Debug/Options.hs +++ b/hdb/Development/Debug/Options.hs @@ -8,13 +8,14 @@ -- | The options `hdb` is invoked in the command line with data HdbOptions - -- | @server [--internal-interpreter] --port @ + -- | @server [--internal-interpreter] [--disable-ipe-backtraces] --port @ = HdbDAPServer { port :: Int , verbosity :: Severity , internalInterpreter :: Bool + , disableIpeBacktraces :: Bool } - -- | @cli [--internal-interpreter] [--entry-point=] [--extra-ghc-args=""] [] -- []@ + -- | @cli [--internal-interpreter] [--disable-ipe-backtraces] [--entry-point=] [--extra-ghc-args=""] [] -- []@ | HdbCLI { entryPoint :: String , entryFile :: FilePath @@ -22,6 +23,7 @@ , extraGhcArgs :: [String] , verbosity :: Severity , internalInterpreter :: Bool + , disableIpeBacktraces :: Bool , debuggeeStdin :: Maybe FilePath } diff --git a/hdb/Development/Debug/Options/Parser.hs b/hdb/Development/Debug/Options/Parser.hs --- a/hdb/Development/Debug/Options/Parser.hs +++ b/hdb/Development/Debug/Options/Parser.hs @@ -29,6 +29,7 @@ <> help "DAP server port" ) <*> verbosityParser Debug <*> internalInterpreterParser + <*> disableIpeBacktracesParser -- | Parser for 'HdbCLI' options cliParser :: Parser HdbOptions @@ -55,6 +56,7 @@ <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" ) <*> verbosityParser Warning <*> internalInterpreterParser + <*> disableIpeBacktracesParser <*> (optional $ strOption ( long "debuggee-stdin" <> metavar "FILE" @@ -151,6 +153,22 @@ switch ( long "internal-interpreter" <> help "Prefer running the debuggee on the debugger's internal interpreter rather than on a separate (external-interpreter) process" + ) + +-- | Parser for --disable-ipe-backtraces +-- +-- Disable IPE backtrace information in the debugger. By default, IPE backtraces +-- are enabled to provide better crash diagnostics when debugging Haskell programs. +-- However, when using the internal interpreter, IPE backtraces appear in the +-- debugger output but not with the external interpreter (since they run as +-- separate processes). Use this flag only if you need consistent test output +-- between internal and external interpreter modes, or when testing behavior that +-- should not include IPE backtrace information. +disableIpeBacktracesParser :: Parser Bool +disableIpeBacktracesParser = + switch + ( long "disable-ipe-backtraces" + <> help "Disable IPE backtrace info for consistent output between internal/external interpreter modes" ) -- | Main parser info diff --git a/hdb/Development/Debug/Session/Setup.hs b/hdb/Development/Debug/Session/Setup.hs --- a/hdb/Development/Debug/Session/Setup.hs +++ b/hdb/Development/Debug/Session/Setup.hs @@ -11,6 +11,7 @@ -- * Logging , SessionSetupLog(..) + , renderSessionSetupLog ) where import Control.Applicative ((<|>)) @@ -43,12 +44,20 @@ 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 diff --git a/hdb/Main.hs b/hdb/Main.hs --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -55,7 +55,6 @@ main = do setBacktraceMechanismState CostCentreBacktrace False setBacktraceMechanismState HasCallStackBacktrace True - setBacktraceMechanismState IPEBacktrace False -- TODO: True, see #181 allArgs <- getArgs hdbOpts <- case allArgs of @@ -66,7 +65,8 @@ pure (HdbExternalInterpreter (read writeFd) (read readFd)) _ -> parseHdbOptions case hdbOpts of - HdbDAPServer{port, internalInterpreter} -> do + HdbDAPServer{port, internalInterpreter, disableIpeBacktraces} -> do + setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) config <- getConfig port redirectRealStdout internalInterpreter $ \realStdout -> do hSetBuffering realStdout LineBuffering @@ -78,6 +78,7 @@ (talk l init_var pid_var ccon_var internalInterpreter) (ack l pid_var) HdbCLI{..} -> do + setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) l <- mainLogger hdbOpts.verbosity stdout stdinStream <- case debuggeeStdin of Just fp -> UseHandle <$> System.IO.openFile fp ReadMode @@ -91,6 +92,7 @@ runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs runConf debugInteractive HdbProxy{port} -> do + setBacktraceMechanismState IPEBacktrace True l <- mainLogger hdbOpts.verbosity stdout runInTerminalHdbProxy (contramap RunProxyClientLog l) port HdbExternalInterpreter{writeFd, readFd} -> do @@ -213,7 +215,13 @@ talk l support_rit_var _pid_var client_proxy_signal 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 liftIO $ writeIORef support_rit_var runInTerminal sendInitializeResponse diff --git a/test/golden/T130/T130.hdb-stdin b/test/golden/T130/T130.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T130/T130.hdb-stdin @@ -0,0 +1,1 @@ +run diff --git a/test/golden/T130/T130.hdb-stdout b/test/golden/T130/T130.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T130/T130.hdb-stdout @@ -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) diff --git a/test/golden/T130/T130.hdb-test b/test/golden/T130/T130.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T130/T130.hdb-test @@ -0,0 +1,12 @@ +#!/bin/sh + +# the pkgdb is filled in by hie-bios +# this test should fail because we are using haskell-debugger-view == 0.1.0.0 +# 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 + exit 0 +fi + +echo "Expecting UnsupportedHsDbgViewVersion but didn't find that error in the debugger output:" diff --git a/test/golden/T130/app/Main.hs b/test/golden/T130/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T130/app/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Lib + +main :: IO () +main = print my + diff --git a/test/golden/T130/lib/Lib.hs b/test/golden/T130/lib/Lib.hs new file mode 100644 --- /dev/null +++ b/test/golden/T130/lib/Lib.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DerivingVia, StandaloneDeriving #-} +module Lib where + +import GHC.Debugger.View.Class + +data MyType = MyType deriving Show +deriving via (BoringTy MyType) instance (DebugView MyType) + +my :: MyType +my = MyType + diff --git a/test/golden/T130b/T130b.hdb-stdin b/test/golden/T130b/T130b.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T130b/T130b.hdb-stdin @@ -0,0 +1,1 @@ +run diff --git a/test/golden/T130b/T130b.hdb-stdout b/test/golden/T130b/T130b.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T130b/T130b.hdb-stdout @@ -0,0 +1,4 @@ +[1 of 2] Compiling Main ( /app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b] +(hdb) MyType +() +(hdb) Exiting... diff --git a/test/golden/T130b/T130b.hdb-test b/test/golden/T130b/T130b.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T130b/T130b.hdb-test @@ -0,0 +1,6 @@ +#!/bin/sh + +# the pkgdb is filled in by hie-bios +# this test should succeed because we are using a supported +# haskell-debugger-view (== 0.2.0.0), unlike for `T130` +$HDB -v0 app/Main.hs 2>&1 < T130b.hdb-stdin || true diff --git a/test/golden/T130b/app/Main.hs b/test/golden/T130b/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T130b/app/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Lib + +main :: IO () +main = print my + diff --git a/test/golden/T130b/lib/Lib.hs b/test/golden/T130b/lib/Lib.hs new file mode 100644 --- /dev/null +++ b/test/golden/T130b/lib/Lib.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DerivingVia, StandaloneDeriving #-} +module Lib where + +import GHC.Debugger.View.Class + +data MyType = MyType deriving Show +deriving via (BoringTy MyType) instance (DebugView MyType) + +my :: MyType +my = MyType + diff --git a/test/golden/T135/T135.hdb-stdin b/test/golden/T135/T135.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T135/T135.hdb-stdin @@ -0,0 +1,1 @@ +run diff --git a/test/golden/T135/T135.hdb-stdout b/test/golden/T135/T135.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T135/T135.hdb-stdout @@ -0,0 +1,13 @@ +[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 ( /myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp] +/myapp/app/Main.hs:3:1: warning: [GHC-66111] [-Wunused-imports] + The import of ‘MyLib’ is redundant + except perhaps to import instances from ‘MyLib’ + To import instances alone, use: import MyLib() + | +3 | import MyLib (someFunc) + | ^^^^^^^^^^^^^^^^^^^^^^^ + +(hdb) Hello, Haskell! +() +(hdb) Exiting... diff --git a/test/golden/T135/T135.hdb-test b/test/golden/T135/T135.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T135/T135.hdb-test @@ -0,0 +1,7 @@ +#!/bin/sh +# mkdir -p mystore +# STORE=$PWD/mystore +# hie-bios already handles setting up its own pkgdb I think +# (cd mylib && cabal -v0 --store-dir="$STORE" install --lib --package-env .) +# MYPKGDB=$(echo "$STORE"/ghc-*/package.db) +$HDB -v0 myapp/app/Main.hs < T135.hdb-stdin # the pkgdb is filled in by hie-bios (--extra-ghc-args -package-db="$MYPKGDB") diff --git a/test/golden/T135/myapp/app/Main.hs b/test/golden/T135/myapp/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T135/myapp/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import MyLib (someFunc) + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/test/golden/T135/mylib/src/MyLib.hs b/test/golden/T135/mylib/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/test/golden/T135/mylib/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/test/golden/T154/Main.hs b/test/golden/T154/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T154/Main.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "hello" diff --git a/test/golden/T154/T154.hdb-stdout b/test/golden/T154/T154.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T154/T154.hdb-stdout @@ -0,0 +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 ( /Main.hs, interpreted )[main] +(hdb) hello +() +(hdb) Exiting... diff --git a/test/golden/T154/T154.hdb-test b/test/golden/T154/T154.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T154/T154.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +echo "run" | $HDB -v0 Main.hs --extra-ghc-args -fexternal-interpreter 2>&1 diff --git a/test/golden/T159/T159.hdb-stdin b/test/golden/T159/T159.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T159/T159.hdb-stdin @@ -0,0 +1,3 @@ +break T159.hs 12 +run +backtrace diff --git a/test/golden/T159/T159.hdb-stdout b/test/golden/T159/T159.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T159/T159.hdb-stdout @@ -0,0 +1,6 @@ +[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 ( /T159.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}} +(hdb) Stopped at breakpoint +(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "/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 /T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}] +(hdb) Exiting... diff --git a/test/golden/T159/T159.hdb-test b/test/golden/T159/T159.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T159/T159.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB -v0 T159.hs < T159.hdb-stdin diff --git a/test/golden/T159/T159.hs b/test/golden/T159/T159.hs new file mode 100644 --- /dev/null +++ b/test/golden/T159/T159.hs @@ -0,0 +1,12 @@ +import GHC.Stack.Annotation.Experimental + +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) diff --git a/test/golden/T164/Main.hs b/test/golden/T164/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T164/Main.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GADTs, ImplicitParams #-} +{-# LANGUAGE BangPatterns #-} + +module Main where + +import Data.Word + +data Foo where + Foo :: Show a => a -> Foo + +data Foo2 where + Foo2 :: Show a => { foo :: a }-> Foo2 + +data Foo3 where + Foo3 :: Int -> {-# UNPACK #-} !Word -> !Int -> !Int -> Foo3 + +data Foo4 = Foo4 !Word32 !Word16 !Word64 !Word16 + +instance Show Foo where + show (Foo a) = show a + +data Foo5 where + Foo5 :: (?impl :: String) => String -> Foo5 + +mkFoo :: Foo +mkFoo = Foo $! ("value" :: String) + +mkFoo2 :: Foo2 +mkFoo2 = Foo2 $! ("value2" :: String) + +mkFoo5 :: Foo5 +mkFoo5 = let ?impl = "bob" in Foo5 "alice" + + +inspectFoo :: IO () +inspectFoo = do + let !existentialFoo = mkFoo + let !existentialFoo2 = mkFoo2 + let !foo3 = Foo3 0 1 2 3 + let !foo4 = Foo4 0 1 2 3 + let !foo5 = mkFoo5 + const (pure ()) (existentialFoo, existentialFoo2, foo3, foo4, foo5) + case existentialFoo of + Foo inner -> putStrLn (show inner) + +main :: IO () +main = inspectFoo diff --git a/test/golden/T164/T164.hdb-stdin b/test/golden/T164/T164.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T164/T164.hdb-stdin @@ -0,0 +1,4 @@ +break Main.hs 42 +run +variables +exit diff --git a/test/golden/T164/T164.hdb-stdout b/test/golden/T164/T164.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T164/T164.hdb-stdout @@ -0,0 +1,27 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}} +(hdb) Stopped at breakpoint +(hdb) _result : IO () = _ +*** Ignoring breakpoint [/Main.hs:42:3-69] + _result : 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) diff --git a/test/golden/T164/T164.hdb-test b/test/golden/T164/T164.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T164/T164.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T164.hdb-stdin diff --git a/test/golden/T169/Main.hs b/test/golden/T169/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T169/Main.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "hello" diff --git a/test/golden/T169/T169.hdb-stdout b/test/golden/T169/T169.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169.hdb-stdout @@ -0,0 +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 ( /Main.hs, interpreted )[main] +(hdb) hello +() +(hdb) Exiting... diff --git a/test/golden/T169/T169.hdb-test b/test/golden/T169/T169.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +echo "run" | $HDB -v0 Main.hs --extra-ghc-args -fno-external-interpreter 2>&1 diff --git a/test/golden/T169/T169b.hdb-stdin b/test/golden/T169/T169b.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169b.hdb-stdin @@ -0,0 +1,5 @@ +break --name main +run +next +next +next diff --git a/test/golden/T169/T169b.hdb-stdout b/test/golden/T169/T169b.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169b.hdb-stdout @@ -0,0 +1,10 @@ +[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 ( /T169b.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}} +(hdb) Stopped at breakpoint +(hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/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 = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}] +(hdb) Debuggee writing something to stderr +() +(hdb) Exiting... diff --git a/test/golden/T169/T169b.hdb-test b/test/golden/T169/T169b.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169b.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB -v0 T169b.hs < T169b.hdb-stdin 2>&1 diff --git a/test/golden/T169/T169b.hs b/test/golden/T169/T169b.hs new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169b.hs @@ -0,0 +1,8 @@ +module Main where + +import System.IO + +main :: IO () +main = do + hPutStrLn stdout "Debuggee writing something to stdout" + hPutStrLn stderr "Debuggee writing something to stderr" diff --git a/test/golden/T169/T169c.debuggee-stdin b/test/golden/T169/T169c.debuggee-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.debuggee-stdin @@ -0,0 +1,2 @@ +hello there + diff --git a/test/golden/T169/T169c.external.hdb-stdout b/test/golden/T169/T169c.external.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.external.hdb-stdout @@ -0,0 +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 ( /T169c.hs, interpreted )[main] +(hdb) "hello there" +() +(hdb) Exiting... diff --git a/test/golden/T169/T169c.external.hdb-test b/test/golden/T169/T169c.external.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.external.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB -v0 T169c.hs --debuggee-stdin T169c.debuggee-stdin < T169c.hdb-stdin 2>&1 diff --git a/test/golden/T169/T169c.hdb-stdin b/test/golden/T169/T169c.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.hdb-stdin @@ -0,0 +1,1 @@ +run diff --git a/test/golden/T169/T169c.hs b/test/golden/T169/T169c.hs new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.hs @@ -0,0 +1,6 @@ +module Main where + +main :: IO () +main = do + line <- getLine + print line diff --git a/test/golden/T169/T169c.internal.hdb-stdin b/test/golden/T169/T169c.internal.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.internal.hdb-stdin @@ -0,0 +1,2 @@ +run +hello world diff --git a/test/golden/T169/T169c.internal.hdb-stdout b/test/golden/T169/T169c.internal.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.internal.hdb-stdout @@ -0,0 +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 ( /T169c.hs, interpreted )[main] +(hdb) "hello world" +() +(hdb) Exiting... diff --git a/test/golden/T169/T169c.internal.hdb-test b/test/golden/T169/T169c.internal.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.internal.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB -v0 T169c.hs < T169c.internal.hdb-stdin 2>&1 diff --git a/test/golden/T61/T61.hdb-stdin b/test/golden/T61/T61.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T61/T61.hdb-stdin @@ -0,0 +1,1 @@ +run diff --git a/test/golden/T61/T61.hdb-stdout b/test/golden/T61/T61.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T61/T61.hdb-stdout @@ -0,0 +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 ( /x/Main.hs, interpreted )[main] +(hdb) wrks +() +(hdb) Exiting... diff --git a/test/golden/T61/T61.hdb-test b/test/golden/T61/T61.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T61/T61.hdb-test @@ -0,0 +1,1 @@ +$HDB x/Main.hs < T61.hdb-stdin diff --git a/test/golden/T61/x/Main.hs b/test/golden/T61/x/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T61/x/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "wrks" diff --git a/test/golden/T79/T79.hdb-stdout b/test/golden/T79/T79.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T79/T79.hdb-stdout @@ -0,0 +1,14 @@ +[Info] Using cabal specification: +[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. + +[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 ( /app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp] +(hdb) Hello, Haskell! +() +(hdb) diff --git a/test/golden/T79/T79.hdb-test b/test/golden/T79/T79.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T79/T79.hdb-test @@ -0,0 +1,4 @@ +cabal init -m -n -d base -p T79-tmp && $HDB app/Main.hs <<'EOF' +run +exit +EOF diff --git a/test/golden/T83/Main.hs b/test/golden/T83/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T83/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Heli" diff --git a/test/golden/T83/T83.hdb-stdin b/test/golden/T83/T83.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T83/T83.hdb-stdin @@ -0,0 +1,1 @@ +run diff --git a/test/golden/T83/T83.hdb-stdout b/test/golden/T83/T83.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T83/T83.hdb-stdout @@ -0,0 +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 ( /Main.hs, interpreted )[main] +(hdb) Heli +() +(hdb) Exiting... diff --git a/test/golden/T83/T83.hdb-test b/test/golden/T83/T83.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T83/T83.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T83.hdb-stdin diff --git a/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdin b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdin @@ -0,0 +1,4 @@ +break --exceptions +run +continue +exit diff --git a/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout @@ -0,0 +1,23 @@ +[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 ( /prog/Main.hs, interpreted )[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 /prog/Main.hs:8:10 in main:Main + +Exception location: /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 /prog/Main.hs:10:3 in main:Main + +Exception location: /prog/Main.hs:10:3 +(hdb) diff --git a/test/golden/exceptions-multiple/exceptions-multiple.hdb-test b/test/golden/exceptions-multiple/exceptions-multiple.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-multiple/exceptions-multiple.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB prog/Main.hs < exceptions-multiple.hdb-stdin diff --git a/test/golden/exceptions-multiple/prog/Main.hs b/test/golden/exceptions-multiple/prog/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-multiple/prog/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Control.Exception + +main :: IO () +main = do + putStrLn "About to throw first" + catch (error "boom first") handler + putStrLn "Continuing after first exception" + error "boom second" + +handler :: SomeException -> IO () +handler se = putStrLn ("Handled first exception: " ++ displayException se) diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdin b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdin @@ -0,0 +1,3 @@ +break --error +run +exit diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout @@ -0,0 +1,22 @@ +[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 ( /prog/Main.hs, interpreted )[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 boom outer + + HasCallStack backtrace: + error, called at /prog/Main.hs:14:3 in main:Main +Inner exceptions: + Exception: ErrorCall + Message: boom outer + Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:8:10 in main:Main + +Exception location: /prog/Main.hs:14:3 +(hdb) diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-test b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB prog/Main.hs < exceptions-uncaught.hdb-stdin diff --git a/test/golden/exceptions-uncaught/prog/Main.hs b/test/golden/exceptions-uncaught/prog/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-uncaught/prog/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Control.Exception + +main :: IO () +main = do + putStrLn "About to throw" + catch (error "boom outer") handler + putStrLn "Should not reach here" + +handler :: SomeException -> IO () +handler se = do + putStrLn ("Handling exception: " ++ displayException se) + error "boom while handling" diff --git a/test/golden/exceptions/exceptions.hdb-stdin b/test/golden/exceptions/exceptions.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/exceptions/exceptions.hdb-stdin @@ -0,0 +1,3 @@ +break --exceptions +run +exit diff --git a/test/golden/exceptions/exceptions.hdb-stdout b/test/golden/exceptions/exceptions.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions/exceptions.hdb-stdout @@ -0,0 +1,13 @@ +[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 ( /prog/Main.hs, interpreted )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw +Stopped at breakpoint +Exception: ErrorCall +Message: boom +Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:6:3 in main:Main + +Exception location: /prog/Main.hs:6:3 +(hdb) diff --git a/test/golden/exceptions/exceptions.hdb-test b/test/golden/exceptions/exceptions.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/exceptions/exceptions.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB prog/Main.hs < exceptions.hdb-stdin diff --git a/test/golden/exceptions/prog/Main.hs b/test/golden/exceptions/prog/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/exceptions/prog/Main.hs @@ -0,0 +1,6 @@ +module Main where + +main :: IO () +main = do + putStrLn "About to throw" + error "boom" diff --git a/test/haskell/Main.hs b/test/haskell/Main.hs --- a/test/haskell/Main.hs +++ b/test/haskell/Main.hs @@ -44,8 +44,14 @@ let testsForInternal = Set.toList $ internalOnlySet `Set.union` defaultTestsSet let testsForExternal = Set.toList $ externalOnlySet `Set.union` defaultTestsSet - default_goldens <- mapM (mkTest "") testsForExternal - intinterp_goldens <- mapM (mkTest "--internal-interpreter") testsForInternal + -- Disable IPE backtraces in tests to ensure consistent output between + -- internal and external interpreter modes. When using the internal interpreter, + -- IPE backtraces appear in debugger output but not with the external interpreter + -- (since they run as separate processes). To use a single golden test file for + -- both modes, we disable IPE backtraces by default in tests. + let baseFlags = "--disable-ipe-backtraces" + default_goldens <- mapM (mkTest baseFlags) testsForExternal + intinterp_goldens <- mapM (mkTest ("--internal-interpreter " ++ baseFlags)) testsForInternal defaultMain $ testGroup "Tests" diff --git a/test/haskell/Test/DAP/RunInTerminal.hs b/test/haskell/Test/DAP/RunInTerminal.hs --- a/test/haskell/Test/DAP/RunInTerminal.hs +++ b/test/haskell/Test/DAP/RunInTerminal.hs @@ -6,6 +6,9 @@ {-# LANGUAGE CPP #-} module Test.DAP.RunInTerminal (runInTerminalTests) where +import System.Exit +import Control.Exception +import Control.Monad import Control.Concurrent import DAP.Types import DAP.Utils @@ -30,7 +33,7 @@ testGroup "DAP.RunInTerminal" [ #ifdef mingw32_HOST_OS - ignoreTestBecause "Needs to be fixed for Windows" $ + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ #endif testGroup "runInTerminal: proxy forwards stdin correctly" [ testCase "(default)" (runInTerminal1 "") @@ -52,10 +55,12 @@ <- P.createProcess (P.shell $ "hdb server " ++ flags ++ " --port " ++ show testPort) {P.cwd = Just test_dir, P.std_out = P.CreatePipe, P.std_in = P.CreatePipe} + serverOutputRef <- newIORef [] + -- Fork thread to print out output of server process -- This is surprisingly needed, otherwise the server process -- will be broken, perhaps because it blocks trying to write to stdout/stderr if the buffer is full? - forkIO $ do + forkIO $ flip catch (\(e :: IOException) -> print ("server process forwarding", e)) $ do hSetBuffering hout LineBuffering let loop = do eof <- hIsEOF hout @@ -63,14 +68,18 @@ then return () else do _l <- hGetLine hout - -- UNCOMMENT ME TO DEBUG - -- putStrLn ("[server] " ++ _l) + modifyIORef' serverOutputRef (_l :) loop loop + let flushServerOutput = do + putStrLn "\n--- SERVER OUTPUT ---" + readIORef serverOutputRef >>= mapM_ putStrLn . reverse + putStrLn "---------------------\n" + retryVar <- newIORef True -- Connect to the DAP server - withNewClient testPort retryVar $ \handle -> do + flip onException flushServerOutput $ withNewClient testPort retryVar $ \handle -> do -- As soon as we get a connection, stop retrying writeIORef retryVar False @@ -112,12 +121,10 @@ ] ] - _ <- shouldReceive handle - ["type" .= ("event" :: String), "event" .= ("output" :: String)] - _ <- shouldReceive handle - ["type" .= ("event" :: String), "event" .= ("output" :: String)] - _ <- shouldReceive handle - ["type" .= ("event" :: String), "event" .= ("output" :: String)] + -- Receive output events + forM_ [1..9] $ \_ -> + shouldReceive handle + ["type" .= ("event" :: String), "event" .= ("output" :: String)] _ <- shouldReceive handle [ "command" .= ("launch" :: String) , "success" .= True] @@ -214,9 +221,9 @@ -- The contents of the rit_output should contain "hello" plus printing of what we wrote out <- LBS.hGetContents rit_out let out_str = LB8.unpack out - assertBool ("Expected output to contain 'hello', got: " ++ out_str) + assertBool ("Expected output to contain 'hello', got: " ++ show out_str) ("hello" `isInfixOf` out_str) - assertBool ("Expected output to contain '" ++ secret_in ++ "' , got: " ++ out_str) + assertBool ("Expected output to contain '" ++ secret_in ++ "' , got: " ++ show out_str) (secret_in `isInfixOf` out_str) -- Send disconnect