diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,4 +1,8 @@ +20180601 phoityne-vscode-0.0.24.0 + * [UPDATE] supported haskell-dap-0.0.5.0 + + 20180430 phoityne-vscode-0.0.23.0 * [UPDATE] supported haskell-dap-0.0.4.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,12 +6,12 @@ ## Information -* [2018/02/11] phoityne-vscode released. +* [2018/06/01] phoityne-vscode released. * Marketplace [phoityne-vscode-0.0.19](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) - * hackage [phoityne-vscode-0.0.22.0](https://hackage.haskell.org/package/phoityne-vscode) + * hackage [phoityne-vscode-0.0.24.0](https://hackage.haskell.org/package/phoityne-vscode) __Need update from hackage !!.__ * Release Summary - * [UPDATE] supported haskell-dap-0.0.3.0 + * [UPDATE] supported haskell-dap-0.0.5.0 ![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).) @@ -112,6 +112,7 @@ * supportsExceptionInfoRequest : no * supportTerminateDebuggee : no * supportsDelayedStackTraceLoading : no +* supportsLogPoints : **yes** (by haskell-dap) ## Install 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 @@ -16,7 +16,6 @@ , loadFile , loadModule , setBreak - , setBreakDAP , setFuncBreak , delete , traceMain @@ -25,21 +24,18 @@ , step , stepLocal , history - , historyDAP , back , forward , bindings - , bindingsDAP , force - , forceDAP , info - , scopesDAP , showType , showKind , execBool , exec , complete , dapCommand + , dapCommand2 ) where import Control.Concurrent @@ -229,16 +225,12 @@ return res where - endOfLoadFile acc = do - let curStr = takeLastMsg acc + endOfLoadFile curStr _ = do outHdl $ curStr ++ "\n" if| U.startswith "Ok," curStr -> return False | U.startswith "Failed," curStr -> return False | otherwise -> return True - - takeLastMsg [] = "" - takeLastMsg xs = last xs - + withLoadResult (Left err ) = return $ Left err withLoadResult (Right msges) = readTillPrompt ghci >>= \case Left err -> return $ Left err @@ -314,50 +306,6 @@ -- | -- -setBreakDAP :: GHCiProcess - -> OutputHandler - -> FilePath - -> LineNo - -> ColNo - -> IO (Either ErrorData String) -setBreakDAP ghci outHdl path lineNo col = do - let cmd = ":dap-break " ++ path ++ " " ++ show lineNo ++ (if (-1) == col then "" else " " ++ show col) - - lock ghci - res <- exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> do - let msgs = filter (L.isPrefixOf _DAP_HEADER) $ lines msg - if 1 == length msgs then return $ Right $ drop (length _DAP_HEADER) $ head msgs - else return $ Left $ "[dap] error. header " ++ _DAP_HEADER ++ "not found. " ++ msg - unlock ghci - - return res - --- | --- -dapCommand :: GHCiProcess - -> OutputHandler - -> String - -> String - -> IO (Either ErrorData String) -dapCommand ghci outHdl cmdStr strDat = do - let cmd = cmdStr ++ " " ++ strDat - - lock ghci - res <- exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> do - let msgs = filter (L.isPrefixOf _DAP_HEADER) $ lines msg - if 1 == length msgs then return $ Right $ drop (length _DAP_HEADER) $ head msgs - else return $ Left $ "[dap] error. header " ++ _DAP_HEADER ++ "not found. " ++ msg - unlock ghci - - return res - - --- | --- setFuncBreak :: GHCiProcess -> OutputHandler -> String @@ -457,20 +405,7 @@ Right msg -> return $ extractStackFrame msg --- | --- -historyDAP :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData String) -historyDAP ghci outHdl _ = do - let cmd = ":dap-history" - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> do - let msgs = filter (L.isPrefixOf _DAP_HEADER) $ lines msg - if 1 == length msgs then return $ Right $ drop (length _DAP_HEADER) $ head msgs - else return $ Left $ "[dap] error. header " ++ _DAP_HEADER ++ "not found. " ++ msg - - -- | -- back :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData SourcePosition) @@ -503,32 +438,6 @@ -- | -- -bindingsDAP :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData String) -bindingsDAP ghci outHdl idx = do - let cmd = ":dap-bindings " ++ show idx - - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> do - let msgs = filter (L.isPrefixOf _DAP_HEADER) $ lines msg - if 1 == length msgs then return $ Right $ drop (length _DAP_HEADER) $ head msgs - else return $ Left $ "[dap] error. header " ++ _DAP_HEADER ++ "not found. " ++ msg - --- | --- -scopesDAP :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData String) -scopesDAP ghci outHdl idx = do - let cmd = ":dap-scopes " ++ show idx - - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> do - let msgs = filter (L.isPrefixOf _DAP_HEADER) $ lines msg - if 1 == length msgs then return $ Right $ drop (length _DAP_HEADER) $ head msgs - else return $ Left $ "[dap] error. header " ++ _DAP_HEADER ++ "not found. " ++ msg - --- | --- force :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) force ghci outHdl target = do let cmd = ":force " ++ target @@ -536,18 +445,6 @@ Left err -> return $ Left err Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) --- | --- -forceDAP :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) -forceDAP ghci outHdl target = do - let cmd = ":dap-force " ++ target - - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> do - let msgs = filter (L.isPrefixOf _DAP_HEADER) $ lines msg - if 1 == length msgs then return $ Right $ drop (length _DAP_HEADER) $ head msgs - else return $ Left $ "[dap] error. header " ++ _DAP_HEADER ++ "not found. " ++ msg -- | -- @@ -809,5 +706,66 @@ -- unlock :: GHCiProcess -> IO () unlock ghci = putMVar (lockGHCiProcess ghci) Lock + + + +-- | +-- +dapCommand :: GHCiProcess + -> OutputHandler + -> String + -> String + -> IO (Either ErrorData String) +dapCommand ghci outHdl cmdStr strDat = do + let cmd = cmdStr ++ " " ++ strDat + + lock ghci + res <- exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> do + let msgs = filter (L.isPrefixOf _DAP_HEADER) $ lines msg + if 1 == length msgs then return $ Right $ drop (length _DAP_HEADER) $ head msgs + else return $ Left $ "[dap] error. header " ++ _DAP_HEADER ++ "not found. " ++ msg + unlock ghci + + return res + + +-- | +-- +dapCommand2 :: GHCiProcess + -> OutputHandler + -> String + -> String + -> IO (Either ErrorData [String]) +dapCommand2 ghci outHdl cmdStr strDat = do + let cmd = cmdStr ++ " " ++ strDat + + outHdl $ cmd ++ "\n" + + lock ghci + res <- writeLine ghci cmd >>= \case + Left err -> return $ Left err + Right _ -> readLineWhileIO ghci proc >>= witResult + unlock ghci + + return res + where + proc curStr _ = do + outHdl curStr + return $ curStr /= _DAP_CMD_END + + witResult (Left err ) = return $ Left err + witResult (Right msges) = readTillPrompt ghci >>= \case + Left err -> return $ Left err + Right prmt -> do + outHdl prmt + return . Right $ msges + + +-- | +-- +_DAP_CMD_END :: String +_DAP_CMD_END = "<>" diff --git a/app/Phoityne/GHCi/Process.hs b/app/Phoityne/GHCi/Process.hs --- a/app/Phoityne/GHCi/Process.hs +++ b/app/Phoityne/GHCi/Process.hs @@ -223,7 +223,7 @@ -- | -- read line from ghci. -- -readLineWhileIO :: GHCiProcess -> ([String] -> IO Bool) -> IO (Either ErrorData [String]) +readLineWhileIO :: GHCiProcess -> (String -> [String] -> IO Bool) -> IO (Either ErrorData [String]) readLineWhileIO (GHCiProcess _ ghciOut _ _ _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case True -> go [] False -> return . Left $ "handle not open." @@ -233,7 +233,7 @@ False -> do l <- S.hGetLine ghciOut let acc' = acc ++ [l] - condProc acc' >>= \case + condProc l acc' >>= \case True -> go acc' False -> return . Right $ acc' 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 @@ -45,7 +45,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Text.Read as R -import Data.Word import Phoityne.VSCode.Constant import Phoityne.VSCode.Utility @@ -443,16 +442,8 @@ -- | -- -readDAP :: Read a => String -> Either String a -readDAP argsStr = case R.readEither argsStr :: Either String [Word8] of - Left err -> Left $ "read [Word8] failed. " ++ err ++ " : " ++ argsStr - Right bs -> case R.readEither (toStr bs) of - Left err -> Left $ "read response body failed. " ++ err ++ " : " ++ (toStr bs) - Right a -> Right a - where - toStr = T.unpack . T.decodeUtf8 . BS.pack - --- | +-- phoityne -> haskell-dap +-- encoding RequestArgument to [Word8] because of using ghci command line interface. -- showDAP :: Show a => a -> String showDAP = show . BS.unpack . T.encodeUtf8 . T.pack . show @@ -472,30 +463,23 @@ exceptIO (Left err) = throwError err exceptIO (Right a) = return a --- | --- -readExcept :: Read a => String -> ExceptT String IO (Either String a) -readExcept = exceptIO . readDAP +-- |===================================================================== +-- DAP Handlers +-- -- | -- -outHdlDAP :: MVar DebugContextData -> String -> IO () -outHdlDAP mvarCtx msgs = do - let normMsgs = unlines $ map normalize $ lines msgs - sendStdoutEvent mvarCtx normMsgs - - where - normalize msg - | L.isPrefixOf "<>" msg = "<> ..." - | L.isPrefixOf ":dap-" msg = (takeWhile ((/=) '[') msg) ++ " ..." - | otherwise = msg - +_DAP_HEADER :: String +_DAP_HEADER = "<>" --- |===================================================================== --- DAP Handlers +-- | -- +_DAP_HEADER_OUTPUT_EVENT :: String +_DAP_HEADER_OUTPUT_EVENT = "<>" +-- | +-- type DAPRequestHandler = MVar DebugContextData -> BSL.ByteString -> BSL.ByteString @@ -506,26 +490,26 @@ -- _SUPPORTED_DAP :: M.Map String DAPRequestHandler _SUPPORTED_DAP = M.fromList [ - ("setBreakpoints", setBreakpointsRequestHandlerDAP) - , ("setFunctionBreakpoints", setFunctionBreakpointsRequestHandlerDAP) - -- , ("setExceptionBreakpoints", setExceptionBreakpointsHandlerDAP) - , ("continue", continueRequestHandlerDAP) - , ("next", nextRequestHandlerDAP) - , ("stepIn", stepInRequestHandlerDAP) - , ("stackTrace", stackTraceRequestHandlerDAP) - , ("scopes", scopesRequestHandlerDAP) - , ("variables", variablesRequestHandlerDAP) - , ("evaluate", evaluateRequestHandlerDAP) - -- , ("completions", completionsHandlerDAP) + ("setBreakpoints", setBreakpointsRequestHandlerDAP) + , ("setFunctionBreakpoints", setFunctionBreakpointsRequestHandlerDAP) + , ("continue", continueRequestHandlerDAP) + , ("next", nextRequestHandlerDAP) + , ("stepIn", stepInRequestHandlerDAP) + , ("stackTrace", stackTraceRequestHandlerDAP) + , ("scopes", scopesRequestHandlerDAP) + , ("variables", variablesRequestHandlerDAP) + , ("evaluate", evaluateRequestHandlerDAP) ---------------------------------------------------------------------- -- phoityne-vscode handle request. -- - -- , ("initialize", ) - -- , ("launch", ) - -- , ("configurationDone", ) - -- , ("disconnect", ) - -- , ("threads", ) + -- , ("initialize", ) + -- , ("launch", ) + -- , ("setExceptionBreakpoints") + -- , ("configurationDone", ) + -- , ("disconnect", ) + -- , ("threads", ) + -- , ("completions", ) ] @@ -576,6 +560,27 @@ -- | -- +outputEventHandler :: MVar DebugContextData -> String -> IO () +outputEventHandler mvarCtx str = case R.readEither str of + Left err -> do + let msg = "[DAP][OUTPUT] read body failed. " ++ err ++ " : " ++ str + errorM _LOG_NAME msg + sendErrorEvent mvarCtx msg + + Right (Left err) -> do + let msg = "[DAP][OUTPUT] output event error. " ++ err ++ " : " ++ str + errorM _LOG_NAME msg + sendErrorEvent mvarCtx msg + + Right (Right body) -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let outEvt = J.defaultOutputEvent resSeq + outEvtStr = J.encode outEvt{J.bodyOutputEvent = body} + sendEvent mvarCtx outEvtStr + + +-- | +-- setBreakpointsRequestHandlerDAP :: DAPRequestHandler setBreakpointsRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err @@ -589,28 +594,59 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorSetBreakpointsResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - Right body -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultSetBreakpointsResponse resSeq req - resStr = J.encode res{J.bodySetBreakpointsResponse = body} - sendResponse mvarCtx resStr + Right _ -> return () + Left err -> sendErrRes mvarCtx req err where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + go = getProcExcept mvarCtx >>= runDap runDap proc = do let cmd = ":dap-set-breakpoints" args = showDAP $ J.argumentsSetBreakpointsRequest req - liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd 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 -> + 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 () + + -- | + -- + dapHdl :: MVar DebugContextData -> J.SetBreakpointsRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Left err) -> do + errorM _LOG_NAME $ "setBreakpointRequest failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Right body) -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultSetBreakpointsResponse resSeq req + resStr = J.encode res{J.bodySetBreakpointsResponse = body} + sendResponse mvarCtx resStr + + -- | + -- + sendErrRes :: MVar DebugContextData -> J.SetBreakpointsRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorSetBreakpointsResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr + -- | -- setFunctionBreakpointsRequestHandlerDAP :: DAPRequestHandler @@ -626,28 +662,60 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorSetFunctionBreakpointsResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - Right body -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultSetFunctionBreakpointsResponse resSeq req - resStr = J.encode res{J.bodySetFunctionBreakpointsResponse = body} - sendResponse mvarCtx resStr + Right _ -> return () + Left err -> sendErrRes mvarCtx req err where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + go = getProcExcept mvarCtx >>= runDap runDap proc = do let cmd = ":dap-set-function-breakpoints" args = showDAP $ J.argumentsSetFunctionBreakpointsRequest req - liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd 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 -> + 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 () + + -- | + -- + dapHdl :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Left err) -> do + errorM _LOG_NAME $ "setFunctionBreakpointRequest failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Right body) -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultSetFunctionBreakpointsResponse resSeq req + resStr = J.encode res{J.bodySetFunctionBreakpointsResponse = body} + sendResponse mvarCtx resStr + + -- | + -- + sendErrRes :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorSetFunctionBreakpointsResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr + + -- | -- continueRequestHandlerDAP :: DAPRequestHandler @@ -663,31 +731,31 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorContinueResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - - Right body -> handleStoppeEventBody body - + Right _ -> return () + Left err -> sendErrRes mvarCtx req err where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + -- | + -- + go = getProcExcept mvarCtx >>= runDap + -- | + -- runDap proc = do cmdArgs <- liftIO getCmdArgs let cmd = ":dap-continue" reqArgs= J.argumentsContinueRequest req args = showDAP $ reqArgs { J.exprContinueArguments = cmdArgs } - liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO + -- | + -- getCmdArgs = do - isStarted <- debugStartedDebugContextData <$> readMVar mvarCtx - startupFunc <- startupFuncDebugContextData <$> readMVar mvarCtx - startupArgs <- startupArgsDebugContextData <$> readMVar mvarCtx + isStarted <- debugStartedDebugContextData <$> readMVar mvarCtx + startupFunc <- startupFuncDebugContextData <$> readMVar mvarCtx + startupArgs <- startupArgsDebugContextData <$> readMVar mvarCtx ctx <- takeMVar mvarCtx putMVar mvarCtx ctx { @@ -700,6 +768,35 @@ then return $ Just "main" else return $ Just $ startupFunc ++ " " ++ startupArgs + -- | + -- + outHdl :: MVar DebugContextData -> J.ContinueRequest -> String -> IO () + outHdl mvarCtx req str = do + + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str + + if | U.startswith _DAP_HEADER 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 () + + -- | + -- + dapHdl :: MVar DebugContextData -> J.ContinueRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Left err) -> do + errorM _LOG_NAME $ "continueRequest failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Right body) -> handleStoppeEventBody body + + -- | + -- handleStoppeEventBody body | "complete" == J.reasonStoppedEventBody body = do debugM _LOG_NAME "[DAP] debugging completeed." @@ -715,6 +812,14 @@ stopEvtStr = J.encode stopEvt{J.bodyStoppedEvent = body} sendEvent mvarCtx stopEvtStr + -- | + -- + sendErrRes :: MVar DebugContextData -> J.ContinueRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorContinueResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr -- | @@ -732,23 +837,47 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorNextResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - Right body -> handleStoppeEventBody body + Right _ -> return () + Left err -> sendErrRes mvarCtx req err where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + go = getProcExcept mvarCtx >>= runDap runDap proc = do let cmd = ":dap-next" args = showDAP $ J.argumentsNextRequest req - liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd 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 -> + 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 () + + -- | + -- + dapHdl :: MVar DebugContextData -> J.NextRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Left err) -> do + errorM _LOG_NAME $ "nextRequest failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Right body) -> handleStoppeEventBody body + + handleStoppeEventBody body | "complete" == J.reasonStoppedEventBody body = do debugM _LOG_NAME "[DAP] debugging completeed." @@ -764,7 +893,16 @@ stopEvtStr = J.encode stopEvt{J.bodyStoppedEvent = body} sendEvent mvarCtx stopEvtStr + -- | + -- + sendErrRes :: MVar DebugContextData -> J.NextRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorNextResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr + -- | -- stepInRequestHandlerDAP :: DAPRequestHandler @@ -780,23 +918,47 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorStepInResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - Right body -> handleStoppeEventBody body + Right _ -> return () + Left err -> sendErrRes mvarCtx req err where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + go = getProcExcept mvarCtx >>= runDap runDap proc = do let cmd = ":dap-step-in" args = showDAP $ J.argumentsStepInRequest req - liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd 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 -> + 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 () + + -- | + -- + dapHdl :: MVar DebugContextData -> J.StepInRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Left err) -> do + errorM _LOG_NAME $ "continueRequest failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Right body) -> handleStoppeEventBody body + + handleStoppeEventBody body | "complete" == J.reasonStoppedEventBody body = do debugM _LOG_NAME "[DAP] debugging completeed." @@ -812,6 +974,14 @@ stopEvtStr = J.encode stopEvt{J.bodyStoppedEvent = body} sendEvent mvarCtx stopEvtStr + -- | + -- + sendErrRes :: MVar DebugContextData -> J.StepInRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorStepInResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr -- | -- @@ -828,30 +998,59 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorStackTraceResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - Right body -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultStackTraceResponse resSeq req - resStr = J.encode res { J.bodyStackTraceResponse = body } - sendResponse mvarCtx resStr + Right _ -> return () + Left err -> sendErrRes mvarCtx req err where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + go = getProcExcept mvarCtx >>= runDap runDap proc = do let cmd = ":dap-stacktrace" args = showDAP $ J.argumentsStackTraceRequest req - liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO - outHdl = debugM _LOG_NAME + -- | + -- + outHdl :: MVar DebugContextData -> J.StackTraceRequest -> String -> IO () + outHdl mvarCtx req str = do + + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str + if | U.startswith _DAP_HEADER 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 () + -- | + -- + dapHdl :: MVar DebugContextData -> J.StackTraceRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + 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 (Right body) -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultStackTraceResponse resSeq req + resStr = J.encode res { J.bodyStackTraceResponse = body } + sendResponse mvarCtx resStr + + -- | + -- + sendErrRes :: MVar DebugContextData -> J.StackTraceRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorStackTraceResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr + -- | -- scopesRequestHandlerDAP :: DAPRequestHandler @@ -867,30 +1066,60 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorScopesResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - Right body -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultScopesResponse resSeq req - resStr = J.encode res { J.bodyScopesResponse = body } - sendResponse mvarCtx resStr + Right _ -> return () + Left err -> sendErrRes mvarCtx req err - where + where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + go = getProcExcept mvarCtx >>= runDap runDap proc = do let cmd = ":dap-scopes" args = showDAP $ J.argumentsScopesRequest req - liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO - outHdl = debugM _LOG_NAME + -- | + -- + outHdl :: MVar DebugContextData -> J.ScopesRequest -> String -> IO () + outHdl mvarCtx req str = do + + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str + if | U.startswith _DAP_HEADER 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 () + + -- | + -- + dapHdl :: MVar DebugContextData -> J.ScopesRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Left err) -> do + errorM _LOG_NAME $ "scopesRequestHandler failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Right body) -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultScopesResponse resSeq req + resStr = J.encode res { J.bodyScopesResponse = body } + sendResponse mvarCtx resStr + + -- | + -- + sendErrRes :: MVar DebugContextData -> J.ScopesRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorScopesResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr + -- | -- variablesRequestHandlerDAP :: DAPRequestHandler @@ -906,30 +1135,60 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorVariablesResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - Right body -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultVariablesResponse resSeq req - resStr = J.encode res { J.bodyVariablesResponse = body } - sendResponse mvarCtx resStr + Right _ -> return () + Left err -> sendErrRes mvarCtx req err where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + go = getProcExcept mvarCtx >>= runDap runDap proc = do let cmd = ":dap-variables" args = showDAP $ J.argumentsVariablesRequest req - liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO - outHdl = debugM _LOG_NAME + -- | + -- + outHdl :: MVar DebugContextData -> J.VariablesRequest -> String -> IO () + outHdl mvarCtx req str = do + + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str + if | U.startswith _DAP_HEADER 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 () + -- | + -- + dapHdl :: MVar DebugContextData -> J.VariablesRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Left err) -> do + errorM _LOG_NAME $ "variablesRequestHandler failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Right body) -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultVariablesResponse resSeq req + resStr = J.encode res { J.bodyVariablesResponse = body } + sendResponse mvarCtx resStr + + -- | + -- + sendErrRes :: MVar DebugContextData -> J.VariablesRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorVariablesResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr + + -- | -- evaluateRequestHandlerDAP :: DAPRequestHandler @@ -945,30 +1204,62 @@ logRequest $ show req runExceptT go >>= \case - Left err -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.errorEvaluateResponse resSeq req err - resStr = J.encode res - sendResponse mvarCtx resStr - Right body -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultEvaluateResponse resSeq req - resStr = J.encode res { J.bodyEvaluateResponse = body } - sendResponse mvarCtx resStr + Right _ -> return () + Left err -> sendErrRes mvarCtx req err where - go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO + go = getProcExcept mvarCtx >>= runDap runDap proc = do - let cmd = ":dap-evaluate" - args = showDAP $ J.argumentsEvaluateRequest req + let cmd = ":dap-evaluate" + args = J.argumentsEvaluateRequest req + dapArgs = showDAP args - liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO + liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd dapArgs) >>= exceptIO + + + -- | + -- + outHdl :: MVar DebugContextData -> J.EvaluateRequest -> String -> IO () + outHdl mvarCtx req str = do - outHdl = debugM _LOG_NAME - + infoM _LOG_NAME $ "[GHCi][STDOUT] " ++ str + if | U.startswith _DAP_HEADER 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 () + + -- | + -- + dapHdl :: MVar DebugContextData -> J.EvaluateRequest -> String -> IO () + dapHdl mvarCtx req str = case R.readEither str of + Left err -> do + errorM _LOG_NAME $ "read response body failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Left err) -> do + errorM _LOG_NAME $ "evaluateRequestHandlerDAP failed. " ++ err ++ " : " ++ str + sendErrRes mvarCtx req err + + Right (Right body) -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultEvaluateResponse resSeq req + resStr = J.encode res { J.bodyEvaluateResponse = body } + sendResponse mvarCtx resStr + + -- | + -- + sendErrRes :: MVar DebugContextData -> J.EvaluateRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorEvaluateResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr + + -- |===================================================================== -- Handlers -- @@ -1127,6 +1418,7 @@ , J.supportsCompletionsRequestInitializeResponseCapabilities = True , J.supportsModulesRequestInitializeResponseCapabilities = False -- no GUI on VSCode , J.additionalModuleColumnsInitializeResponseCapabilities = [] -- no GUI on VSCode + , J.supportsLogPointsInitializeResponseCapabilities = True } res = J.InitializeResponse resSeq "response" seq True "initialize" "" capa @@ -1381,7 +1673,7 @@ sendResponse mvarCtx $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg sendErrorEvent mvarCtx msg - convBp cwd path startup stMod (J.SourceBreakpoint lineNo colNo cond hitCond) = + convBp cwd path startup stMod (J.SourceBreakpoint lineNo colNo cond hitCond _) = BreakPointData { nameBreakPointData = src2mod cwd path startup stMod , srcPosBreakPointData = G.SourcePosition path lineNo (maybe (-1) id colNo) (-1) (-1) @@ -1707,7 +1999,6 @@ stackTraceRequestHandler :: MVar DebugContextData -> J.StackTraceRequest -> IO () stackTraceRequestHandler mvarCtx req = flip E.catches handlers $ do logRequest $ show req - ctx <- readMVar mvarCtx case debugStoppedPosDebugContextData ctx of Nothing -> do diff --git a/app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs --- a/app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs +++ b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs @@ -28,6 +28,7 @@ , supportsCompletionsRequestInitializeResponseCapabilities :: Bool -- The debug adapter supports the completionsRequest. , supportsModulesRequestInitializeResponseCapabilities :: Bool -- The debug adapter supports the modules request. , additionalModuleColumnsInitializeResponseCapabilities :: [ColumnDescriptor] -- The set of additional module information exposed by the debug adapter. + , supportsLogPointsInitializeResponseCapabilities :: Bool -- The debug adapter supports logpoints by interpreting the 'logMessage' attribute of the SourceBreakpoint. } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilities") } ''InitializeResponseCapabilities) @@ -35,5 +36,5 @@ -- | -- defaultInitializeResponseCapabilities :: InitializeResponseCapabilities -defaultInitializeResponseCapabilities = InitializeResponseCapabilities False False False False False [] False False False False False False False [] +defaultInitializeResponseCapabilities = InitializeResponseCapabilities False False False False False [] False False False False False False False [] False diff --git a/app/Phoityne/VSCode/TH/ResponseJSON.hs b/app/Phoityne/VSCode/TH/ResponseJSON.hs --- a/app/Phoityne/VSCode/TH/ResponseJSON.hs +++ b/app/Phoityne/VSCode/TH/ResponseJSON.hs @@ -5,7 +5,6 @@ import Data.Aeson.TH -import Phoityne.VSCode.TH.RequestJSON import Phoityne.VSCode.Utility -- | diff --git a/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs b/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs --- a/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs +++ b/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs @@ -15,6 +15,7 @@ , columnSourceBreakpoint :: Maybe Int -- An optional source column of the breakpoint. , conditionSourceBreakpoint :: Maybe String -- An optional expression for conditional breakpoints. , hitConditionSourceBreakpoint :: Maybe String -- An optional expression that controls how many hits of the breakpoint are ignored. The backend is expected to interpret the expression as needed. + , logMessageSourceBreakpoint :: Maybe String -- ^If this attribute exists and is non-empty, the backend must not 'break' (stop) but log the message instead. Expressions within {} are interpolated. } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceBreakpoint") } ''SourceBreakpoint) diff --git a/phoityne-vscode.cabal b/phoityne-vscode.cabal --- a/phoityne-vscode.cabal +++ b/phoityne-vscode.cabal @@ -1,5 +1,5 @@ name: phoityne-vscode -version: 0.0.23.0 +version: 0.0.24.0 synopsis: Haskell Debug Adapter for Visual Studio Code. description: Please see README.md license: BSD3