diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,4 +1,9 @@ +20180701 phoityne-vscode-0.0.25.0 + * [UPDATE] supported haskell-dap-0.0.6.0 + * [FIX][1](https://github.com/phoityne/haskell-debug-adapter/issues/1) : stopOnEntry false doesn't work with haskell-dap. + + 20180601 phoityne-vscode-0.0.24.0 * [UPDATE] supported haskell-dap-0.0.5.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,12 +6,13 @@ ## Information -* [2018/06/01] phoityne-vscode released. +* [2018/07/01] phoityne-vscode released. * Marketplace [phoityne-vscode-0.0.19](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) - * hackage [phoityne-vscode-0.0.24.0](https://hackage.haskell.org/package/phoityne-vscode) + * hackage [phoityne-vscode-0.0.25.0](https://hackage.haskell.org/package/phoityne-vscode) __Need update from hackage !!.__ * Release Summary - * [UPDATE] supported haskell-dap-0.0.5.0 + * [UPDATE] supported haskell-dap-0.0.6.0 + * [FIX] [1][stopOnEntry false doesn't work with haskell-dap.](https://github.com/phoityne/haskell-debug-adapter/issues/1) ![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).) 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 @@ -35,7 +35,6 @@ , exec , complete , dapCommand - , dapCommand2 ) where import Control.Concurrent @@ -708,37 +707,14 @@ 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 +dapCommand ghci outHdl cmdStr strDat = do let cmd = cmdStr ++ " " ++ strDat outHdl $ cmd ++ "\n" 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 @@ -492,6 +492,7 @@ _SUPPORTED_DAP = M.fromList [ ("setBreakpoints", setBreakpointsRequestHandlerDAP) , ("setFunctionBreakpoints", setFunctionBreakpointsRequestHandlerDAP) + , ("configurationDone", configurationDoneRequestHandlerDAP) , ("continue", continueRequestHandlerDAP) , ("next", nextRequestHandlerDAP) , ("stepIn", stepInRequestHandlerDAP) @@ -506,7 +507,6 @@ -- , ("initialize", ) -- , ("launch", ) -- , ("setExceptionBreakpoints") - -- , ("configurationDone", ) -- , ("disconnect", ) -- , ("threads", ) -- , ("completions", ) @@ -605,7 +605,7 @@ let cmd = ":dap-set-breakpoints" args = showDAP $ J.argumentsSetBreakpointsRequest req - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO -- | -- @@ -673,7 +673,7 @@ let cmd = ":dap-set-function-breakpoints" args = showDAP $ J.argumentsSetFunctionBreakpointsRequest req - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO -- | -- @@ -718,6 +718,129 @@ -- | -- +configurationDoneRequestHandlerDAP :: DAPRequestHandler +configurationDoneRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of + Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err + Right req -> runConfigurationDone mvarCtx req + + +-- | +-- +runConfigurationDone :: MVar DebugContextData -> J.ConfigurationDoneRequest -> IO () +runConfigurationDone mvarCtx req = do + logRequest $ show req + + runExceptT go >>= \case + Right _ -> return () + Left err -> sendErrRes mvarCtx req err + + where + + -- | + -- + go = getProcExcept mvarCtx >>= runDap + + -- | + -- + runDap proc = liftIO (runDapIO proc) >>= exceptIO + + -- | + -- + runDapIO proc = do + sendConsoleEvent mvarCtx $ L.intercalate "\n" _DEBUG_START_MSG + + checkVersion mvarCtx + + sendStdoutEvent mvarCtx $ G.promptGHCiProcess proc + + stopOnEntryDebugContextData <$> (readMVar mvarCtx) >>= stopOnEntry proc + + -- | + -- + _THREAD_ID = 1 + + -- | + -- + stopOnEntry _ True = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultConfigurationDoneResponse resSeq req + resStr = J.encode res + sendResponse mvarCtx resStr + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + + return $ Right [] + + -- | + -- + stopOnEntry proc False = do + cmdArgs <- getContinueCmdArgs mvarCtx + let cmd = ":dap-continue" + args = showDAP $ J.ContinueArguments _THREAD_ID cmdArgs + + G.dapCommand proc (outHdl mvarCtx req) cmd args + + -- | + -- + outHdl :: MVar DebugContextData -> J.ConfigurationDoneRequest -> 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.ConfigurationDoneRequest -> 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." + sendTerminateEvent mvarCtx + + | otherwise = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultConfigurationDoneResponse 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 + + + -- | + -- + sendErrRes :: MVar DebugContextData -> J.ConfigurationDoneRequest -> String -> IO () + sendErrRes mvarCtx req err = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.errorConfigurationDoneResponse resSeq req err + resStr = J.encode res + sendResponse mvarCtx resStr + + +-- | +-- continueRequestHandlerDAP :: DAPRequestHandler continueRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err @@ -743,30 +866,12 @@ -- | -- runDap proc = do - cmdArgs <- liftIO getCmdArgs + cmdArgs <- liftIO $ getContinueCmdArgs mvarCtx let cmd = ":dap-continue" reqArgs= J.argumentsContinueRequest req args = showDAP $ reqArgs { J.exprContinueArguments = cmdArgs } - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO - - -- | - -- - getCmdArgs = do - isStarted <- debugStartedDebugContextData <$> readMVar mvarCtx - startupFunc <- startupFuncDebugContextData <$> readMVar mvarCtx - startupArgs <- startupArgsDebugContextData <$> readMVar mvarCtx - - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx { - currentFrameIdDebugContextData = 0 - , debugStartedDebugContextData = True - } - - if isStarted then return Nothing - else if null startupFunc - then return $ Just "main" - else return $ Just $ startupFunc ++ " " ++ startupArgs + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO -- | -- @@ -824,6 +929,25 @@ -- | -- +getContinueCmdArgs :: MVar DebugContextData -> IO (Maybe String) +getContinueCmdArgs mvarCtx = do + isStarted <- debugStartedDebugContextData <$> readMVar mvarCtx + startupFunc <- startupFuncDebugContextData <$> readMVar mvarCtx + startupArgs <- startupArgsDebugContextData <$> readMVar mvarCtx + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx { + currentFrameIdDebugContextData = 0 + , debugStartedDebugContextData = True + } + + if isStarted then return Nothing + else if null startupFunc + then return $ Just "main" + else return $ Just $ startupFunc ++ " " ++ startupArgs + +-- | +-- nextRequestHandlerDAP :: DAPRequestHandler nextRequestHandlerDAP mvarCtx contLenStr jsonStr reqP = case J.eitherDecode jsonStr of Left err -> sendParseErrorResponse mvarCtx contLenStr jsonStr reqP err @@ -848,7 +972,7 @@ let cmd = ":dap-next" args = showDAP $ J.argumentsNextRequest req - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO -- | -- @@ -929,7 +1053,7 @@ let cmd = ":dap-step-in" args = showDAP $ J.argumentsStepInRequest req - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO -- | -- @@ -1009,7 +1133,7 @@ let cmd = ":dap-stacktrace" args = showDAP $ J.argumentsStackTraceRequest req - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO -- | -- @@ -1077,7 +1201,7 @@ let cmd = ":dap-scopes" args = showDAP $ J.argumentsScopesRequest req - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO -- | @@ -1146,7 +1270,7 @@ let cmd = ":dap-variables" args = showDAP $ J.argumentsVariablesRequest req - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd args) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd args) >>= exceptIO -- | -- @@ -1216,7 +1340,7 @@ args = J.argumentsEvaluateRequest req dapArgs = showDAP args - liftIO (G.dapCommand2 proc (outHdl mvarCtx req) cmd dapArgs) >>= exceptIO + liftIO (G.dapCommand proc (outHdl mvarCtx req) cmd dapArgs) >>= exceptIO -- | @@ -1484,13 +1608,16 @@ -- prepareTasksJsonFile = do ctx <- readMVar mvarCtx - let jsonFile = workspaceDebugContextData ctx ".vscode" "tasks.json" + let jsonDir = workspaceDebugContextData ctx ".vscode" + jsonFile = jsonDir "tasks.json" - doesFileExist jsonFile >>= \case - True -> debugM _LOG_NAME $ "tasks.json file exists. " ++ jsonFile - False -> do - sendConsoleEvent mvarCtx $ "create tasks.json file. " ++ jsonFile ++ "\n" - saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS + doesDirectoryExist jsonDir >>= \case + False -> debugM _LOG_NAME $ "setting folder not found. skip saveing tasks.json. DIR:" ++ jsonDir + True -> doesFileExist jsonFile >>= \case + True -> debugM _LOG_NAME $ "tasks.json file exists. " ++ jsonFile + False -> do + sendConsoleEvent mvarCtx $ "create tasks.json file. " ++ jsonFile ++ "\n" + saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS -- | -- @@ -1555,7 +1682,7 @@ withProcess (Just ghciProc) = do sendConsoleEvent mvarCtx $ L.intercalate "\n" _DEBUG_START_MSG - checkVersion + checkVersion mvarCtx sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc @@ -1571,17 +1698,21 @@ stopEvtStr = J.encode stopEvt sendEvent mvarCtx stopEvtStr - checkVersion = do - verStr <- hackagePackageVersionDebugContextData <$> (readMVar mvarCtx) - verArg <- case getVersion verStr of - Right v -> return v - Left err -> do - sendErrorEvent mvarCtx $ "[checkVersion] argument version parse error. " ++ err - return version +-- | +-- +checkVersion :: MVar DebugContextData -> IO () +checkVersion mvarCtx = do + verStr <- hackagePackageVersionDebugContextData <$> (readMVar mvarCtx) + verArg <- case getVersion verStr of + Right v -> return v + Left err -> do + sendErrorEvent mvarCtx $ "[checkVersion] argument version parse error. " ++ err + return version - when (version < verArg) $ do - sendErrorEvent mvarCtx $ L.intercalate "\n" _NEW_VERSION_MSG + when (version < verArg) $ do + sendErrorEvent mvarCtx $ L.intercalate "\n" _NEW_VERSION_MSG + where getVersion :: String -> Either String V.Version getVersion str = case parse getVersionParser "getVersionParser" str of Right v -> Right v @@ -2179,7 +2310,7 @@ withProcess _ _ Nothing = sendErrorEvent mvarCtx "[evaluateRequestHandler] ghci not started." - withProcess "watch" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case + withProcess (Just "watch") exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case Left err -> do errorM _LOG_NAME $ show err evaluateResponse err "" @@ -2190,7 +2321,7 @@ Right valStr -> evaluateResponse (getOnlyValue valStr) (getOnlyType typeStr) Left _ -> evaluateResponse "" (getOnlyType typeStr) - withProcess "hover" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case + withProcess (Just "hover") exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case Left err -> do errorM _LOG_NAME $ show err evaluateResponse err "" diff --git a/app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs b/app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs --- a/app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs +++ b/app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs @@ -26,7 +26,7 @@ etc. -} - , contextEvaluateArguments :: String + , contextEvaluateArguments :: Maybe String } deriving (Show, Read, Eq) 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.24.0 +version: 0.0.25.0 synopsis: Haskell Debug Adapter for Visual Studio Code. description: Please see README.md license: BSD3