phoityne-vscode 0.0.22.0 → 0.0.23.0
raw patch · 6 files changed
+204/−41 lines, 6 files
Files
- Changelog.md +5/−0
- app/Phoityne/VSCode/Core.hs +174/−16
- app/Phoityne/VSCode/TH/SetFunctionBreakpointsArgumentsJSON.hs +21/−0
- app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestArgumentsJSON.hs +0/−21
- app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs +2/−2
- phoityne-vscode.cabal +2/−2
Changelog.md view
@@ -1,3 +1,8 @@++20180430 phoityne-vscode-0.0.23.0+ * [UPDATE] supported haskell-dap-0.0.4.0++ 20180225 phoityne-vscode-0.0.22.0 * [UPDATE] supported haskell-dap-0.0.3.0
app/Phoityne/VSCode/Core.hs view
@@ -95,7 +95,7 @@ import qualified Phoityne.VSCode.TH.SetBreakpointsRequestJSON as J import qualified Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON as J import qualified Phoityne.VSCode.TH.SetBreakpointsResponseJSON as J-import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON as J+import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsArgumentsJSON as J import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON as J import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON as J import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseJSON as J@@ -242,8 +242,8 @@ , " \"isDefault\": true" , " }," , " \"label\": \"stack build\","- , " \"type\": \"shell\","- , " \"command\": \"echo START_STACK_BUILD && cd ${workspaceRoot} && stack build && echo END_STACK_BUILD \""+ , " \"type\": \"shell\","+ , " \"command\": \"echo START_STACK_BUILD && cd ${workspaceRoot} && stack build && echo END_STACK_BUILD \"" , " }," , " { " , " \"group\": \"build\","@@ -478,6 +478,20 @@ readExcept = exceptIO . readDAP +-- |+--+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 Handlers --@@ -493,11 +507,25 @@ _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)++ ----------------------------------------------------------------------+ -- phoityne-vscode handle request.+ --+ -- , ("initialize", )+ -- , ("launch", )+ -- , ("configurationDone", )+ -- , ("disconnect", )+ -- , ("threads", ) ] @@ -580,14 +608,48 @@ let cmd = ":dap-set-breakpoints" args = showDAP $ J.argumentsSetBreakpointsRequest req - liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO- - outHdl = sendStdoutEvent mvarCtx+ liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO +-- |+--+setFunctionBreakpointsRequestHandlerDAP :: DAPRequestHandler+setFunctionBreakpointsRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of+ Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err+ Right req -> runSetFunctionBreakpoints mvarCtx req + -- | --+runSetFunctionBreakpoints :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> IO ()+runSetFunctionBreakpoints mvarCtx req = do+ 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++ where++ go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO++ runDap proc = do+ let cmd = ":dap-set-function-breakpoints"+ args = showDAP $ J.argumentsSetFunctionBreakpointsRequest req++ liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO+++-- |+-- continueRequestHandlerDAP :: DAPRequestHandler continueRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err@@ -620,9 +682,7 @@ reqArgs= J.argumentsContinueRequest req args = showDAP $ reqArgs { J.exprContinueArguments = cmdArgs } - liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO- - outHdl = sendStdoutEvent mvarCtx+ liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO getCmdArgs = do isStarted <- debugStartedDebugContextData <$> readMVar mvarCtx@@ -656,8 +716,105 @@ sendEvent mvarCtx stopEvtStr + -- | --+nextRequestHandlerDAP :: DAPRequestHandler+nextRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of+ Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err+ Right req -> runNext mvarCtx req+++-- |+--+runNext :: MVar DebugContextData -> J.NextRequest -> IO ()+runNext mvarCtx req = do+ 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++ where++ go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO++ runDap proc = do+ let cmd = ":dap-next"+ args = showDAP $ J.argumentsNextRequest req++ liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO+ + handleStoppeEventBody body + | "complete" == J.reasonStoppedEventBody body = do+ debugM _LOG_NAME "[DAP] debugging completeed."+ sendTerminateEvent mvarCtx+ | otherwise = do+ resSeq <- getIncreasedResponseSequence mvarCtx+ let res = J.defaultNextResponse resSeq req+ resStr = J.encode res+ sendResponse mvarCtx resStr++ resSeq <- getIncreasedResponseSequence mvarCtx+ let stopEvt = J.defaultStoppedEvent resSeq+ stopEvtStr = J.encode stopEvt{J.bodyStoppedEvent = body}+ sendEvent mvarCtx stopEvtStr+++-- |+--+stepInRequestHandlerDAP :: DAPRequestHandler+stepInRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of+ Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err+ Right req -> runStepIn mvarCtx req+++-- |+--+runStepIn :: MVar DebugContextData -> J.StepInRequest -> IO ()+runStepIn mvarCtx req = do+ 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++ where++ go = getProcExcept mvarCtx >>= runDap >>= readExcept >>= exceptIO++ runDap proc = do+ let cmd = ":dap-step-in"+ args = showDAP $ J.argumentsStepInRequest req++ liftIO (G.dapCommand proc (outHdlDAP mvarCtx) cmd args) >>= exceptIO+ + handleStoppeEventBody body + | "complete" == J.reasonStoppedEventBody body = do+ debugM _LOG_NAME "[DAP] debugging completeed."+ sendTerminateEvent mvarCtx+ | otherwise = do+ resSeq <- getIncreasedResponseSequence mvarCtx+ let res = J.defaultStepInResponse resSeq req+ resStr = J.encode res+ sendResponse mvarCtx resStr++ resSeq <- getIncreasedResponseSequence mvarCtx+ let stopEvt = J.defaultStoppedEvent resSeq+ stopEvtStr = J.encode stopEvt{J.bodyStoppedEvent = body}+ sendEvent mvarCtx stopEvtStr+++-- |+-- stackTraceRequestHandlerDAP :: DAPRequestHandler stackTraceRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err@@ -692,8 +849,7 @@ liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO - outHdl = sendStdoutEvent mvarCtx-+ outHdl = debugM _LOG_NAME -- |@@ -731,8 +887,8 @@ args = showDAP $ J.argumentsScopesRequest req liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO- - outHdl = sendStdoutEvent mvarCtx+ + outHdl = debugM _LOG_NAME -- |@@ -771,8 +927,9 @@ liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO - outHdl = sendStdoutEvent mvarCtx+ outHdl = debugM _LOG_NAME + -- | -- evaluateRequestHandlerDAP :: DAPRequestHandler@@ -809,7 +966,8 @@ liftIO (G.dapCommand proc outHdl cmd args) >>= exceptIO - outHdl = sendStdoutEvent mvarCtx+ outHdl = debugM _LOG_NAME+ -- |===================================================================== -- Handlers@@ -1292,7 +1450,7 @@ logRequest $ show req let args = J.argumentsSetFunctionBreakpointsRequest req- reqBps = J.breakpointsSetFunctionBreakpointsRequestArguments args+ reqBps = J.breakpointsSetFunctionBreakpointsArguments args bps = map convBp reqBps delete
+ app/Phoityne/VSCode/TH/SetFunctionBreakpointsArgumentsJSON.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}+++module Phoityne.VSCode.TH.SetFunctionBreakpointsArgumentsJSON where++import Data.Aeson.TH++import Phoityne.VSCode.Utility+import Phoityne.VSCode.TH.FunctionBreakpointJSON++-- |+-- Arguments for "setFunctionBreakpoints" request.+--+data SetFunctionBreakpointsArguments =+ SetFunctionBreakpointsArguments {+ breakpointsSetFunctionBreakpointsArguments :: [FunctionBreakpoint] -- The function names of the breakpoints.+ } deriving (Show, Read, Eq)+++$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetFunctionBreakpointsArguments") } ''SetFunctionBreakpointsArguments)+
− app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestArgumentsJSON.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---module Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON where--import Data.Aeson.TH--import Phoityne.VSCode.Utility-import Phoityne.VSCode.TH.FunctionBreakpointJSON---- |--- Arguments for "setFunctionBreakpoints" request.----data SetFunctionBreakpointsRequestArguments =- SetFunctionBreakpointsRequestArguments {- breakpointsSetFunctionBreakpointsRequestArguments :: [FunctionBreakpoint] -- The function names of the breakpoints.- } deriving (Show, Read, Eq)---$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetFunctionBreakpointsRequestArguments") } ''SetFunctionBreakpointsRequestArguments)-
app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs view
@@ -6,7 +6,7 @@ import Data.Aeson.TH import Phoityne.VSCode.Utility-import Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON+import Phoityne.VSCode.TH.SetFunctionBreakpointsArgumentsJSON -- | -- SetFunctionBreakpoints request; value of command field is "setFunctionBreakpoints".@@ -19,7 +19,7 @@ seqSetFunctionBreakpointsRequest :: Int -- Sequence number , typeSetFunctionBreakpointsRequest :: String -- One of "request", "response", or "event" , commandSetFunctionBreakpointsRequest :: String -- The command to execute- , argumentsSetFunctionBreakpointsRequest :: SetFunctionBreakpointsRequestArguments -- Arguments for "setFunctionBreakpoints" request.+ , argumentsSetFunctionBreakpointsRequest :: SetFunctionBreakpointsArguments -- Arguments for "setFunctionBreakpoints" request. } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetFunctionBreakpointsRequest") } ''SetFunctionBreakpointsRequest)
phoityne-vscode.cabal view
@@ -1,5 +1,5 @@ name: phoityne-vscode-version: 0.0.22.0+version: 0.0.23.0 synopsis: Haskell Debug Adapter for Visual Studio Code. description: Please see README.md license: BSD3@@ -88,7 +88,7 @@ , Phoityne.VSCode.TH.SetExceptionBreakpointsRequestArgumentsJSON , Phoityne.VSCode.TH.SetExceptionBreakpointsRequestJSON , Phoityne.VSCode.TH.SetExceptionBreakpointsResponseJSON- , Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON+ , Phoityne.VSCode.TH.SetFunctionBreakpointsArgumentsJSON , Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON , Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON , Phoityne.VSCode.TH.SetFunctionBreakpointsResponseJSON