phoityne-vscode 0.0.19.0 → 0.0.20.0
raw patch · 8 files changed
+201/−79 lines, 8 files
Files
- Changelog.md +5/−0
- README.md +15/−9
- app/Phoityne/GHCi/Command.hs +46/−3
- app/Phoityne/VSCode/Core.hs +119/−58
- app/Phoityne/VSCode/TH/EvaluateBodyJSON.hs +7/−2
- app/Phoityne/VSCode/TH/ScopeJSON.hs +5/−3
- app/Phoityne/VSCode/TH/ScopesBodyJSON.hs +1/−1
- phoityne-vscode.cabal +3/−3
Changelog.md view
@@ -1,4 +1,9 @@ +20180101 phoityne-vscode-0.0.20.0+ * [FIX] clearing frame id while handling stack trace request.+ * [MODIFY] change stack trace size from 20 to 50(max).++ 20171216 phoityne-vscode-0.0.19.0 * [ADD] checking hackage package version and inform on console if using lower version. * [MODIFY] Supporting Multi-root Workspaces. version up tasks.json.
README.md view
@@ -2,20 +2,18 @@ # Phoityne VSCode -Phoityne is a ghci debug viewer for Visual Studio Code.+Phoityne is a Haskell GHCi debug adapter for Visual Studio Code. ## Information -* [2017/12/16] phoityne-vscode released. - * Marketplace [phoityne-vscode-0.0.17](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode)- * hackage [phoityne-vscode-0.0.19.0](https://hackage.haskell.org/package/phoityne-vscode) +* [2018/01/01] phoityne-vscode released. + * Marketplace [phoityne-vscode-0.0.18](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode)+ * hackage [phoityne-vscode-0.0.20.0](https://hackage.haskell.org/package/phoityne-vscode) __Need update from hackage !!.__ * Release Summary- * [ADD] checking hackage package version and inform on console if using lower version.- * [MODIFY] Supporting Multi-root Workspaces. version up tasks.json.- * [MODIFY] Supporting Multi-root Workspaces. setBreakpointsRequest. - __Need recreate .vscde/launch.json and tasks.json in the project folder !!.__+ * [FIX] clearing frame id while handling stack trace request.+ * [MODIFY] change stack trace size from 20 to 50(max).  (This sample project is available from [here](https://github.com/phoityne/stack-project-template).)@@ -85,6 +83,14 @@  +### and more++Better inspection. This is an experimental enhancement. +There are limitations and additional installation. +[Here are the details](https://github.com/phoityne/haskell-dap). ++ + ## Capabilites * supportsConfigurationDoneRequest : **yes**@@ -146,7 +152,7 @@ 1. run VSCode and open stack project __Folder__ from file menu. 2. open Extensions from side menu of VSCode. 3. search "haskell" -4. select "[__Haskell GHCi debug viewer Phoityne__](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode)"+4. select "[__Haskell GHCi debug adapter Phoityne__](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode)"
app/Phoityne/GHCi/Command.hs view
@@ -24,12 +24,15 @@ , step , stepLocal , history+ , historyDAP , back , forward , bindings , bindingsDAP , force+ , forceDAP , info+ , scopesDAP , showType , showKind , execBool@@ -395,15 +398,30 @@ -- | ---history :: GHCiProcess -> OutputHandler -> IO (Either ErrorData [StackFrame])-history ghci outHdl = do- let cmd = ":history"+history :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData [StackFrame])+history ghci outHdl size = do+ let cmd = ":history " ++ show size exec ghci outHdl cmd >>= \case Left err -> return $ Left err Right msg -> return $ extractStackFrame msg + -- | --+historyDAP :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData String)+historyDAP ghci outHdl _ = do+ let cmd = ":dap-history"+ dapHead = "<<DAP>>"+ exec ghci outHdl cmd >>= \case+ Left err -> return $ Left err+ Right msg -> do+ let msgs = filter (L.isPrefixOf dapHead) $ lines msg+ if 1 == length msgs then return $ Right $ drop (length dapHead) $ head msgs+ else return $ Left $ "[dap] error. header " ++ dapHead ++ "not found. " ++ msg +++-- |+-- back :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData SourcePosition) back ghci outHdl _ = do -- let cmd = ":back " ++ show val@@ -445,6 +463,18 @@ if 1 == length msgs then return $ Right $ drop (length dapHead) $ head msgs else return $ Left $ "[dap] error. header " ++ dapHead ++ "not found. " ++ msg +-- |+--+scopesDAP :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData String)+scopesDAP ghci outHdl idx = do+ let cmd = ":dap-scopes " ++ show idx+ dapHead = "<<DAP>>"+ exec ghci outHdl cmd >>= \case+ Left err -> return $ Left err+ Right msg -> do+ let msgs = filter (L.isPrefixOf dapHead) $ lines msg+ if 1 == length msgs then return $ Right $ drop (length dapHead) $ head msgs+ else return $ Left $ "[dap] error. header " ++ dapHead ++ "not found. " ++ msg -- | --@@ -454,6 +484,19 @@ exec ghci outHdl cmd >>= \case 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+ dapHead = "<<DAP>>"+ exec ghci outHdl cmd >>= \case+ Left err -> return $ Left err+ Right msg -> do+ let msgs = filter (L.isPrefixOf dapHead) $ lines msg+ if 1 == length msgs then return $ Right $ drop (length dapHead) $ head msgs+ else return $ Left $ "[dap] error. header " ++ dapHead ++ "not found. " ++ msg -- | --
app/Phoityne/VSCode/Core.hs view
@@ -75,6 +75,7 @@ import qualified Phoityne.VSCode.TH.PauseResponseJSON as J import qualified Phoityne.VSCode.TH.RequestJSON as J import qualified Phoityne.VSCode.TH.ScopesArgumentsJSON as J+import qualified Phoityne.VSCode.TH.ScopesBodyJSON as J import qualified Phoityne.VSCode.TH.ScopesRequestJSON as J import qualified Phoityne.VSCode.TH.ScopesResponseJSON as J import qualified Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON as J@@ -168,7 +169,12 @@ _HASKELL_DAP_EXE :: String _HASKELL_DAP_EXE = "haskell-dap" +-- |+--+_GHCi_HISTORY_SIZE :: Int+_GHCi_HISTORY_SIZE = 50 + -- | -- -- @@ -492,7 +498,9 @@ Left err -> sendParseErrorAndTerminate err "stackTrace" handle "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of- Right req -> scopesRequestHandler mvarDat req+ Right req -> haskellDapEnabledDebugContextData <$> (readMVar mvarDat) >>= \case+ True -> scopesRequestHandlerDAP mvarDat req+ False -> scopesRequestHandler mvarDat req Left err -> sendParseErrorAndTerminate err "scopes" handle "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of@@ -1181,16 +1189,26 @@ sendErrorEvent mvarCtx "[stackTraceRequestHandler] ghci not started." defaultFrame pos - withProcess pos (Just ghciProc) = G.history ghciProc outHdl >>= \case- Left err -> do- sendErrorEvent mvarCtx $ show err- defaultFrame pos+ withProcess pos (Just ghciProc) = do+ + isDAP <- haskellDapEnabledDebugContextData <$> (readMVar mvarCtx)+ when isDAP $ do+ _ <- G.historyDAP ghciProc outHdlDAP _GHCi_HISTORY_SIZE+ return () - Right dats -> do- cwd <- workspaceDebugContextData <$> readMVar mvarCtx- cfs <- defaultFrame pos- foldM (convTrace2Frame cwd) cfs dats+ ctx <- takeMVar mvarCtx+ putMVar mvarCtx ctx{currentFrameIdDebugContextData = 0} + G.history ghciProc outHdl _GHCi_HISTORY_SIZE >>= \case+ Left err -> do+ sendErrorEvent mvarCtx $ show err+ defaultFrame pos++ Right dats -> do+ cwd <- workspaceDebugContextData <$> readMVar mvarCtx+ cfs <- defaultFrame pos+ foldM (convTrace2Frame cwd) cfs dats+ convTrace2Frame cwd xs (G.StackFrame traceId funcName (G.SourcePosition file sl sc el ec)) = do ctx <- readMVar mvarCtx let startup = startupDebugContextData ctx@@ -1208,6 +1226,7 @@ outHdl = debugM _LOG_NAME + outHdlDAP = sendStdoutEvent mvarCtx -- | --@@ -1233,9 +1252,57 @@ sendResponse mvarCtx $ J.encode $ J.errorScopesResponse resSeq req msg sendErrorEvent mvarCtx msg + -- | -- --+scopesRequestHandlerDAP :: MVar DebugContextData -> J.ScopesRequest -> IO ()+scopesRequestHandlerDAP mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req++ body <- ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess++ resSeq <- getIncreasedResponseSequence mvarCtx+ let res = J.defaultScopesResponse resSeq req+ resStr = J.encode res{J.bodyScopesResponse = body}+ sendResponse mvarCtx resStr++ where+ handlers = [ E.Handler someExcept ]+ someExcept (e :: E.SomeException) = do+ let msg = L.intercalate " " ["scopes request error.", show req, show e]+ resSeq <- getIncreasedResponseSequence mvarCtx+ sendResponse mvarCtx $ J.encode $ J.errorScopesResponse resSeq req msg + sendErrorEvent mvarCtx msg++ withProcess Nothing = do+ sendErrorEvent mvarCtx "[scopesRequestHandlerDAP] ghci not started."+ return J.ScopesBody {J.scopesScopesBody = []}++ withProcess (Just ghciProc) = do+ let args = J.argumentsScopesRequest req+ traceId = J.frameIdScopesArguments args+ + G.scopesDAP ghciProc outHdl traceId >>= \case+ Left err -> do+ sendErrorEvent mvarCtx $ show err+ return J.ScopesBody {J.scopesScopesBody = []}++ Right dats -> case readMay dats of+ Just body -> do+ debugM _LOG_NAME $ "[scopesRequestHandlerDAP] read string: " ++ dats+ return body+ Nothing -> do+ sendErrorEvent mvarCtx $ "[scopesRequestHandlerDAP] can not read valriables. " ++ dats+ return J.ScopesBody {J.scopesScopesBody = []}++ -- outHdl = debugM _LOG_NAME++ outHdl = sendStdoutEvent mvarCtx++-- |+--+-- variablesRequestHandler :: MVar DebugContextData -> J.VariablesRequest -> IO () variablesRequestHandler mvarCtx req = flip E.catches handlers $ do logRequest $ show req@@ -1289,11 +1356,11 @@ variablesRequestHandlerDAP mvarCtx req = flip E.catches handlers $ do logRequest $ show req - vals <- currentBindings+ body <- ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess resSeq <- getIncreasedResponseSequence mvarCtx let res = J.defaultVariablesResponse resSeq req- resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals}+ resStr = J.encode $ res{J.bodyVariablesResponse = body} sendResponse mvarCtx resStr where@@ -1304,11 +1371,9 @@ sendResponse mvarCtx $ J.encode $ J.errorVariablesResponse resSeq req msg sendErrorEvent mvarCtx msg - currentBindings = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess- withProcess Nothing = do sendErrorEvent mvarCtx "[variablesRequestHandler] ghci not started."- return []+ return J.defaultVariablesBody withProcess (Just ghciProc) = do let args = J.argumentsVariablesRequest req@@ -1317,7 +1382,7 @@ G.bindingsDAP ghciProc outHdl idx >>= \case Left err -> do sendErrorEvent mvarCtx $ show err- return []+ return J.defaultVariablesBody Right dats -> case readMay dats of Just vals -> do@@ -1325,47 +1390,15 @@ return vals Nothing -> do sendErrorEvent mvarCtx $ "[variablesRequestHandler] can not read valriables. " ++ dats- return []+ return J.defaultVariablesBody - outHdl = debugM _LOG_NAME+ -- outHdl = debugM _LOG_NAME+ outHdl = sendStdoutEvent mvarCtx -- | ---{--variablesRequestHandlerDAP :: MVar DebugContextData -> BSL.ByteString -> IO ()-variablesRequestHandlerDAP mvarCtx jsonStr = flip E.catches handlers $ do- logRequest $ show jsonStr-- resStr <- currentBindings- -- {"seq":36,"type":"response","request_seq":11,"success":true,"command":"variables","message":"","body":{"variables":[{"name":"foo","type":"Foo","value":"_","evaluateName":"foo","variablesReference":0},{"name":"_result","type":"IO ()","value":"_","evaluateName":"_result","variablesReference":0}]}}- sendResponse mvarCtx resStr-- where- handlers = [ E.Handler someExcept ]- someExcept (e :: E.SomeException) = do- let msg = L.intercalate " " ["[variablesRequestHandlerDAP] variables request error.", show e]- sendErrorEvent mvarCtx msg-- currentBindings = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess-- withProcess Nothing = do- sendErrorEvent mvarCtx "[variablesRequestHandlerDAP] ghci not started."- return $ "[variablesRequestHandlerDAP] CRITICAL."-- withProcess (Just ghciProc) = G.dap ghciProc outHdl (lbs2str jsonStr) >>= \case- Left err -> do- sendErrorEvent mvarCtx $ show err- return $ "[variablesRequestHandlerDAP] CRITICAL."-- Right dats -> return (str2lbs dats)-- outHdl = debugM _LOG_NAME--}---- | ----- threadsRequestHandler :: MVar DebugContextData -> J.ThreadsRequest -> IO () threadsRequestHandler mvarCtx req = flip E.catches handlers $ do logRequest $ show req@@ -1390,8 +1423,9 @@ evaluateRequestHandler mvarCtx req = flip E.catches handlers $ do logRequest $ show req + isDap <- haskellDapEnabledDebugContextData <$> (readMVar mvarCtx) let (J.EvaluateArguments exp _ ctx) = J.argumentsEvaluateRequest req- ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess ctx exp+ ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess ctx isDap exp where handlers = [ E.Handler someExcept ]@@ -1401,9 +1435,9 @@ sendResponse mvarCtx $ J.encode $ J.errorEvaluateResponse resSeq req msg sendErrorEvent mvarCtx msg - withProcess _ _ Nothing = sendErrorEvent mvarCtx "[evaluateRequestHandler] ghci not started."+ withProcess _ _ _ Nothing = sendErrorEvent mvarCtx "[evaluateRequestHandler] ghci not started." - withProcess "watch" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case+ withProcess "watch" False exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case Left err -> do errorM _LOG_NAME $ show err evaluateResponse err ""@@ -1414,13 +1448,33 @@ Right valStr -> evaluateResponse (getOnlyValue valStr) (getOnlyType typeStr) Left _ -> evaluateResponse "" (getOnlyType typeStr) - withProcess "hover" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case+ + withProcess "watch" True exp (Just ghciProc) = G.forceDAP ghciProc outHdlDAP exp >>= \case+ Right dats -> case readMay dats of+ Just body -> do+ debugM _LOG_NAME $ "[evaluateRequestHandler] read string: " ++ dats+ resSeq <- getIncreasedResponseSequence mvarCtx+ let res = J.defaultEvaluateResponse resSeq req+ resStr = J.encode res{J.bodyEvaluateResponse = body}+ sendResponse mvarCtx resStr+ Nothing -> do+ sendErrorEvent mvarCtx $ "[evaluateRequestHandler] can not read valriables. " ++ dats+ resSeq <- getIncreasedResponseSequence mvarCtx+ let res = J.errorEvaluateResponse resSeq req $ "eval faild."+ sendResponse mvarCtx (J.encode res)++ Left e -> do+ resSeq <- getIncreasedResponseSequence mvarCtx+ let res = J.errorEvaluateResponse resSeq req (show e)+ sendResponse mvarCtx (J.encode res)++ withProcess "hover" _ exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case Left err -> do errorM _LOG_NAME $ show err evaluateResponse err "" Right typeStr -> evaluateResponse typeStr (getOnlyType typeStr) - withProcess _ exp (Just ghciProc) + withProcess _ _ exp (Just ghciProc) | null (U.strip exp) = do evaluateResponse "" "" sendStdoutEvent mvarCtx (G.promptGHCiProcess ghciProc)@@ -1472,6 +1526,7 @@ isPermitCmd c = 0 == (length ( filter (flip U.startswith c) _NOT_PERMIT_REPL_COMMANDS)) outHdl = debugM _LOG_NAME+ outHdlDAP = sendStdoutEvent mvarCtx isFunction str = case parse isFunctionParser "isFunction" str of Right _ -> True@@ -1481,7 +1536,7 @@ evaluateResponse msg typeStr = do resSeq <- getIncreasedResponseSequence mvarCtx- let body = J.EvaluateBody msg typeStr 0+ let body = J.defaultEvaluateBody{J.resultEvaluateBody = msg, J.typeEvaluateBody = typeStr} res = J.defaultEvaluateResponse resSeq req resStr = J.encode res{J.bodyEvaluateResponse = body} sendResponse mvarCtx resStr@@ -1799,7 +1854,13 @@ sendErrorEvent mvarCtx $ "[breakByException] can't get exception message. " ++ err sendTerminateEvent mvarCtx - withExceptionMsg ghciProc (Right msg) = G.history ghciProc outHdl >>= \case+ withExceptionMsg ghciProc (Right msg) = do+ isDAP <- haskellDapEnabledDebugContextData <$> (readMVar mvarCtx)+ when isDAP $ do+ _ <- G.historyDAP ghciProc outHdlDAP _GHCi_HISTORY_SIZE+ return ()+ + G.history ghciProc outHdl _GHCi_HISTORY_SIZE >>= \case Left err -> do sendErrorEvent mvarCtx $ show err sendTerminateEvent mvarCtx@@ -1820,7 +1881,7 @@ -- | -- outHdl = debugM _LOG_NAME- -- outHdl = sendStdoutEvent mvarCtx+ outHdlDAP = sendStdoutEvent mvarCtx -- |
app/Phoityne/VSCode/TH/EvaluateBodyJSON.hs view
@@ -5,6 +5,8 @@ import Data.Aeson.TH +import Phoityne.VSCode.TH.VariablePresentationHintJSON+ import Phoityne.VSCode.Utility -- |@@ -14,7 +16,10 @@ EvaluateBody { resultEvaluateBody :: String -- The result of the evaluate. , typeEvaluateBody :: String -- The optional type of the evaluate result. - , variablesReferenceEvaluateBody :: Int -- If variablesReference is > 0, the evaluate result is structured and its children can be retrieved by passing variablesReference to the VariablesRequest+ , presentationHintEvaluateBody :: Maybe VariablePresentationHint -- Properties of a evaluate result that can be used to determine how to render the result in the UI.+ , variablesReferenceEvaluateBody :: Int -- If variablesReference is > 0, the evaluate result is structured and its children can be retrieved by passing variablesReference to the VariablesRequest.+ , namedVariablesEvaluateBody :: Maybe Int -- The number of named child variables. The client can use this optional information to present the variables in a paged UI and fetch them in chunks.+ , indexedVariablesEvaluateBody :: Maybe Int -- The number of indexed child variables. The client can use this optional information to present the variables in a paged UI and fetch them in chunks. } deriving (Show, Read, Eq) @@ -23,7 +28,7 @@ -- | -- defaultEvaluateBody :: EvaluateBody-defaultEvaluateBody = EvaluateBody "" "" 0+defaultEvaluateBody = EvaluateBody "" "" Nothing 0 Nothing Nothing
app/Phoityne/VSCode/TH/ScopeJSON.hs view
@@ -12,9 +12,11 @@ -- data Scope = Scope {- nameScope :: String -- name of the scope (as such 'Arguments', 'Locals')- , variablesReferenceScope :: Int -- The variables of this scope can be retrieved by passing the value of variablesReference to the VariablesRequest. - , expensiveScope :: Bool -- If true, the number of variables in this scope is large or expensive to retrieve. + nameScope :: String -- Name of the scope such as 'Arguments', 'Locals'. + , variablesReferenceScope :: Int -- The variables of this scope can be retrieved by passing the value of variablesReference to the VariablesRequest.+ , namedVariablesScope :: Maybe Int -- The number of named variables in this scope. The client can use this optional information to present the variables in a paged UI and fetch them in chunks.+ , indexedVariablesScope :: Maybe Int -- The number of indexed variables in this scope. The client can use this optional information to present the variables in a paged UI and fetch them in chunks.+ , expensiveScope :: Bool -- If true, the number of variables in this scope is large or expensive to retrieve. } deriving (Show, Read, Eq)
app/Phoityne/VSCode/TH/ScopesBodyJSON.hs view
@@ -20,5 +20,5 @@ $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesBody") } ''ScopesBody) defaultScopesBody :: ScopesBody-defaultScopesBody = ScopesBody [Scope "GHCi scope" 1 False]+defaultScopesBody = ScopesBody [Scope "GHCi scope" 1 Nothing Nothing False]
phoityne-vscode.cabal view
@@ -1,6 +1,6 @@ name: phoityne-vscode-version: 0.0.19.0-synopsis: ghci debug viewer on Visual Studio Code+version: 0.0.20.0+synopsis: Haskell Debug Adapter for Visual Studio Code. description: Please see README.md license: BSD3 license-file: LICENSE@@ -8,7 +8,7 @@ maintainer: phoityne.hs@gmail.com homepage: https://github.com/phoityne/phoityne-vscode bug-reports: https://github.com/phoityne/phoityne-vscode/issues-copyright: 2016-2017 phoityne_hs+copyright: 2016-2018 phoityne_hs category: Development build-type: Simple cabal-version: >=1.10