phoityne-vscode 0.0.24.0 → 0.0.25.0
raw patch · 6 files changed
+190/−77 lines, 6 files
Files
- Changelog.md +5/−0
- README.md +4/−3
- app/Phoityne/GHCi/Command.hs +1/−25
- app/Phoityne/VSCode/Core.hs +178/−47
- app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs +1/−1
- phoityne-vscode.cabal +1/−1
Changelog.md view
@@ -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
README.md view
@@ -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)  (This sample project is available from [here](https://github.com/phoityne/stack-project-template).)
app/Phoityne/GHCi/Command.hs view
@@ -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"
app/Phoityne/VSCode/Core.hs view
@@ -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 ""
app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs view
@@ -26,7 +26,7 @@ etc. -}- , contextEvaluateArguments :: String+ , contextEvaluateArguments :: Maybe String } deriving (Show, Read, Eq)
phoityne-vscode.cabal view
@@ -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