diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 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 @@ -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 "<>" msg = "<> ..." + | 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 diff --git a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsArgumentsJSON.hs b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsArgumentsJSON.hs @@ -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) + diff --git a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestArgumentsJSON.hs b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestArgumentsJSON.hs +++ /dev/null @@ -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) - diff --git a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs --- a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs +++ b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs @@ -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) 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.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