diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,4 +1,10 @@ +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. + * [MODIFY] Supporting Multi-root Workspaces. setBreakpointsRequest. + + 20171112 phoityne-vscode-0.0.18.0 * [FIX] [29](https://github.com/phoityne/phoityne-vscode/issues/29) : Space in filename and reload on save bug. * [MODIFY] [20](https://github.com/phoityne/phoityne-vscode/issues/20) : During stopping on breakpoints selection is one character less. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,14 +7,15 @@ ## Information -* [2017/11/12] phoityne-vscode released. - * Marketplace [phoityne-vscode-0.0.16](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) - * hackage [phoityne-vscode-0.0.18.0](https://hackage.haskell.org/package/phoityne-vscode) +* [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) __Need update from hackage !!.__ * Release Summary - * [FIX] [29](https://github.com/phoityne/phoityne-vscode/issues/29) : Space in filename and reload on save bug. - * [MODIFY] [20](https://github.com/phoityne/phoityne-vscode/issues/20) : During stopping on breakpoints selection is one character less. - + * [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 !!.__ ![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 @@ -27,6 +27,7 @@ , back , forward , bindings + , bindingsDAP , force , info , showType @@ -431,7 +432,20 @@ if 1 == length msgs then return $ Right [] else return $ extractBindingBindingDatas $ unlines $ init $ msgs +-- | +-- +bindingsDAP :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData String) +bindingsDAP ghci outHdl idx = do + let cmd = ":dap-bindings " ++ show idx + dapHead = "<>" + 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 + -- | -- force :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) @@ -700,3 +714,5 @@ -- unlock :: GHCiProcess -> IO () unlock ghci = putMVar (lockGHCiProcess ghci) Lock + + 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 @@ -108,6 +108,7 @@ import qualified Phoityne.VSCode.TH.ThreadsRequestJSON as J import qualified Phoityne.VSCode.TH.ThreadsResponseJSON as J import qualified Phoityne.VSCode.TH.VariableJSON as J +import qualified Phoityne.VSCode.TH.VariablesArgumentsJSON as J import qualified Phoityne.VSCode.TH.VariablesBodyJSON as J import qualified Phoityne.VSCode.TH.VariablesRequestJSON as J import qualified Phoityne.VSCode.TH.VariablesResponseJSON as J @@ -132,7 +133,8 @@ , ghciProcessDebugContextData :: Maybe G.GHCiProcess , responseHandlerDebugContextData :: BSL.ByteString -> IO () , stopOnEntryDebugContextData :: Bool - , hackagePackageVersionDebugContextData :: String + , hackagePackageVersionDebugContextData :: String + , haskellDapEnabledDebugContextData :: Bool } @@ -160,7 +162,14 @@ -- type BreakPointDatas = M.Map BreakPointDataKey BreakPointData + -- | +-- +_HASKELL_DAP_EXE :: String +_HASKELL_DAP_EXE = "haskell-dap" + + +-- | -- -- getBreakPointKey :: BreakPointData -> BreakPointDataKey @@ -202,41 +211,41 @@ "{" , " // atuomatically created by phoityne-vscode" , " " - , " \"version\": \"0.1.0\"," - , " \"isShellCommand\": true," - , " \"showOutput\": \"always\"," - , " \"suppressTaskName\": true," - , " \"windows\": {" - , " \"command\": \"cmd\"," - , " \"args\": [\"/c\"]" - , " }," - , " \"linux\": {" - , " \"command\": \"sh\"," - , " \"args\": [\"-c\"]" - , " }," - , " \"osx\": {" - , " \"command\": \"sh\"," - , " \"args\": [\"-c\"]" + , " \"version\": \"2.0.0\"," + , " \"presentation\": {" + , " \"reveal\": \"always\"," + , " \"panel\": \"new\"" , " }," , " \"tasks\": [" , " {" - , " \"taskName\": \"stack build\"," - , " \"args\": [ \"echo START_STACK_BUILD && cd ${workspaceRoot} && stack build && echo END_STACK_BUILD \" ]" + , " \"group\": {" + , " \"kind\": \"build\"," + , " \"isDefault\": true" + , " }," + , " \"label\": \"stack build\"," + , " \"type\": \"shell\"," + , " \"command\": \"echo START_STACK_BUILD && cd ${workspaceRoot} && stack build && echo END_STACK_BUILD \"" , " }," , " { " - , " \"isBuildCommand\": true," - , " \"taskName\": \"stack clean & build\"," - , " \"args\": [ \"echo START_STACK_CLEAN_AND_BUILD && cd ${workspaceRoot} && stack clean && stack build && echo END_STACK_CLEAN_AND_BUILD \" ]" + , " \"group\": \"build\"," + , " \"type\": \"shell\"," + , " \"label\": \"stack clean & build\"," + , " \"command\": \"echo START_STACK_CLEAN_AND_BUILD && cd ${workspaceRoot} && stack clean && stack build && echo END_STACK_CLEAN_AND_BUILD \"" , " }," , " { " - , " \"isTestCommand\": true," - , " \"taskName\": \"stack test\"," - , " \"args\": [ \"echo START_STACK_TEST && cd ${workspaceRoot} && stack test && echo END_STACK_TEST \" ]" + , " \"group\": {" + , " \"kind\": \"test\"," + , " \"isDefault\": true" + , " }," + , " \"type\": \"shell\"," + , " \"label\": \"stack test\"," + , " \"command\": \"echo START_STACK_TEST && cd ${workspaceRoot} && stack test && echo END_STACK_TEST \"" , " }," , " { " - , " \"isBackground\": true," - , " \"taskName\": \"stack watch\"," - , " \"args\": [ \"echo START_STACK_WATCH && cd ${workspaceRoot} && stack build --test --no-run-tests --file-watch && echo END_STACK_WATCH \" ]" + , " \"isBackground\": true," + , " \"type\": \"shell\"," + , " \"label\": \"stack watch\"," + , " \"command\": \"echo START_STACK_WATCH && cd ${workspaceRoot} && stack build --test --no-run-tests --file-watch && echo END_STACK_WATCH \"" , " }" , " ]" , "}" @@ -272,8 +281,9 @@ _NEW_VERSION_MSG = [ "" , " New hackage module has been released." - , " `stack update` and install new phoityen-vscode." + , " `stack update` and `stack install phoityen-vscode`." , " " + , " " ] @@ -308,6 +318,7 @@ , responseHandlerDebugContextData = BSL.putStr , stopOnEntryDebugContextData = False , hackagePackageVersionDebugContextData = "" + , haskellDapEnabledDebugContextData = False } @@ -485,7 +496,9 @@ Left err -> sendParseErrorAndTerminate err "scopes" handle "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of - Right req -> variablesRequestHandler mvarDat req + Right req -> haskellDapEnabledDebugContextData <$> (readMVar mvarDat) >>= \case + True -> variablesRequestHandlerDAP mvarDat req + False -> variablesRequestHandler mvarDat req Left err -> sendParseErrorAndTerminate err "variables" handle "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of @@ -584,6 +597,7 @@ , startupFuncDebugContextData = maybe "" (\s->if null (U.strip s) then "" else (U.strip s)) (J.startupFuncLaunchRequestArguments args) , startupArgsDebugContextData = maybe "" (id) (J.startupArgsLaunchRequestArguments args) , stopOnEntryDebugContextData = J.stopOnEntryLaunchRequestArguments args + , haskellDapEnabledDebugContextData = L.isInfixOf _HASKELL_DAP_EXE (J.ghciCmdLaunchRequestArguments args) } let logLevelStr = J.logLevelLaunchRequestArguments args @@ -765,7 +779,24 @@ -- | -- setBreakpointsRequestHandler :: MVar DebugContextData -> J.SetBreakpointsRequest -> IO () -setBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do +setBreakpointsRequestHandler mvarCtx req = do + ctx <- readMVar mvarCtx + let cwd = workspaceDebugContextData ctx + args = J.argumentsSetBreakpointsRequest req + source = J.sourceSetBreakpointsRequestArguments args + path = J.pathSource source + + if U.startswith cwd path then setBreakpointsInternal mvarCtx req + else do + let msg = L.intercalate " " ["setBreakpoints request ignored."] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg + + +-- | +-- +setBreakpointsInternal :: MVar DebugContextData -> J.SetBreakpointsRequest -> IO () +setBreakpointsInternal mvarCtx req = flip E.catches handlers $ do logRequest $ show req ctx <- readMVar mvarCtx @@ -1237,14 +1268,104 @@ Right dats -> return $ map convBind2Vals dats - convBind2Vals (G.BindingData varName modName val) = J.Variable varName modName val (Just varName) 0 + convBind2Vals (G.BindingData varName modName val) = + J.Variable { + J.nameVariable = varName + , J.typeVariable = modName + , J.valueVariable = val + , J.evaluateNameVariable = (Just varName) + , J.variablesReferenceVariable = 0 + , J.presentationHintVariable = Nothing + , J.namedVariablesVariable = Nothing + , J.indexedVariablesVariable = Nothing + } outHdl = debugM _LOG_NAME +-- | +-- +-- +variablesRequestHandlerDAP :: MVar DebugContextData -> J.VariablesRequest -> IO () +variablesRequestHandlerDAP mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + vals <- currentBindings + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultVariablesResponse resSeq req + resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["variables request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + 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 [] + + withProcess (Just ghciProc) = do + let args = J.argumentsVariablesRequest req + idx = J.variablesReferenceVariablesArguments args + + G.bindingsDAP ghciProc outHdl idx >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + return [] + + Right dats -> case readMay dats of + Just vals -> do + debugM _LOG_NAME $ "[variablesRequestHandlerDAP] read string: " ++ dats + return vals + Nothing -> do + sendErrorEvent mvarCtx $ "[variablesRequestHandler] can not read valriables. " ++ dats + return [] + + outHdl = debugM _LOG_NAME + + -- | -- +{- +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 @@ -1288,7 +1409,7 @@ evaluateResponse err "" Right typeStr -> case isFunction typeStr of - True -> evaluateResponse "" (getOnlyType typeStr) + True -> evaluateResponse ("function :: " ++ (getOnlyType typeStr)) (getOnlyType typeStr) False -> G.force ghciProc outHdl exp >>= \case Right valStr -> evaluateResponse (getOnlyValue valStr) (getOnlyType typeStr) Left _ -> evaluateResponse "" (getOnlyType typeStr) diff --git a/app/Phoityne/VSCode/TH/VariableJSON.hs b/app/Phoityne/VSCode/TH/VariableJSON.hs --- a/app/Phoityne/VSCode/TH/VariableJSON.hs +++ b/app/Phoityne/VSCode/TH/VariableJSON.hs @@ -7,17 +7,21 @@ import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.VariablePresentationHintJSON -- | -- A Variable is a name/value pair. -- If the value is structured (has children), a handle is provided to retrieve the children with the VariablesRequest. -- data Variable = Variable { - nameVariable :: String -- The variable's name - , typeVariable :: String -- he variable's type. - , valueVariable :: String -- The variable's value. For structured objects this can be a multi line text, e.g. for a function the body of a function. + nameVariable :: String -- The variable's name. + , valueVariable :: String -- The variable's value. This can be a multi-line text, e.g. for a function the body of a function. + , typeVariable :: String -- The type of the variable's value. Typically shown in the UI when hovering over the value. + , presentationHintVariable :: Maybe VariablePresentationHint -- Properties of a variable that can be used to determine how to render the variable in the UI. , evaluateNameVariable :: Maybe String -- Optional evaluatable name of this variable which can be passed to the 'EvaluateRequest' to fetch the variable's value. , variablesReferenceVariable :: Int -- If variablesReference is > 0, the variable is structured and its children can be retrieved by passing variablesReference to the VariablesRequest. + , namedVariablesVariable :: Maybe Int -- The number of named child variables. + , indexedVariablesVariable :: Maybe Int -- The number of indexed child variables. The client can use this optional information to present the children in a paged UI and fetch them in chunks. } deriving (Show, Read, Eq) diff --git a/app/Phoityne/VSCode/TH/VariablePresentationHintJSON.hs b/app/Phoityne/VSCode/TH/VariablePresentationHintJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/VariablePresentationHintJSON.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.VariablePresentationHintJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Optional properties of a variable that can be used to determine how to render the variable in the UI. +-- +data VariablePresentationHint = + VariablePresentationHint { + {- + The kind of variable. Before introducing additional values, try to use the listed values. + Values: + 'property': Indicates that the object is a property. + 'method': Indicates that the object is a method. + 'class': Indicates that the object is a class. + 'data': Indicates that the object is data. + 'event': Indicates that the object is an event. + 'baseClass': Indicates that the object is a base class. + 'innerClass': Indicates that the object is an inner class. + 'interface': Indicates that the object is an interface. + 'mostDerivedClass': Indicates that the object is the most derived class. + 'virtual': Indicates that the object is virtual, that means it is a synthetic object introduced by the adapter for rendering purposes, e.g. an index range for large arrays. + etc. + -} + kindVariablePresentationHint :: String + {- + Set of attributes represented as an array of strings. Before introducing additional values, try to use the listed values. + Values: + 'static': Indicates that the object is static. + 'constant': Indicates that the object is a constant. + 'readOnly': Indicates that the object is read only. + 'rawString': Indicates that the object is a raw string. + 'hasObjectId': Indicates that the object can have an Object ID created for it. + 'canHaveObjectId': Indicates that the object has an Object ID associated with it. + 'hasSideEffects': Indicates that the evaluation had side effects. + etc. + -} + , attributesVariablePresentationHint :: [String] + {- + Visibility of variable. Before introducing additional values, try to use the listed values. + Values: 'public', 'private', 'protected', 'internal', 'final', etc. + -} + , visibilityVariablePresentationHint :: String + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablePresentationHint") } ''VariablePresentationHint) + +-- | +-- +defaultVariablePresentationHint :: VariablePresentationHint +defaultVariablePresentationHint = VariablePresentationHint "data" [] "public" + 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.18.0 +version: 0.0.19.0 synopsis: ghci debug viewer on Visual Studio Code description: Please see README.md license: BSD3 @@ -111,6 +111,7 @@ , Phoityne.VSCode.TH.ThreadsResponseBodyJSON , Phoityne.VSCode.TH.ThreadsResponseJSON , Phoityne.VSCode.TH.VariableJSON + , Phoityne.VSCode.TH.VariablePresentationHintJSON , Phoityne.VSCode.TH.VariablesArgumentsJSON , Phoityne.VSCode.TH.VariablesBodyJSON , Phoityne.VSCode.TH.VariablesRequestJSON