phoityne-vscode 0.0.23.0 → 0.0.24.0
raw patch · 9 files changed
+524/−269 lines, 9 files
Files
- Changelog.md +4/−0
- README.md +4/−3
- app/Phoityne/GHCi/Command.hs +64/−106
- app/Phoityne/GHCi/Process.hs +2/−2
- app/Phoityne/VSCode/Core.hs +446/−155
- app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs +2/−1
- app/Phoityne/VSCode/TH/ResponseJSON.hs +0/−1
- app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs +1/−0
- phoityne-vscode.cabal +1/−1
Changelog.md view
@@ -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
README.md view
@@ -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  (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
app/Phoityne/GHCi/Command.hs view
@@ -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 = "<<DAP_CMD_END>>"
app/Phoityne/GHCi/Process.hs view
@@ -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'
app/Phoityne/VSCode/Core.hs view
@@ -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 "<<DAP>>" msg = "<<DAP>> ..."- | L.isPrefixOf ":dap-" msg = (takeWhile ((/=) '[') msg) ++ " ..."- | otherwise = msg-+_DAP_HEADER :: String+_DAP_HEADER = "<<DAP>>" --- |=====================================================================--- DAP Handlers+-- | --+_DAP_HEADER_OUTPUT_EVENT :: String+_DAP_HEADER_OUTPUT_EVENT = "<<DAP_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
app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs view
@@ -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
app/Phoityne/VSCode/TH/ResponseJSON.hs view
@@ -5,7 +5,6 @@ import Data.Aeson.TH -import Phoityne.VSCode.TH.RequestJSON import Phoityne.VSCode.Utility -- |
app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs view
@@ -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)
phoityne-vscode.cabal view
@@ -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