diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,4 +1,10 @@ +20181014 phoityne-vscode-0.0.27.0 + * [UPDATE] supported haskell-dap-0.0.9.0 + * [MODIFY] send dap output to vscode with DEBUG level. + * [FIX][[1](https://github.com/phoityne/hdx4vsc/issues/1)]debugger does not work with vscode-1.28.(Fixed with haskell-dap only.) + + 20180801 phoityne-vscode-0.0.26.0 * [UPDATE] supported haskell-dap-0.0.7.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,163 +1,81 @@ -# Phoityne VSCode +# Requirements -Phoityne is a Haskell GHCi debug adapter for Visual Studio Code. +Install [phoityne-vscode](https://hackage.haskell.org/package/phoityne-vscode) from hackage. +## Especially for GHC8 -## Information -* [2018/08/01] phoityne-vscode released. - * Marketplace [phoityne-vscode-0.0.19](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) - * hackage [phoityne-vscode-0.0.26.0](https://hackage.haskell.org/package/phoityne-vscode) - __Need update from hackage !!.__ -* Release Summary - * [UPDATE] supported haskell-dap-0.0.7.0 + Install [phoityne-vscode](https://hackage.haskell.org/package/phoityne-vscode) and [haskell-dap](https://hackage.haskell.org/package/haskell-dap). + In the launch.json, add "--with-ghc=haskell-dap" to ghciCmd variable. -![10_quick_start.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/10_quick_start.gif) -(This sample project is available from [here](https://github.com/phoityne/stack-project-template).) +``` +> stack install phoityne-vscode haskell-dap +``` -## Important +# Limitations -* __LIMITATION__: Source file extension must be ".hs" -* __LIMITATION__: Can not use STDIN handle while debugging. -* When you start debugging for the first time, .vscode/tasks.json will be created automatically. Then you can use F6, F7, F8 shortcut key. - * F5 : start debug - * F6 : show command menu (for stack watch) - * Shift + F6 : stop stack watch - * F7 : stack clean & build - * F8 : stack test - * F9 : put bp on current line - * Shift + F9 : put bp on current column -* While debugging, you can use F5, F9, F10, F11 shortcut key. - * F5 : jump to next bp - * F9 : put bp on the line - * Shift + F9 : put bp on the column - * F10 : step next - * F11 : step into +* The source file extension must be ".hs" +* Can not use STDIN handle while debugging. +* Using GHC7, see the [README](https://github.com/phoityne/hdx4vsc/blob/master/README_ghc7.md). -## Features +# Features -### Run to Cursor +## Continue & Steps -![03_run_to_cursor.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/03_run_to_cursor.gif) +![01_F5_F10_F11.gif](https://raw.githubusercontent.com/phoityne/hdx4vsc/master/docs/01_F5_F10_F11.gif) -### Bindings & Watch +## Stacktrace The variable added to watch will be forced. -![02_watch.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/02_watch.gif) - - -### Stack trace - -![05_stacktrace.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/05_stacktrace.gif) - - -### Break condition - -![04_condition.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/04_condition.gif) - -### Hit count break condition - -Supports these operators. -* == -* /= -* <, > -* <=, >= -* mod, % -* just digit is same with '>=' - -![07_hit_count.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/07_hit_count.gif) - -### Break on Exception - -![08_exception.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/08_exception.gif) +![03_stacktrace.gif](https://raw.githubusercontent.com/phoityne/hdx4vsc/master/docs/03_stacktrace.gif) -### Repl & Completions - -![06_repl.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/06_repl.gif) - -### and more - -Better inspection. This is an experimental enhancement. -There are limitations and additional installation. -[Here are the details](https://github.com/phoityne/haskell-dap). - -![01_inspect_variables.gif](https://raw.githubusercontent.com/phoityne/haskell-dap/master/docs/01_inspect_variables.gif) - -## Capabilites - -* supportsConfigurationDoneRequest : **yes** -* supportsFunctionBreakpoints : **yes** -* supportsConditionalBreakpoints : **yes** -* supportsHitConditionalBreakpoints : **yes** -* supportsEvaluateForHovers : **yes** -* exceptionBreakpointFilters : **yes** -* supportsStepBack : no -* supportsSetVariable : no -* supportsRestartFrame : no -* supportsGotoTargetsRequest : no -* supportsStepInTargetsRequest : no -* supportsCompletionsRequest : **yes** -* supportsModulesRequest : no -* additionalModuleColumns : no -* supportedChecksumAlgorithms : no -* supportsRestartRequest : no -* supportsExceptionOptions : no -* supportsValueFormattingOptions : no -* supportsExceptionInfoRequest : no -* supportTerminateDebuggee : no -* supportsDelayedStackTraceLoading : no -* supportsLogPoints : **yes** (by haskell-dap) - +## Bindings -## Install +![04_variables.gif](https://raw.githubusercontent.com/phoityne/hdx4vsc/master/docs/04_variables.gif) -### Run stack install - - % stack install phoityne-vscode - . . . . . - % +## Break condition -Add 'phoityne-vscode.exe' to PATH environment. +![05_break_cond.gif](https://raw.githubusercontent.com/phoityne/hdx4vsc/master/docs/05_break_cond.gif) -Windows) +## Console output - % where $path:phoityne-vscode.exe - C:\Users\[user name]\AppData\Roaming\local\bin\phoityne-vscode.exe - - % phoityne-vscode --version - phoityne-vscode-x.x.x.x - % - % code +![02_console_out.gif](https://raw.githubusercontent.com/phoityne/hdx4vsc/master/docs/02_console_out.gif) -linux) +## Quick Start +This is a new experimental feature. +__Note!!__, This function will automatically change the .vscode / launch.json file. +![06_quick_start.gif](https://raw.githubusercontent.com/phoityne/hdx4vsc/master/docs/06_quick_start.gif) - $ which phoityne-vscode - ~/.local/bin/phoityne-vscode - $ - $ phoityne-vscode --version - phoityne-vscode-x.x.x.x - $ - $ code +# Shortcut keys -### Install vscode extensions +When you start debugging for the first time, .vscode/tasks.json will be created automatically. Then you can use F6, F7, F8 shortcut keys. + * F5 : start debug + * F6 : show command menu (for stack watch) + * Shift + F6 : stop stack watch + * F7 : stack clean & build + * F8 : stack test + * F9 : put a breakpoint on the current line + * Shift + F9 : put a breakpoint on the current column -1. run VSCode and open stack project __Folder__ from file menu. -2. open Extensions from side menu of VSCode. -3. search "haskell" -4. select "[__Haskell GHCi debug adapter Phoityne__](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode)" +While debugging, you can use F5, F9, F10, F11 shortcut keys. + * F5 : jump to next bp + * F9 : put bp on the line + * Shift + F9 : put bp on the column + * F10 : step next + * F11 : step into - + -## Configuration +# Configuration -### __.vscode/launch.json__ +## __.vscode/launch.json__ |NAME|REQUIRED OR OPTIONAL|DEFAULT SETTING|DESCRIPTION| |:--|:--:|:--|:--| @@ -173,7 +91,7 @@ |logLevel|required|WARNING|internal log level.| -#### changing ghci initial prompt +### changing ghci initial prompt If you change ghci prompt in .ghci file, or ghci prompt is changed from "Prelude>" by applying _NoImplicitPrelude_ extension, set the initial prompt variable to same prompt string. @@ -187,7 +105,7 @@ Make sure needs of the last space, and don't forget adding it. -#### setting the startup hs file +### setting the startup hs file Set the startup variable to the path of .hs file in which main function is defined. @@ -199,7 +117,7 @@ % -#### setting the startup function +### setting the startup function If you want to run the specific function instead of main function, set the startupFunc variable. For example, when specifying the following startDebug function, @@ -221,7 +139,7 @@ % -#### changing log level +### changing log level For debuging phoityen itself, change the log level to DEBUG. Adding Issue with the debug log. @@ -234,7 +152,7 @@ % -### __.vscode/tasks.json__ +## __.vscode/tasks.json__ |TASK NAME|REQUIRED OR OPTIONAL|DEFAULT SETTING|DESCRIPTION| |:--|:--:|:--|:--| diff --git a/app/Phoityne/GHCi/Command.hs b/app/Phoityne/GHCi/Command.hs --- a/app/Phoityne/GHCi/Command.hs +++ b/app/Phoityne/GHCi/Command.hs @@ -10,6 +10,7 @@ SourcePosition(..) , StackFrame(..) , BindingData(..) + , _DAP_CMD_END , start , quit , set @@ -127,7 +128,8 @@ -> M.Map String String -> IO (Either ErrorData GHCiProcess) start outHdl cmd opts cwd initPmt pmt envs = do - outHdl $ L.intercalate " " $ (cmd : opts) ++ ["in " ++ cwd, "\n"] + outHdl $ L.intercalate " " ["CWD:", cwd, "\n"] + outHdl $ L.intercalate " " $ ("CMD:" : cmd : opts) ++ ["\n\n"] runProcess cmd opts cwd pmt envs >>= withProcess where withProcess (Left err) = return $ Left err @@ -728,7 +730,7 @@ return res where proc curStr _ = do - outHdl curStr + outHdl (curStr ++ "\n") return $ curStr /= _DAP_CMD_END witResult (Left err ) = return $ Left err diff --git a/app/Phoityne/VSCode/Core.hs b/app/Phoityne/VSCode/Core.hs --- a/app/Phoityne/VSCode/Core.hs +++ b/app/Phoityne/VSCode/Core.hs @@ -478,6 +478,7 @@ _DAP_HEADER_OUTPUT_EVENT :: String _DAP_HEADER_OUTPUT_EVENT = "<>" + -- | -- type DAPRequestHandler = MVar DebugContextData @@ -578,6 +579,33 @@ outEvtStr = J.encode outEvt{J.bodyOutputEvent = body} sendEvent mvarCtx outEvtStr + +-- | +-- +commonDapOutHdl :: MVar DebugContextData -> String -> String -> String -> IO () +commonDapOutHdl mvarCtx cmd args str = getLevel <$> getLogger _LOG_NAME >>= \case + Just DEBUG -> do + if | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> + outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str + + | U.startswith cmd str -> sendStdoutEvent mvarCtx $ cmd ++ " " ++ args ++ "\n" + + | otherwise -> sendStdoutEvent mvarCtx str + + Just INFO -> do + if | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> + outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str + + | U.startswith cmd str -> sendStdoutEvent mvarCtx $ cmd ++ " ...\n" + + | U.startswith G._DAP_CMD_END str -> return () + + | otherwise -> sendStdoutEvent mvarCtx str + + _ -> do + if | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> + outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str + | otherwise -> return () -- | -- @@ -599,27 +627,29 @@ where + cmdStr = ":dap-set-breakpoints" + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-set-breakpoints" - args = showDAP $ J.argumentsSetBreakpointsRequest req + let args = showDAP $ J.argumentsSetBreakpointsRequest req - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr args) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.SetBreakpointsRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + -- | -- dapHdl :: MVar DebugContextData -> J.SetBreakpointsRequest -> String -> IO () @@ -647,6 +677,7 @@ resStr = J.encode res sendResponse mvarCtx resStr + -- | -- setFunctionBreakpointsRequestHandlerDAP :: DAPRequestHandler @@ -667,27 +698,29 @@ where + cmdStr = ":dap-set-function-breakpoints" + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-set-function-breakpoints" - args = showDAP $ J.argumentsSetFunctionBreakpointsRequest req + let args = showDAP $ J.argumentsSetFunctionBreakpointsRequest req - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr args) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + -- | -- dapHdl :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> String -> IO () @@ -761,41 +794,51 @@ -- | -- - stopOnEntry _ True = do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultConfigurationDoneResponse resSeq req - resStr = J.encode res - sendResponse mvarCtx resStr + cmdStr = ":dap-continue" + + -- | + -- + stopOnEntry proc True = do + startupFile <- startupDebugContextData <$> readMVar mvarCtx + startupFunc <- startupFuncDebugContextData <$> readMVar mvarCtx - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEvent mvarCtx stopEvtStr + let funcName = if null startupFunc then "main" else startupFunc + funcBp = (startupFile, J.FunctionBreakpoint funcName Nothing Nothing) - return $ Right [] + adhocSetFuncBreakpoint proc funcBp >>= \case + Left err -> do + errorM _LOG_NAME $ "set entry breakpoint failed. " ++ err ++ " : " ++ funcName ++ " : " ++ show funcBp + sendErrRes mvarCtx req err + stopOnEntry proc False + Right bp -> do + stopOnEntry proc False + adhocDelBreakpoint proc bp -- | -- stopOnEntry proc False = do cmdArgs <- getContinueCmdArgs mvarCtx - let cmd = ":dap-continue" - args = showDAP $ J.ContinueArguments _THREAD_ID cmdArgs + let args = showDAP $ J.ContinueArguments _THREAD_ID cmdArgs - G.dapCommand proc (outHdl mvarCtx req) cmd args + G.dapCommand proc (outHdl mvarCtx req) cmdStr args + return $ Right () + -- | -- outHdl :: MVar DebugContextData -> J.ConfigurationDoneRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + + -- | -- dapHdl :: MVar DebugContextData -> J.ConfigurationDoneRequest -> String -> IO () @@ -839,6 +882,60 @@ sendResponse mvarCtx resStr + -- | + -- + adhocSetFuncBreakpoint :: G.GHCiProcess + -> (FilePath, J.FunctionBreakpoint) + -> IO (Either G.ErrorData J.Breakpoint) + adhocSetFuncBreakpoint proc args = do + let cmdStr = ":dap-set-function-breakpoint" + G.dapCommand proc (adhocOutHdl mvarCtx (show args) cmdStr) cmdStr (showDAP args) >>= \case + Left err -> return $ Left err + Right strs -> withAdhocAddDapHeader $ filter (U.startswith _DAP_HEADER) strs + + + -- | + -- + withAdhocAddDapHeader :: [String] -> IO (Either G.ErrorData J.Breakpoint) + withAdhocAddDapHeader [] = return $ Left "[ERROR] can not set func breakpoint. no dap header found." + withAdhocAddDapHeader (str:[]) = case R.readEither (drop (length _DAP_HEADER) str) of + Left err -> return $ Left $ "[ERROR] read response body failed. " ++ err ++ " : " ++ str + Right (Left err) -> return $ Left $ "[ERROR] set adhoc breakpoint failed. " ++ err ++ " : " ++ str + Right (Right res) -> return $ Right res + withAdhocAddDapHeader _ = return $ Left "[ERROR] can not set func breakpoint. ambiguous dap header found." + + + -- | + -- + adhocDelBreakpoint :: G.GHCiProcess -> J.Breakpoint -> IO (Either G.ErrorData ()) + adhocDelBreakpoint proc args = do + let cmdStr = ":dap-delete-breakpoint" + G.dapCommand proc (adhocOutHdl mvarCtx (show args) cmdStr) cmdStr (showDAP args) >>= \case + Left err -> return $ Left err + Right strs -> withAdhocDelDapHeader $ filter (U.startswith _DAP_HEADER) strs + + -- | + -- + withAdhocDelDapHeader :: [String] -> IO (Either G.ErrorData ()) + withAdhocDelDapHeader [] = return $ Left "[ERROR] can not del func breakpoint. no dap header found." + withAdhocDelDapHeader (str:[]) = case R.readEither (drop (length _DAP_HEADER) str) of + Left err -> return $ Left $ "[ERROR] read response body failed. " ++ err ++ " : " ++ str + Right (Left err) -> return $ Left $ "[ERROR] del adhoc breakpoint failed. " ++ err ++ " : " ++ str + Right (Right res) -> return $ Right res + withAdhocDelDapHeader _ = return $ Left "[ERROR] can not del func breakpoint. ambiguous dap header found." + + -- | + -- + adhocOutHdl :: MVar DebugContextData -> String -> String -> String -> IO () + adhocOutHdl mvarCtx reqStr cmdStr str = do + + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str + + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str + | otherwise -> commonDapOutHdl mvarCtx cmdStr reqStr str + -- | -- continueRequestHandlerDAP :: DAPRequestHandler @@ -859,6 +956,8 @@ where + cmdStr = ":dap-continue" + -- | -- go = getProcExcept mvarCtx >>= runDap @@ -867,25 +966,27 @@ -- runDap proc = do cmdArgs <- liftIO $ getContinueCmdArgs mvarCtx - let cmd = ":dap-continue" - reqArgs= J.argumentsContinueRequest req + let reqArgs= J.argumentsContinueRequest req args = showDAP $ reqArgs { J.exprContinueArguments = cmdArgs } - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr args) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.ContinueRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + + + -- | -- dapHdl :: MVar DebugContextData -> J.ContinueRequest -> String -> IO () @@ -966,27 +1067,29 @@ where + cmdStr = ":dap-next" + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-next" - args = showDAP $ J.argumentsNextRequest req + let args = showDAP $ J.argumentsNextRequest req - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr args) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.NextRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + -- | -- dapHdl :: MVar DebugContextData -> J.NextRequest -> String -> IO () @@ -1047,27 +1150,29 @@ where + cmdStr = ":dap-step-in" + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-step-in" - args = showDAP $ J.argumentsStepInRequest req + let args = showDAP $ J.argumentsStepInRequest req - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr args) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.StepInRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + -- | -- dapHdl :: MVar DebugContextData -> J.StepInRequest -> String -> IO () @@ -1127,27 +1232,29 @@ where + cmdStr = ":dap-stacktrace" + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-stacktrace" - args = showDAP $ J.argumentsStackTraceRequest req + let args = showDAP $ J.argumentsStackTraceRequest req - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr args) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.StackTraceRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + -- | -- dapHdl :: MVar DebugContextData -> J.StackTraceRequest -> String -> IO () @@ -1156,10 +1263,18 @@ errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str sendErrRes mvarCtx req err - Right (Left err) -> do - errorM _LOG_NAME $ "stackTraceRequestHandler failed. " ++ err ++ " : " ++ str - sendErrRes mvarCtx req err + Right (Left err) -> debugStartedDebugContextData <$> readMVar mvarCtx >>= \case + False -> do + errorM _LOG_NAME $ "stackTraceRequestHandler failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + True -> do + errorM _LOG_NAME $ "stackTraceRequestHandler failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + sendConsoleEvent mvarCtx $ " No stack trace is found. It seems that GHCi has ended debugging.\n" + sendConsoleEvent mvarCtx $ " Exitting haskell debugger.\n" + sendTerminateEvent mvarCtx + Right (Right body) -> do resSeq <- getIncreasedResponseSequence mvarCtx let res = J.defaultStackTraceResponse resSeq req @@ -1195,28 +1310,30 @@ where + cmdStr = ":dap-scopes" + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-scopes" - args = showDAP $ J.argumentsScopesRequest req + let args = showDAP $ J.argumentsScopesRequest req - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr args) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.ScopesRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + -- | -- dapHdl :: MVar DebugContextData -> J.ScopesRequest -> String -> IO () @@ -1264,27 +1381,29 @@ where + cmdStr = ":dap-variables" + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-variables" - args = showDAP $ J.argumentsVariablesRequest req + let args = showDAP $ J.argumentsVariablesRequest req - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr args) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.VariablesRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str + -- | -- dapHdl :: MVar DebugContextData -> J.VariablesRequest -> String -> IO () @@ -1332,29 +1451,30 @@ Left err -> sendErrRes mvarCtx req err where - + cmdStr = ":dap-evaluate" + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-evaluate" - args = J.argumentsEvaluateRequest req + let args = J.argumentsEvaluateRequest req dapArgs = showDAP args - liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd dapArgs) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmdStr dapArgs) >>= exceptIO -- | -- outHdl :: MVar DebugContextData -> J.EvaluateRequest -> String -> IO () outHdl mvarCtx req str = do - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str - if | U.startswith _DAP_HEADER str -> + if | U.startswith _DAP_HEADER str -> do + logLevelMay <- getLevel <$> getLogger _LOG_NAME + when ((Just DEBUG) == logLevelMay) $ sendStdoutEvent mvarCtx str dapHdl mvarCtx req $ drop (length _DAP_HEADER) str - | U.startswith _DAP_HEADER_OUTPUT_EVENT str -> - outputEventHandler mvarCtx $ drop (length _DAP_HEADER_OUTPUT_EVENT) str - | otherwise -> return () + + | otherwise -> commonDapOutHdl mvarCtx cmdStr (show req) str -- | -- diff --git a/phoityne-vscode.cabal b/phoityne-vscode.cabal --- a/phoityne-vscode.cabal +++ b/phoityne-vscode.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: b19b0fcf2dcc588b7530ff1f713fa07c43cf33b004dcb6825997aa462b0658fb +-- hash: 2e3d81bba7298c6b250fac3885e94bd14ecd597e7e17391774f5411f2375b1fc name: phoityne-vscode -version: 0.0.26.0 +version: 0.0.27.0 synopsis: Haskell Debug Adapter for Visual Studio Code. description: Please see README.md category: Development