diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,6 @@ +20180211 phoityne-vscode-0.0.21.0 + * [MODIFY] [34](https://github.com/phoityne/phoityne-vscode/issues/34) : can not set breakpoint on vscode-1.20.0 + 20180101 phoityne-vscode-0.0.20.0 * [FIX] clearing frame id while handling stack trace request. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,14 +6,12 @@ ## Information - -* [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) +* [2018/02/11] phoityne-vscode released. + * Marketplace [phoityne-vscode-0.0.19](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) + * hackage [phoityne-vscode-0.0.21.0](https://hackage.haskell.org/package/phoityne-vscode) __Need update from hackage !!.__ * Release Summary - * [FIX] clearing frame id while handling stack trace request. - * [MODIFY] change stack trace size from 20 to 50(max). + * [MODIFY] [34](https://github.com/phoityne/phoityne-vscode/issues/34) : can not set breakpoint on vscode-1.20.0 ![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/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -3,14 +3,13 @@ module Main where -import qualified Phoityne.VSCode.Main as M +import Phoityne.VSCode.Control import System.Exit -- | -- main :: IO () -main = do - M.run >>= \case - 0 -> exitSuccess - c -> exitWith . ExitFailure $ c +main = run >>= \case + 0 -> exitSuccess + c -> exitWith . ExitFailure $ c 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 @@ -16,6 +16,7 @@ , loadFile , loadModule , setBreak + , setBreakDAP , setFuncBreak , delete , traceMain @@ -38,6 +39,7 @@ , execBool , exec , complete + , dapCommand ) where import Control.Concurrent @@ -57,6 +59,10 @@ _HS_FILE_EXT :: String _HS_FILE_EXT = ".hs" +-- | +-- +_DAP_HEADER :: String +_DAP_HEADER = "<>" -- | -- @@ -305,8 +311,53 @@ pos <- parsePosition return (read no, pos) + -- | -- +setBreakDAP :: GHCiProcess + -> OutputHandler + -> FilePath + -> LineNo + -> ColNo + -> IO (Either ErrorData String) +setBreakDAP ghci outHdl path lineNo col = do + let cmd = ":dap-break " ++ path ++ " " ++ show lineNo ++ (if (-1) == col then "" else " " ++ show col) + + 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 + +-- | +-- +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 + + +-- | +-- setFuncBreak :: GHCiProcess -> OutputHandler -> String @@ -411,13 +462,13 @@ historyDAP :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData String) historyDAP ghci outHdl _ = do let cmd = ":dap-history" - 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 + 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 -- | @@ -455,26 +506,26 @@ 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 + 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 -- | -- scopesDAP :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData String) scopesDAP ghci outHdl idx = do let cmd = ":dap-scopes " ++ 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 + 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 -- | -- @@ -490,13 +541,13 @@ forceDAP :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) forceDAP ghci outHdl target = do let cmd = ":dap-force " ++ target - 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 + 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 -- | -- @@ -631,6 +682,7 @@ -- | -- to lowercase Windows drive letter + -- drive2lower :: FilePath -> FilePath drive2lower (x : ':' : xs) = toLower x : ':' : xs drive2lower xs = xs diff --git a/app/Phoityne/GHCi/Process.hs b/app/Phoityne/GHCi/Process.hs --- a/app/Phoityne/GHCi/Process.hs +++ b/app/Phoityne/GHCi/Process.hs @@ -27,7 +27,7 @@ import qualified System.IO as S import qualified System.Exit as S import qualified System.Environment as S -import qualified Control.Exception as E +import qualified Control.Exception.Safe as E import qualified Data.String.Utils as U import qualified Data.Map as M import qualified Data.Version as V diff --git a/app/Phoityne/VSCode/Argument.hs b/app/Phoityne/VSCode/Argument.hs --- a/app/Phoityne/VSCode/Argument.hs +++ b/app/Phoityne/VSCode/Argument.hs @@ -2,31 +2,32 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-cse #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} module Phoityne.VSCode.Argument ( HelpExitException(..) , ArgData(..) -, config +, getArgData ) where import Paths_phoityne_vscode (version) +import Phoityne.VSCode.Type import System.Console.CmdArgs -import qualified Control.Exception as E +import qualified Control.Exception.Safe as E +import qualified System.Console.CmdArgs as CMD import Data.Version -- | --- -data HelpExitException = HelpExitException - deriving (Show, Typeable) - -instance E.Exception HelpExitException - --- | --- -data ArgData = ModeA { - hackageVersion :: String - } deriving (Data, Typeable, Show, Read, Eq) +-- +getArgData :: IO ArgData +getArgData = E.catches (CMD.cmdArgs config) handlers + where + handlers = [E.Handler someExcept] + someExcept (e :: E.SomeException) = if + | "ExitSuccess" == show e -> E.throw HelpExitException + | otherwise -> E.throwIO e -- | @@ -37,8 +38,8 @@ &= program "phoityne-vscode" where - confA = ModeA { - hackageVersion = showVersion version + confA = ArgData { + _hackageVersionArgData = showVersion version &= name "hackage-version" &= typ "VERSION" &= explicit @@ -53,8 +54,7 @@ mdAMsg = [ "" - , "Phoityne is a ghci debug viewer for Visual Studio Code. " + , "Phoityne is a ghci debug adapter for Visual Studio Code. " , "" ] - diff --git a/app/Phoityne/VSCode/Constant.hs b/app/Phoityne/VSCode/Constant.hs --- a/app/Phoityne/VSCode/Constant.hs +++ b/app/Phoityne/VSCode/Constant.hs @@ -16,6 +16,16 @@ _INI_SEC_PHOITYNE :: String _INI_SEC_PHOITYNE = "PHOITYNE" +-- | +-- +_INI_SEC_DEF :: String +_INI_SEC_DEF = "DEFAULT" + +-- | +-- +_INI_DEF_WORK_DIR :: String +_INI_DEF_WORK_DIR = "work_dir" + -- | -- diff --git a/app/Phoityne/VSCode/Control.hs b/app/Phoityne/VSCode/Control.hs --- a/app/Phoityne/VSCode/Control.hs +++ b/app/Phoityne/VSCode/Control.hs @@ -6,37 +6,68 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} -module Phoityne.VSCode.Control where +module Phoityne.VSCode.Control ( + run +) where import System.IO import Control.Concurrent import Text.Parsec -import qualified Data.ConfigFile as C +import Control.Lens import qualified System.Log.Logger as L import Phoityne.VSCode.Constant import Phoityne.VSCode.Utility +import Phoityne.VSCode.Type import qualified Phoityne.VSCode.Argument as A -import qualified Phoityne.VSCode.Core as GUI +import qualified Phoityne.VSCode.Core as C import qualified Data.ByteString.Lazy as BSL +import System.Exit +import qualified Control.Exception.Safe as E -- | -- -run :: A.ArgData - -> C.ConfigParser - -> IO Int -run args _ = do +_CONTENT_LENGTH :: String +_CONTENT_LENGTH = "Content-Length: " + +-- | +-- +run :: IO Int +run = flip E.catches handlers $ + E.finally go finalize + + where + handlers = [ E.Handler helpExcept + , E.Handler exitExcept + , E.Handler ioExcept + , E.Handler someExcept + ] + finalize = L.removeAllHandlers + helpExcept (_ :: A.HelpExitException) = return 0 + exitExcept ExitSuccess = return 0 + exitExcept (ExitFailure c) = return c + ioExcept (e :: E.IOException) = print e >> return 1 + someExcept (e :: E.SomeException) = print e >> return 1 + + +-- | +-- +go :: IO Int +go = do + + args <- A.getArgData + hSetBuffering stdin NoBuffering hSetEncoding stdin utf8 hSetBuffering stdout NoBuffering hSetEncoding stdout utf8 - mvarDat <- newMVar GUI.defaultDebugContextData { - GUI.responseHandlerDebugContextData = sendResponse - , GUI.hackagePackageVersionDebugContextData = A.hackageVersion args + mvarDat <- newMVar C.defaultDebugContextData { + C.responseHandlerDebugContextData = sendResponse + , C.hackagePackageVersionDebugContextData = args ^. hackageVersionArgData } wait mvarDat @@ -47,32 +78,32 @@ -- | -- -- -wait :: MVar GUI.DebugContextData -> IO () -wait mvarDat = go BSL.empty +wait :: MVar C.DebugContextData -> IO () +wait mvarDat = readStdin BSL.empty where - go buf = BSL.hGet stdin 1 >>= withC buf + readStdin buf = BSL.hGet stdin 1 >>= withC buf withC buf c | c == BSL.empty = unexpectedEOF | otherwise = withBuf $ BSL.append buf c - withBuf buf = case parse parser "readContentLength" (lbs2str buf) of - Left _ -> go buf + withBuf buf = case parse parser "readContentLengthParser" (lbs2str buf) of + Left _ -> readStdin buf Right len -> BSL.hGet stdin len >>= withCnt buf withCnt buf cnt | cnt == BSL.empty = unexpectedEOF | otherwise = do - GUI.handleRequest mvarDat buf cnt + C.handleRequest mvarDat buf cnt wait mvarDat parser = do - string "Content-Length: " + string _CONTENT_LENGTH len <- manyTill digit (string _TWO_CRLF) return . read $ len unexpectedEOF = do - L.criticalM _LOG_NAME "unexpected EOF on stdin." + L.criticalM _LOG_NAME "unexpected EOF from stdin." return () @@ -81,7 +112,7 @@ -- sendResponse :: BSL.ByteString -> IO () sendResponse str = do - BSL.hPut stdout $ BSL.append "Content-Length: " $ str2lbs $ show (BSL.length str) + BSL.hPut stdout $ str2lbs $ _CONTENT_LENGTH ++ (show (BSL.length str)) BSL.hPut stdout $ str2lbs _TWO_CRLF BSL.hPut stdout str hFlush stdout 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 @@ -28,9 +28,10 @@ import System.Directory import System.Log.Logger import Text.Parsec -import qualified Control.Exception as E +import qualified Control.Exception.Safe as E import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString as BS import qualified Data.String.Utils as U import qualified Data.List as L import qualified Data.Map as M @@ -40,10 +41,15 @@ import qualified System.Log.Handler as LH import qualified System.Log.Handler.Simple as LHS import qualified Data.Version as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Text.Read as R +import Data.Word import Phoityne.VSCode.Constant import Phoityne.VSCode.Utility import qualified Phoityne.VSCode.TH.BreakpointJSON as J +-- import qualified Phoityne.VSCode.TH.ColumnDescriptorJSON as J import qualified Phoityne.VSCode.TH.CompletionsItemJSON as J import qualified Phoityne.VSCode.TH.CompletionsArgumentsJSON as J import qualified Phoityne.VSCode.TH.CompletionsResponseBodyJSON as J @@ -62,11 +68,15 @@ import qualified Phoityne.VSCode.TH.ExceptionBreakpointsFilterJSON as J import qualified Phoityne.VSCode.TH.InitializedEventJSON as J import qualified Phoityne.VSCode.TH.InitializeRequestJSON as J -import qualified Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON as J +import qualified Phoityne.VSCode.TH.InitializeResponseCapabilitiesJSON as J import qualified Phoityne.VSCode.TH.InitializeResponseJSON as J import qualified Phoityne.VSCode.TH.LaunchRequestArgumentsJSON as J import qualified Phoityne.VSCode.TH.LaunchRequestJSON as J import qualified Phoityne.VSCode.TH.LaunchResponseJSON as J +-- import qualified Phoityne.VSCode.TH.ModulesArgumentsJSON as J +-- import qualified Phoityne.VSCode.TH.ModulesRequestJSON as J +-- import qualified Phoityne.VSCode.TH.ModulesResponseBodyJSON as J +-- import qualified Phoityne.VSCode.TH.ModulesResponseJSON import qualified Phoityne.VSCode.TH.NextRequestJSON as J import qualified Phoityne.VSCode.TH.NextResponseJSON as J import qualified Phoityne.VSCode.TH.OutputEventJSON as J @@ -78,7 +88,7 @@ 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 +import qualified Phoityne.VSCode.TH.SetBreakpointsArgumentsJSON as J import qualified Phoityne.VSCode.TH.SetBreakpointsRequestJSON as J import qualified Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON as J import qualified Phoityne.VSCode.TH.SetBreakpointsResponseJSON as J @@ -423,16 +433,179 @@ sendEvent mvarCtx terminatedEvtStr + -- |===================================================================== +-- DAP Utility +-- + +-- | +-- +readDAP :: Read a => String -> Either String a +readDAP argsStr = case R.readEither argsStr :: Either String [Word8] of + Left err -> Left $ "read [Word8] failed. " ++ err ++ " : " ++ argsStr + Right bs -> case R.readEither (toStr bs) of + Left err -> Left $ "read toStr] failed. " ++ err ++ " : " ++ (toStr bs) + Right a -> Right a + where + toStr = T.unpack . T.decodeUtf8 . BS.pack + +-- | +-- +showDAP :: Show a => a -> String +showDAP = show . BS.unpack . T.encodeUtf8 . T.pack . show + + +-- |===================================================================== +-- DAP Handlers +-- + +type DAPRequestHandler = MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> IO () + +-- | +-- +_SUPPORTED_DAP :: M.Map String DAPRequestHandler +_SUPPORTED_DAP = M.fromList [ + ("setBreakpoints-dummy", setBreakpointsRequestHandlerDAP) + ] + + +-- | +-- +-- +handleRequestDAP :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> IO () +handleRequestDAP mvarDat contLenStr jsonStr = case J.eitherDecode jsonStr :: Either String J.Request of + Right (J.Request cmd) -> case M.lookup cmd _SUPPORTED_DAP of + Just hdl -> hdl mvarDat contLenStr jsonStr + Nothing -> sendCmdNotFoundErrorAndTerminate cmd + Left err -> sendParseErrorAndTerminate mvarDat contLenStr jsonStr err + + where + sendCmdNotFoundErrorAndTerminate cmd = do + let msg = L.intercalate "\n" + $ [ "[CRITICAL]"++"<"++cmd++">"++" request command not found." + , lbs2str contLenStr + , lbs2str jsonStr + , "" + ] ++ _ERR_MSG_URL ++ ["", ""] + sendErrorEvent mvarDat msg + sendTerminateEvent mvarDat + + +-- | +-- +sendParseErrorAndTerminate :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> String -> IO () +sendParseErrorAndTerminate mvarDat contLenStr jsonStr err = do + let msg = L.intercalate "\n" + $ [ "[CRITICAL]" ++ "request parce error." + , lbs2str contLenStr + , lbs2str jsonStr + , err, "" + ] ++ _ERR_MSG_URL ++ ["", ""] + sendErrorEvent mvarDat msg + sendTerminateEvent mvarDat + + +-- | +-- +sendGHCiProcErrorAndTerminate :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> String -> IO () +sendGHCiProcErrorAndTerminate mvarDat contLenStr jsonStr err = do + let msg = L.intercalate "\n" + $ [ "[CRITICAL]" ++ "ghci process has not started." + , lbs2str contLenStr + , lbs2str jsonStr + , err, "" + ] + sendErrorEvent mvarDat msg + sendTerminateEvent mvarDat + + +-- | +-- +sendDAPCmdErrorAndTerminate :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> String -> IO () +sendDAPCmdErrorAndTerminate mvarDat contLenStr jsonStr err = do + let msg = L.intercalate "\n" + $ [ "[CRITICAL]" ++ "dap command execution failed." + , lbs2str contLenStr + , lbs2str jsonStr + , err, "" + ] + sendErrorEvent mvarDat msg + sendTerminateEvent mvarDat + + +-- | +-- +sendDAPUnserializeErrorAndTerminate :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> String -> IO () +sendDAPUnserializeErrorAndTerminate mvarDat contLenStr jsonStr err = do + let msg = L.intercalate "\n" + $ [ "[CRITICAL]" ++ "dap command result unserialization failed." + , lbs2str contLenStr + , lbs2str jsonStr + , err, "" + ] + sendErrorEvent mvarDat msg + sendTerminateEvent mvarDat + + +-- | +-- +sendDAPResultErrorAndTerminate :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> String -> IO () +sendDAPResultErrorAndTerminate mvarDat contLenStr jsonStr err = do + let msg = L.intercalate "\n" + $ [ "[CRITICAL]" ++ "dap command result error." + , lbs2str contLenStr + , lbs2str jsonStr + , err, "" + ] + sendErrorEvent mvarDat msg + sendTerminateEvent mvarDat + + +-- | +-- +setBreakpointsRequestHandlerDAP :: DAPRequestHandler +setBreakpointsRequestHandlerDAP mvarCtx contLenStr jsonStr = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of + Left err -> sendParseErrorAndTerminate mvarCtx contLenStr jsonStr err + Right req -> do + logRequest $ show req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess req + + where + withProcess req Nothing = sendGHCiProcErrorAndTerminate mvarCtx contLenStr jsonStr (show req) + withProcess req (Just proc) = do + let cmd = ":dap-set-breakpoints" + args = showDAP $ J.argumentsSetBreakpointsRequest req + + G.dapCommand proc outHdl cmd args >>= withResult req + + withResult req (Left err) = sendDAPCmdErrorAndTerminate mvarCtx contLenStr jsonStr (show req ++ err) + withResult req (Right strDat) = withBody req $ readDAP strDat + + withBody :: J.SetBreakpointsRequest -> Either String (Either String J.SetBreakpointsResponseBody) -> IO () + withBody req (Left err) = sendDAPUnserializeErrorAndTerminate mvarCtx contLenStr jsonStr (show req ++ err) + withBody req (Right (Left err)) = sendDAPResultErrorAndTerminate mvarCtx contLenStr jsonStr (show req ++ err) + withBody req (Right (Right body)) = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultSetBreakpointsResponse resSeq req + resStr = J.encode res{J.bodySetBreakpointsResponse = body} + sendResponse mvarCtx resStr + + outHdl = sendStdoutEvent mvarCtx + + +-- |===================================================================== -- Handlers +-- -- | -- -- handleRequest :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> IO () handleRequest mvarDat contLenStr jsonStr = do + isDAP <- haskellDapEnabledDebugContextData <$> (readMVar mvarDat) case J.eitherDecode jsonStr :: Either String J.Request of - Right (J.Request cmd) -> handle cmd + Right (J.Request cmd) ->if isDAP && M.member cmd _SUPPORTED_DAP then handleRequestDAP mvarDat contLenStr jsonStr + else handle cmd Left err -> sendParseErrorAndTerminate err "request" where @@ -446,6 +619,7 @@ sendErrorEvent mvarDat msg sendTerminateEvent mvarDat + handle "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of Right req -> initializeRequestHandler mvarDat req Left err -> do @@ -563,22 +737,24 @@ initializeRequestHandler :: MVar DebugContextData -> J.InitializeRequest -> IO () initializeRequestHandler mvarCtx req@(J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do resSeq <- getIncreasedResponseSequence mvarCtx - let capa = J.InitializeResponseCapabilites { - J.supportsConfigurationDoneRequestInitializeResponseCapabilites = True - , J.supportsFunctionBreakpointsInitializeResponseCapabilites = True - , J.supportsConditionalBreakpointsInitializeResponseCapabilites = True - , J.supportsHitConditionalBreakpointsInitializeResponseCapabilites = True - , J.supportsEvaluateForHoversInitializeResponseCapabilites = True - , J.exceptionBreakpointFiltersInitializeResponseCapabilites = [ + let capa = J.InitializeResponseCapabilities { + J.supportsConfigurationDoneRequestInitializeResponseCapabilities = True + , J.supportsFunctionBreakpointsInitializeResponseCapabilities = True + , J.supportsConditionalBreakpointsInitializeResponseCapabilities = True + , J.supportsHitConditionalBreakpointsInitializeResponseCapabilities = True + , J.supportsEvaluateForHoversInitializeResponseCapabilities = True + , J.exceptionBreakpointFiltersInitializeResponseCapabilities = [ J.ExceptionBreakpointsFilter "break-on-error" "break-on-error" False , J.ExceptionBreakpointsFilter "break-on-exception" "break-on-exception" False ] - , J.supportsStepBackInitializeResponseCapabilites = False - , J.supportsSetVariableInitializeResponseCapabilites = False - , J.supportsRestartFrameInitializeResponseCapabilites = False - , J.supportsGotoTargetsRequestInitializeResponseCapabilites = False - , J.supportsStepInTargetsRequestInitializeResponseCapabilites = False - , J.supportsCompletionsRequestInitializeResponseCapabilites = True + , J.supportsStepBackInitializeResponseCapabilities = False + , J.supportsSetVariableInitializeResponseCapabilities = False + , J.supportsRestartFrameInitializeResponseCapabilities = False + , J.supportsGotoTargetsRequestInitializeResponseCapabilities = False + , J.supportsStepInTargetsRequestInitializeResponseCapabilities = False + , J.supportsCompletionsRequestInitializeResponseCapabilities = True + , J.supportsModulesRequestInitializeResponseCapabilities = False -- no GUI on VSCode + , J.additionalModuleColumnsInitializeResponseCapabilities = [] -- no GUI on VSCode } res = J.InitializeResponse resSeq "response" seq True "initialize" "" capa @@ -789,14 +965,14 @@ setBreakpointsRequestHandler :: MVar DebugContextData -> J.SetBreakpointsRequest -> IO () setBreakpointsRequestHandler mvarCtx req = do ctx <- readMVar mvarCtx - let cwd = workspaceDebugContextData ctx + let cwd = nzPath $ workspaceDebugContextData ctx args = J.argumentsSetBreakpointsRequest req - source = J.sourceSetBreakpointsRequestArguments args - path = J.pathSource source + source = J.sourceSetBreakpointsArguments args + path = nzPath $ J.pathSource source if U.startswith cwd path then setBreakpointsInternal mvarCtx req else do - let msg = L.intercalate " " ["setBreakpoints request ignored."] + let msg = L.intercalate " " ["setBreakpoints request ignored.", cwd, path] resSeq <- getIncreasedResponseSequence mvarCtx sendResponse mvarCtx $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg @@ -810,9 +986,9 @@ ctx <- readMVar mvarCtx let cwd = workspaceDebugContextData ctx args = J.argumentsSetBreakpointsRequest req - source = J.sourceSetBreakpointsRequestArguments args + source = J.sourceSetBreakpointsArguments args path = J.pathSource source - reqBps = J.breakpointsSetBreakpointsRequestArguments args + reqBps = J.breakpointsSetBreakpointsArguments args startup = startupDebugContextData ctx stMod = startupModuleDebugContextData ctx bps = map (convBp cwd path startup stMod) reqBps @@ -860,9 +1036,13 @@ mapM_ (deleteBreakPointOnGHCi mvarCtx) delBps - + -- | + -- + insert :: [BreakPointData] -> IO [J.Breakpoint] insert reqBps = do + results <- mapM insertInternal reqBps + let addBps = filter (\(_, (J.Breakpoint _ verified _ _ _ _ _ _)) -> verified) results resData = map snd results @@ -891,6 +1071,53 @@ (J.Source (Just modName) filePath Nothing Nothing) lineNo (-1) lineNo (-1)) + {- + insertInternalDAP reqBp = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProc reqBp + + withProc reqBp Nothing = do + errorM _LOG_NAME $ "[insertInternalDAP] ghci not started. " ++ show reqBp + return (reqBp, + J.Breakpoint Nothing False "ghci not started." + (J.Source Nothing "" Nothing Nothing) + (-1) (-1) (-1) (-1)) + + withProc reqBp@(BreakPointData _ (G.SourcePosition filePath lineNo col _ _) _ _ _ _) (Just ghciProc) = + G.setBreakDAP ghciProc outHdl (nzPath filePath) lineNo col >>= \case + Left err -> + return (reqBp, + J.Breakpoint Nothing False err + (J.Source Nothing filePath Nothing Nothing) + lineNo (-1) lineNo (-1)) + Right dats -> case readMay dats of + Just (Right jbp@(J.Breakpoint idBP _ _ srcBP sl sc el ec)) -> do + debugM _LOG_NAME $ "[insertInternalDAP] read string: " ++ dats + return (reqBp{ nameBreakPointData = maybe "" id (J.nameSource srcBP) + , breakNoBreakPointData = idBP + , srcPosBreakPointData = (srcPosBreakPointData reqBp) { + G.startLineNoSourcePosition = sl + , G.startColNoSourcePosition = sc + , G.endLineNoSourcePosition = el + , G.endColNoSourcePosition = ec + } + }, + jbp) + Just (Left err) -> do + sendErrorEvent mvarCtx $ "[insertInternalDAP] " ++ err + return (reqBp, + J.Breakpoint Nothing False err + (J.Source Nothing filePath Nothing Nothing) + lineNo (-1) lineNo (-1)) + Nothing -> do + sendErrorEvent mvarCtx $ "[insertInternalDAP] can not read valriables. " ++ dats + return (reqBp, + J.Breakpoint Nothing False "dap error. can not read valriables." + (J.Source Nothing filePath Nothing Nothing) + lineNo (-1) lineNo (-1)) + + outHdl = sendStdoutEvent mvarCtx + -} + + -- | -- setFunctionBreakpointsRequestHandler :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> IO () @@ -1714,7 +1941,7 @@ -- | --- ブレークポイントをGHCi上でdeleteする +-- -- deleteBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO () deleteBreakPointOnGHCi mvarCtx bp@(BreakPointData _ _ (Just breakNo) _ _ _) = @@ -1731,7 +1958,7 @@ deleteBreakPointOnGHCi mvarCtx bp = sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] invalid delete break point. " ++ show bp -- | --- GHCi上でブレークポイントを追加する +-- -- addBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String (Int, G.SourcePosition)) addBreakPointOnGHCi mvarCtx bp@(BreakPointData modName (G.SourcePosition _ lineNo col _ _) _ _ _ _) = @@ -1745,7 +1972,7 @@ outHdl = sendStdoutEvent mvarCtx -- | --- GHCi上で関数ブレークポイントを追加する +-- -- addFunctionBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String (Int, G.SourcePosition)) addFunctionBreakPointOnGHCi mvarCtx bp@(BreakPointData name _ _ _ _ _) = @@ -1760,7 +1987,7 @@ -- | --- Loggerのセットアップ +-- -- setupLogger :: FilePath -> Priority -> IO () setupLogger logFile level = do diff --git a/app/Phoityne/VSCode/Main.hs b/app/Phoityne/VSCode/Main.hs deleted file mode 100644 --- a/app/Phoityne/VSCode/Main.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiWayIf #-} - -module Phoityne.VSCode.Main (run) where - -import qualified Phoityne.VSCode.Argument as A -import qualified Phoityne.VSCode.Control as CTRL - -import Data.Either.Utils -import System.Exit -import qualified Control.Exception as E -import qualified Data.ConfigFile as C -import qualified System.Console.CmdArgs as CMD -import qualified System.Log.Logger as L - - --- | --- -run :: IO Int -run = flip E.catches handlers $ do - - args <- getArgs - - iniSet <- loadIniFile args - - flip E.finally finalProc $ do - CTRL.run args iniSet - - where - handlers = [ E.Handler helpExcept - , E.Handler exitExcept - , E.Handler ioExcept - , E.Handler someExcept - ] - finalProc = L.removeAllHandlers - helpExcept (_ :: A.HelpExitException) = return 0 - exitExcept ExitSuccess = return 0 - exitExcept (ExitFailure c) = return c - ioExcept (e :: E.IOException) = print e >> return 1 - someExcept (e :: E.SomeException) = print e >> return 1 - - --- | --- -getArgs :: IO A.ArgData -getArgs = E.catches (CMD.cmdArgs A.config) handlers - where - handlers = [E.Handler someExcept] - someExcept (e :: E.SomeException) = if - | "ExitSuccess" == show e -> E.throw A.HelpExitException - | otherwise -> E.throwIO e - - --- | --- -loadIniFile :: A.ArgData - -> IO C.ConfigParser -loadIniFile _ = do - let cp = forceEither $ C.readstring C.emptyCP defaultIniSetting - return cp{ C.accessfunc = C.interpolatingAccess 5 } - - --- | --- -defaultIniSetting :: String -defaultIniSetting = unlines [ - "[DEFAULT]" - , "work_dir = ./" - , "" - , "[LOG]" - , "file = %(work_dir)sphoityne.log" - , "level = WARNING" - , "" - , "[PHOITYNE]" - ] - diff --git a/app/Phoityne/VSCode/TH/ColumnDescriptorJSON.hs b/app/Phoityne/VSCode/TH/ColumnDescriptorJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ColumnDescriptorJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ColumnDescriptorJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- A ColumnDescriptor specifies what module attribute to show in a column of the ModulesView, how to format it, and what the column's label should be. +-- It is only used if the underlying UI actually supports this level of customization. +-- +data ColumnDescriptor = + ColumnDescriptor { + attributeNameColumnDescriptor :: String -- Name of the attribute rendered in this column. + , labelColumnDescriptor :: String -- Header UI label of column. + , formatColumnDescriptor :: Maybe String -- Format to use for the rendered values in this column. TBD how the format strings looks like. + , typeColumnDescriptor :: Maybe String -- Datatype of values in this column. Defaults to 'string' if not specified. 'string' | 'number' | 'boolean' | 'unixTimestampUTC'; + , widthColumnDescriptor :: Maybe Int -- Width of this column in characters (hint only). + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ColumnDescriptor") } ''ColumnDescriptor) diff --git a/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs deleted file mode 100644 --- a/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON where - -import Data.Aeson.TH - -import Phoityne.VSCode.Utility -import Phoityne.VSCode.TH.ExceptionBreakpointsFilterJSON - --- | --- Information about the capabilities of a debug adapter. --- -data InitializeResponseCapabilites = - InitializeResponseCapabilites { - supportsConfigurationDoneRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the configurationDoneRequest. - , supportsFunctionBreakpointsInitializeResponseCapabilites :: Bool -- The debug adapter supports functionBreakpoints. - , supportsConditionalBreakpointsInitializeResponseCapabilites :: Bool -- The debug adapter supports conditionalBreakpoints. - , supportsHitConditionalBreakpointsInitializeResponseCapabilites :: Bool -- The debug adapter supports breakpoints that break execution after a specified number of hits. - , supportsEvaluateForHoversInitializeResponseCapabilites :: Bool -- The debug adapter supports a (side effect free) evaluate request for data hovers. - , exceptionBreakpointFiltersInitializeResponseCapabilites :: [ExceptionBreakpointsFilter] -- Available filters for the setExceptionBreakpoints request. - , supportsStepBackInitializeResponseCapabilites :: Bool -- The debug adapter supports stepping back. - , supportsSetVariableInitializeResponseCapabilites :: Bool -- The debug adapter supports setting a variable to a value. - , supportsRestartFrameInitializeResponseCapabilites :: Bool -- The debug adapter supports restarting a frame. - , supportsGotoTargetsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the gotoTargetsRequest. - , supportsStepInTargetsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the stepInTargetsRequest. - , supportsCompletionsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the completionsRequest. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilites") } ''InitializeResponseCapabilites) - --- | --- -defaultInitializeResponseCapabilites :: InitializeResponseCapabilites -defaultInitializeResponseCapabilites = InitializeResponseCapabilites False False False False False [] False False False False False False - diff --git a/app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitiesJSON.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.InitializeResponseCapabilitiesJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ExceptionBreakpointsFilterJSON +import Phoityne.VSCode.TH.ColumnDescriptorJSON + +-- | +-- Information about the capabilities of a debug adapter. +-- +data InitializeResponseCapabilities = + InitializeResponseCapabilities { + supportsConfigurationDoneRequestInitializeResponseCapabilities :: Bool -- The debug adapter supports the configurationDoneRequest. + , supportsFunctionBreakpointsInitializeResponseCapabilities :: Bool -- The debug adapter supports functionBreakpoints. + , supportsConditionalBreakpointsInitializeResponseCapabilities :: Bool -- The debug adapter supports conditionalBreakpoints. + , supportsHitConditionalBreakpointsInitializeResponseCapabilities :: Bool -- The debug adapter supports breakpoints that break execution after a specified number of hits. + , supportsEvaluateForHoversInitializeResponseCapabilities :: Bool -- The debug adapter supports a (side effect free) evaluate request for data hovers. + , exceptionBreakpointFiltersInitializeResponseCapabilities :: [ExceptionBreakpointsFilter] -- Available filters for the setExceptionBreakpoints request. + , supportsStepBackInitializeResponseCapabilities :: Bool -- The debug adapter supports stepping back. + , supportsSetVariableInitializeResponseCapabilities :: Bool -- The debug adapter supports setting a variable to a value. + , supportsRestartFrameInitializeResponseCapabilities :: Bool -- The debug adapter supports restarting a frame. + , supportsGotoTargetsRequestInitializeResponseCapabilities :: Bool -- The debug adapter supports the gotoTargetsRequest. + , supportsStepInTargetsRequestInitializeResponseCapabilities :: Bool -- The debug adapter supports the stepInTargetsRequest. + , supportsCompletionsRequestInitializeResponseCapabilities :: Bool -- The debug adapter supports the completionsRequest. + , supportsModulesRequestInitializeResponseCapabilities :: Bool -- The debug adapter supports the modules request. + , additionalModuleColumnsInitializeResponseCapabilities :: [ColumnDescriptor] -- The set of additional module information exposed by the debug adapter. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilities") } ''InitializeResponseCapabilities) + +-- | +-- +defaultInitializeResponseCapabilities :: InitializeResponseCapabilities +defaultInitializeResponseCapabilities = InitializeResponseCapabilities False False False False False [] False False False False False False False [] + diff --git a/app/Phoityne/VSCode/TH/InitializeResponseJSON.hs b/app/Phoityne/VSCode/TH/InitializeResponseJSON.hs --- a/app/Phoityne/VSCode/TH/InitializeResponseJSON.hs +++ b/app/Phoityne/VSCode/TH/InitializeResponseJSON.hs @@ -6,7 +6,7 @@ import Data.Aeson.TH import Phoityne.VSCode.Utility -import Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON +import Phoityne.VSCode.TH.InitializeResponseCapabilitiesJSON import Phoityne.VSCode.TH.InitializeRequestJSON -- | @@ -20,7 +20,7 @@ , successInitializeResponse :: Bool -- Outcome of the request , commandInitializeResponse :: String -- The command requested , messageInitializeResponse :: String -- Contains error message if success == false. - , bodyInitializeResponse :: InitializeResponseCapabilites -- The capabilities of this debug adapter + , bodyInitializeResponse :: InitializeResponseCapabilities -- The capabilities of this debug adapter } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponse") } ''InitializeResponse) @@ -30,11 +30,11 @@ -- parseErrorInitializeResponse :: Int -> String -> InitializeResponse parseErrorInitializeResponse seq msg = - InitializeResponse seq "response" seq False "initialize" msg defaultInitializeResponseCapabilites + InitializeResponse seq "response" seq False "initialize" msg defaultInitializeResponseCapabilities -- | -- errorInitializeResponse :: Int -> InitializeRequest -> String -> InitializeResponse errorInitializeResponse seq (InitializeRequest reqSeq _ _ _) msg = - InitializeResponse seq "response" reqSeq False "initialize" msg defaultInitializeResponseCapabilites + InitializeResponse seq "response" reqSeq False "initialize" msg defaultInitializeResponseCapabilities diff --git a/app/Phoityne/VSCode/TH/ModuleJSON.hs b/app/Phoityne/VSCode/TH/ModuleJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ModuleJSON.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ModuleJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- A Module object represents a row in the modules view. +-- Two attributes are mandatory: an id identifies a module in the modules view and is used in a ModuleEvent for identifying a module for adding, updating or deleting. +-- The name is used to minimally render the module in the UI. +-- +-- Additional attributes can be added to the module. They will show up in the module View if they have a corresponding ColumnDescriptor. +-- To avoid an unnecessary proliferation of additional attributes with similar semantics but different names +-- we recommend to re-use attributes from the 'recommended' list below first, and only introduce new attributes if nothing appropriate could be found. +-- +-- +data Module = + Module { + idModule :: String -- Unique identifier for the module. + , nameModle :: String -- A name of the module. + -- optional but recommended attributes. + -- always try to use these first before introducing additional attributes. + -- Logical full path to the module. The exact definition is implementation defined, but usually this would be a full path to the on-disk file for the module. + , pathModle :: String + , versionModule :: Maybe String -- Version of Module. + , isUserCodeModule :: Bool -- True if the module is considered 'user code' by a debugger that supports 'Just My Code'. + , symbolStatusModule :: Maybe String -- User understandable description of if symbols were found for the module (ex: 'Symbols Loaded', 'Symbols not found', etc. + , symbolFilePathModule :: Maybe FilePath -- Logical full path to the symbol file. The exact definition is implementation defined. + , dateTimeStampModule :: Maybe String -- Module created or modified. + , addressRangeModule :: Maybe String -- Address range covered by this module. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Module") } ''Module) diff --git a/app/Phoityne/VSCode/TH/ModulesArgumentsJSON.hs b/app/Phoityne/VSCode/TH/ModulesArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ModulesArgumentsJSON.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ModulesArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for 'modules' request. +-- +data ModulesArguments = + ModulesArguments { + startModuleModulesArguments :: Maybe Int -- The index of the first module to return; if omitted modules start at 0. + , moduleCounteModulesArguments :: Maybe Int -- The number of modules to return. If moduleCount is not specified or 0, all modules are returned. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ModulesArguments") } ''ModulesArguments) diff --git a/app/Phoityne/VSCode/TH/ModulesRequestJSON.hs b/app/Phoityne/VSCode/TH/ModulesRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ModulesRequestJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ModulesRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ModulesArgumentsJSON + +-- | +-- Modules can be retrieved from the debug adapter with the ModulesRequest which can either return all modules or a range of modules to support paging. +-- +data ModulesRequest = + ModulesRequest { + argumentsModulesRequest :: ModulesArguments -- command: 'modules'; + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ModulesRequest") } ''ModulesRequest) diff --git a/app/Phoityne/VSCode/TH/ModulesResponseBodyJSON.hs b/app/Phoityne/VSCode/TH/ModulesResponseBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ModulesResponseBodyJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ModulesResponseBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ModuleJSON + +-- | +-- Response to "scopes" request. +-- +data ModulesResponseBody = + ModulesResponseBody { + modulesModulesResponseBody :: [Module] -- All modules or range of modules. + , totalModulesModulesResponseBody :: Int -- The total number of modules available. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ModulesResponseBody") } ''ModulesResponseBody) + + diff --git a/app/Phoityne/VSCode/TH/ModulesResponseJSON.hs b/app/Phoityne/VSCode/TH/ModulesResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ModulesResponseJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ModulesResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ModulesResponseBodyJSON + +-- | +-- Response to 'modules' request. +-- +data ModulesResponse = + ModulesResponse { + bodyModulesResponse :: ModulesResponseBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ModulesResponse") } ''ModulesResponse) + + + + + diff --git a/app/Phoityne/VSCode/TH/SetBreakpointsArgumentsJSON.hs b/app/Phoityne/VSCode/TH/SetBreakpointsArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetBreakpointsArgumentsJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetBreakpointsArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SourceJSON +import Phoityne.VSCode.TH.SourceBreakpointJSON + +-- | +-- Arguments for "setBreakpoints" request. +-- +data SetBreakpointsArguments = + SetBreakpointsArguments { + sourceSetBreakpointsArguments :: Source -- The source location of the breakpoints; either source.path or source.reference must be specified. + , breakpointsSetBreakpointsArguments :: [SourceBreakpoint] -- The code locations of the breakpoints. + --, sourceModifiedSetBreakpointsArguments :: Bool -- A value of true indicates that the underlying source has been modified which results in new breakpoint locations. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsArguments") } ''SetBreakpointsArguments) + diff --git a/app/Phoityne/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs b/app/Phoityne/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.VSCode.Utility -import Phoityne.VSCode.TH.SourceJSON -import Phoityne.VSCode.TH.SourceBreakpointJSON - --- | --- Arguments for "setBreakpoints" request. --- -data SetBreakpointsRequestArguments = - SetBreakpointsRequestArguments { - sourceSetBreakpointsRequestArguments :: Source -- The source location of the breakpoints; either source.path or source.reference must be specified. - , breakpointsSetBreakpointsRequestArguments :: [SourceBreakpoint] -- The code locations of the breakpoints. - --, sourceModifiedSetBreakpointsRequestArguments :: Bool -- A value of true indicates that the underlying source has been modified which results in new breakpoint locations. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsRequestArguments") } ''SetBreakpointsRequestArguments) - diff --git a/app/Phoityne/VSCode/TH/SetBreakpointsRequestJSON.hs b/app/Phoityne/VSCode/TH/SetBreakpointsRequestJSON.hs --- a/app/Phoityne/VSCode/TH/SetBreakpointsRequestJSON.hs +++ b/app/Phoityne/VSCode/TH/SetBreakpointsRequestJSON.hs @@ -6,7 +6,7 @@ import Data.Aeson.TH import Phoityne.VSCode.Utility -import Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON +import Phoityne.VSCode.TH.SetBreakpointsArgumentsJSON -- | -- SetBreakpoints request; value of command field is "setBreakpoints". @@ -19,7 +19,7 @@ seqSetBreakpointsRequest :: Int -- Sequence number , typeSetBreakpointsRequest :: String -- One of "request", "response", or "event" , commandSetBreakpointsRequest :: String -- The command to execute - , argumentsSetBreakpointsRequest :: SetBreakpointsRequestArguments -- Arguments for "setBreakpoints" request. + , argumentsSetBreakpointsRequest :: SetBreakpointsArguments -- Arguments for "setBreakpoints" request. } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsRequest") } ''SetBreakpointsRequest) diff --git a/app/Phoityne/VSCode/TH/SourceJSON.hs b/app/Phoityne/VSCode/TH/SourceJSON.hs --- a/app/Phoityne/VSCode/TH/SourceJSON.hs +++ b/app/Phoityne/VSCode/TH/SourceJSON.hs @@ -12,11 +12,14 @@ -- data Source = Source { - nameSource :: Maybe String -- The short name of the source. Every source returned from the debug adapter has a name. When specifying a source to the debug adapter this name is optional. - , pathSource :: String -- The long (absolute) path of the source. It is not guaranteed that the source exists at this location. - , sourceReferenceSource :: Maybe Int -- If sourceReference > 0 the contents of the source can be retrieved through the SourceRequest. A sourceReference is only valid for a session, so it must not be used to persist a source. - , origineSource :: Maybe String -- The (optional) origin of this source: possible values "internal module", "inlined content from source map", etc. - -- , adapterDataSource :: Any -- Optional data that a debug adapter might want to loop through the client. The client should leave the data intact and persist it across sessions. The client should not interpret the data. + nameSource :: Maybe String -- The short name of the source. Every source returned from the debug adapter has a name. When sending a source to the debug adapter this name is optional. + , pathSource :: String -- The path of the source to be shown in the UI. It is only used to locate and load the content of the source if no sourceReference is specified (or its vaule is 0). + , sourceReferenceSource :: Maybe Int -- If sourceReference > 0 the contents of the source must be retrieved through the SourceRequest (even if a path is specified). A sourceReference is only valid for a session, so it must not be used to persist a source. + -- , presentationHintSource :: Maybe String -- An optional hint for how to present the source in the UI. A value of 'deemphasize' can be used to indicate that the source is not available or that it is skipped on stepping. + , origineSource :: Maybe String -- The (optional) origin of this source: possible values 'internal module', 'inlined content from source map', etc. + -- , sourcesSource :: [Source] -- An optional list of sources that are related to this source. These may be the source that generated this source. + -- , adapterDataSource :: Maybe String -- Optional data that a debug adapter might want to loop through the client. The client should leave the data intact and persist it across sessions. The client should not interpret the data. + -- , checksumsSource :: [] -- The checksums associated with this file. } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Source") } ''Source) diff --git a/app/Phoityne/VSCode/Type.hs b/app/Phoityne/VSCode/Type.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/Type.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Rank2Types #-} + +module Phoityne.VSCode.Type where + +import Data.Data +import Control.Lens +import qualified Control.Exception.Safe as E + +-------------------------------------------------------------------------------- +-- | Command Line Argument Data Type + +-- | +-- Help Exception +-- +data HelpExitException = HelpExitException + deriving (Show, Typeable) + +instance E.Exception HelpExitException + +-- | +-- +data ArgData = ArgData { + _hackageVersionArgData :: String +} deriving (Data, Typeable, Show, Read, Eq) + +makeLenses ''ArgData + diff --git a/app/Phoityne/VSCode/Utility.hs b/app/Phoityne/VSCode/Utility.hs --- a/app/Phoityne/VSCode/Utility.hs +++ b/app/Phoityne/VSCode/Utility.hs @@ -19,6 +19,58 @@ import qualified Data.Conduit.Binary as C import qualified Data.Conduit as C import qualified Data.Conduit.List as C +import qualified Data.Char as CH + + +-- | +-- +_SLASH :: Char +_SLASH = '/' + + +-- | +-- +_BACK_SLASH :: Char +_BACK_SLASH = '\\' + + +-- | +-- +toLower :: String -> String +toLower = map CH.toLower + + +-- | +-- +toUpper :: String -> String +toUpper = map CH.toUpper + + +-- | +-- +win2unixSlash :: String -> String +win2unixSlash = map (\c -> if c == _BACK_SLASH then _SLASH else c) + + +-- | +-- +unix2winSlash :: String -> String +unix2winSlash = map (\c -> if c == _SLASH then _BACK_SLASH else c) + + +-- | +-- normalized path +-- +nzPath :: FilePath -> FilePath +nzPath = drive2lower . win2unixSlash + + +-- | +-- to lowercase Windows drive letter +-- +drive2lower :: FilePath -> FilePath +drive2lower (x : ':' : xs) = CH.toLower x : ':' : xs +drive2lower xs = xs -- | 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.20.0 +version: 0.0.21.0 synopsis: Haskell Debug Adapter for Visual Studio Code. description: Please see README.md license: BSD3 @@ -22,12 +22,13 @@ other-modules: Paths_phoityne_vscode , Phoityne.VSCode.Argument , Phoityne.VSCode.Control - , Phoityne.VSCode.Main , Phoityne.VSCode.Core , Phoityne.VSCode.Constant + , Phoityne.VSCode.Type , Phoityne.VSCode.Utility , Phoityne.VSCode.Utility , Phoityne.VSCode.TH.BreakpointJSON + , Phoityne.VSCode.TH.ColumnDescriptorJSON , Phoityne.VSCode.TH.CompletionsItemJSON , Phoityne.VSCode.TH.CompletionsArgumentsJSON , Phoityne.VSCode.TH.CompletionsResponseBodyJSON @@ -54,12 +55,17 @@ , Phoityne.VSCode.TH.InitializedEventJSON , Phoityne.VSCode.TH.InitializeRequestArgumentsJSON , Phoityne.VSCode.TH.InitializeRequestJSON - , Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON + , Phoityne.VSCode.TH.InitializeResponseCapabilitiesJSON , Phoityne.VSCode.TH.InitializeResponseJSON , Phoityne.VSCode.TH.LaunchRequestArgumentsJSON , Phoityne.VSCode.TH.LaunchRequestJSON , Phoityne.VSCode.TH.LaunchResponseJSON , Phoityne.VSCode.TH.MessageJSON + , Phoityne.VSCode.TH.ModuleJSON + , Phoityne.VSCode.TH.ModulesArgumentsJSON + , Phoityne.VSCode.TH.ModulesRequestJSON + , Phoityne.VSCode.TH.ModulesResponseBodyJSON + , Phoityne.VSCode.TH.ModulesResponseJSON , Phoityne.VSCode.TH.NextArgumentsJSON , Phoityne.VSCode.TH.NextRequestJSON , Phoityne.VSCode.TH.NextResponseJSON @@ -74,7 +80,7 @@ , Phoityne.VSCode.TH.ScopesBodyJSON , Phoityne.VSCode.TH.ScopesRequestJSON , Phoityne.VSCode.TH.ScopesResponseJSON - , Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON + , Phoityne.VSCode.TH.SetBreakpointsArgumentsJSON , Phoityne.VSCode.TH.SetBreakpointsRequestJSON , Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON , Phoityne.VSCode.TH.SetBreakpointsResponseJSON @@ -142,5 +148,8 @@ , conduit , conduit-extra , resourcet + , safe-exceptions + , lens + , data-default default-language: Haskell2010