phoityne-vscode 0.0.2.0 → 0.0.3.0
raw patch · 22 files changed
+801/−416 lines, 22 files
Files
- Changelog.md +6/−0
- README.md +12/−8
- app/Phoityne/IO/Control.hs +47/−12
- app/Phoityne/IO/GUI/Control.hs +570/−347
- app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs +11/−0
- app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs +12/−0
- app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs +6/−0
- app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs +6/−0
- app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs +15/−0
- app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs +9/−6
- app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs +12/−0
- app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs +6/−0
- app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs +6/−0
- app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs +6/−0
- app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs +6/−0
- app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs +6/−0
- app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs +5/−0
- app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs +5/−1
- app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs +5/−0
- app/Phoityne/IO/Main.hs +5/−37
- phoityne-vscode.cabal +2/−2
- vscode/package.json +43/−3
Changelog.md view
@@ -1,4 +1,10 @@ +20160515 phoityne-vscode-0.0.3.0++ * [Add] tasks.jsonが存在しない場合は、作成するようにした。+ * [Add] package.json にキーバインディング設定を追加した。(stack build, stack clean, stack test, stack watch)+ * [Add] hover requestに対して、:info結果を返すようにした。+ 20160508 phoityne-vscode-0.0.2.0
README.md view
@@ -14,17 +14,13 @@ 5. Set startup source file. Default file is test/Spec.hs 6. Run debug(F5) -[](https://sites.google.com/site/phoityne/doc_jp/demo01.gif?attredirects=0)+[](https://sites.google.com/site/phoityne/doc_jp/demo01.gif?attredirects=0) ## Install ### Run stack install - % stack new project- . . . . .- %- % cd project % stack install phoityne-vscode . . . . . %@@ -33,7 +29,7 @@ ### Prepare vscode extensions 1. create folder "%USERPROFILE%\.vscode\extensions\phoityne-vscode"-2. copy "phoityne-vscode-0.0.1.0\vscode\package.json"(*) to "%USERPROFILE%\.vscode\extensions\phoityne-vscode"+2. copy "phoityne-vscode-0.0.#.0\vscode\package.json"(*) to "%USERPROFILE%\.vscode\extensions\phoityne-vscode" 3. copy "%USERPROFILE%\AppData\Roaming\local\bin\phoityne-vscode.exe" to "%USERPROFILE%\.vscode\extensions\phoityne-vscode" 4. Install "Haskell Syntax Highlighting" extension. Ctrl+p and put "ext install haskell syntax highlighting". @@ -43,9 +39,17 @@ % -## Important+### Important -* need c:\temp folder. phoityne.log file will be created. * breakpoint can be set in a .hs file which defineds "module ... where". * source file extension must be ".hs"+++## Key Bindings++* F5 : start debug+* F6 : show command menu (for stack watch)+* Shift + F6 : stop stack watch+* F7 : stack clean & build+* F8 : stack test
app/Phoityne/IO/Control.hs view
@@ -16,15 +16,21 @@ import qualified Phoityne.IO.CUI.GHCiControl as GHCI -- システム-import System.Info-import System.Log.Logger import System.Exit-import Distribution.System import Control.Concurrent import Data.String.Utils import qualified Data.ConfigFile as C + -- |+--+data SysEnv =+ SysEnv {+ promptSysEnv :: String+ } deriving (Show, Read, Eq, Ord)+++-- | -- ロジックメイン -- run :: A.ArgData -- コマンドライン引数@@ -32,27 +38,27 @@ -> IO Int -- exit code run _ _ = do - infoM _LOG_NAME $ "OS:" ++ os- infoM _LOG_NAME $ "ARCH:" ++ arch- infoM _LOG_NAME $ "BuildOS:" ++ show buildOS + mvarENV <- newMVar $ SysEnv _PHOITYNE_GHCI_PROMPT+ mvarCUI <- newMVar GHCI.defaultExternalCommandData - let cmdData = createCmdData mvarCUI + let cmdData = createCmdData mvarENV mvarCUI+ GUI.run cmdData return 1 where- createCmdData mvarCUI =+ createCmdData mvarENV mvarCUI = GUI.DebugCommandData { GUI.startDebugCommandData = debugStart mvarCUI , GUI.stopDebugCommandData = stopDebug mvarCUI- , GUI.readDebugCommandData = readResult mvarCUI+ , GUI.readDebugCommandData = readResult mvarENV mvarCUI , GUI.readLinesDebugCommandData = readLines mvarCUI- , GUI.promptDebugCommandData = execCmd mvarCUI $ ":set prompt \"" ++ _PHOITYNE_GHCI_PROMPT ++ "\""+ , GUI.promptDebugCommandData = setPrompt mvarENV mvarCUI , GUI.breakDebugCommandData = setBreak mvarCUI , GUI.bindingsDebugCommandData = execCmd mvarCUI ":show bindings" , GUI.runDebugCommandData = runDebug mvarCUI@@ -72,12 +78,39 @@ , GUI.loadFileDebugCommandData = \f-> execCmd mvarCUI $ ":l " ++ f , GUI.readWhileDebugCommandData = readWhile mvarCUI , GUI.infoDebugCommandData = \arg -> execCmd mvarCUI $ ":info " ++ arg+ , GUI.typeDebugCommandData = \arg -> execCmd mvarCUI $ ":type " ++ arg+ , GUI.moduleDebugCommandData = \arg -> execCmd mvarCUI $ ":module " ++ arg+ , GUI.envSetPromptDebugCommandData = envSetPrompt mvarENV+ , GUI.envGetPromptDebugCommandData = envGetPrompt mvarENV } +-- |+--+-- +envSetPrompt :: MVar SysEnv -> String -> IO ()+envSetPrompt mvarENV prmt = do+ sysEnv <- takeMVar mvarENV+ putMVar mvarENV sysEnv{promptSysEnv = prmt} -- | -- -- +envGetPrompt :: MVar SysEnv -> IO String+envGetPrompt mvarENV = readMVar mvarENV >>= return . promptSysEnv+++-- |+--+--+setPrompt :: MVar SysEnv -> MVar GHCI.ExternalCommandData -> IO String+setPrompt mvarENV mvarCUI = do+ prmpt <- envGetPrompt mvarENV+ execCmd mvarCUI $ ":set prompt \"" ++ prmpt ++ "\""+++-- |+--+-- cleanStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () cleanStart mvarCUI cwd = do exeData <- GHCI.run "stack" ["clean"] $ Just cwd@@ -125,8 +158,10 @@ -- | -- -- -readResult :: MVar GHCI.ExternalCommandData -> IO String-readResult mvarCUI = readWhile mvarCUI $ not . endswith _PHOITYNE_GHCI_PROMPT+readResult :: MVar SysEnv -> MVar GHCI.ExternalCommandData -> IO String+readResult mvarENV mvarCUI = do+ prmpt <- envGetPrompt mvarENV+ readWhile mvarCUI $ not . endswith prmpt -- |
app/Phoityne/IO/GUI/Control.hs view
@@ -14,7 +14,7 @@ import Phoityne.Constant import Phoityne.Utility-+import Phoityne.IO.Utility import qualified Phoityne.IO.GUI.VSCode.TH.BreakpointJSON as J import qualified Phoityne.IO.GUI.VSCode.TH.ContinueRequestJSON as J import qualified Phoityne.IO.GUI.VSCode.TH.ContinueResponseJSON as J@@ -70,6 +70,7 @@ import System.IO import System.Exit import System.FilePath+import System.Directory import System.Log.Logger import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL@@ -85,7 +86,11 @@ import Data.Functor.Identity import Control.Monad import qualified System.FSNotify as FSN-+import qualified System.Log.Logger as L+import qualified System.Log.Formatter as L+import qualified System.Log.Handler as LH+import qualified System.Log.Handler.Simple as LHS+import Safe -- | --@@ -133,6 +138,10 @@ , loadFileDebugCommandData :: FilePath -> IO String , readWhileDebugCommandData :: (String -> Bool) -> IO String , infoDebugCommandData :: String -> IO String+ , typeDebugCommandData :: String -> IO String+ , moduleDebugCommandData :: String -> IO String+ , envSetPromptDebugCommandData :: String -> IO ()+ , envGetPromptDebugCommandData :: IO String } -- |@@ -207,6 +216,44 @@ _SEP_UNIX :: Char _SEP_UNIX = '/' +-- |+--+--+_TASKS_JSON_FILE_CONTENTS :: BSL.ByteString+_TASKS_JSON_FILE_CONTENTS = str2lbs $ Data.String.Utils.join "\n" $+ [+ "{"+ , " // atuomatically created by phoityne-vscode"+ , " "+ , " \"version\": \"0.1.0\","+ , " \"command\": \"cmd\","+ , " \"isShellCommand\": true,"+ , " \"showOutput\": \"always\","+ , " \"suppressTaskName\": true,"+ , " \"args\": [\"/c\"],"+ , " \"tasks\": ["+ , " {"+ , " \"taskName\": \"stack build\","+ , " \"args\": [ \"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 \" ]"+ , " },"+ , " { "+ , " \"isTestCommand\": true,"+ , " \"taskName\": \"stack test\","+ , " \"args\": [ \"echo START_STACK_TEST & cd ${workspaceRoot} & stack test & echo END_STACK_TEST \" ]"+ , " },"+ , " { "+ , " \"isWatching\": true,"+ , " \"taskName\": \"stack watch\","+ , " \"args\": [ \"echo START_STACK_WATCH & cd ${workspaceRoot} & stack build --file-watch & echo END_STACK_WATCH \" ]"+ , " }"+ , " ]"+ , "}"+ ] -- | --@@ -215,7 +262,6 @@ defaultDebugContext = DebugContext _INITIAL_RESPONSE_SEQUENCE (MAP.fromList []) "" "" False Nothing 0 False - -- | -- --@@ -244,7 +290,7 @@ -- -- wait :: DebugCommandData -> MVar DebugContext -> IO ()-wait cmdData ctx = go BSL.empty+wait cmdData mvarCtx = go BSL.empty where go :: BSL.ByteString -> IO () go buf = do@@ -253,10 +299,8 @@ case readContentLength (lbs2str newBuf) of Left _ -> go newBuf Right len -> do- infoM _LOG_NAME $ "[REQUEST] Content-Length: " ++ show len cnt <- BSL.hGet stdin len- infoM _LOG_NAME $ "[REQUEST] " ++ lbs2str cnt- handleRequest cmdData ctx cnt+ handleRequest cmdData mvarCtx newBuf cnt where readContentLength :: String -> Either ParseError Int@@ -270,69 +314,87 @@ -- | -- ---handleRequest :: DebugCommandData -> MVar DebugContext -> BSL.ByteString -> IO ()-handleRequest cmdData mvarCtx jsonStr = case J.eitherDecode jsonStr :: Either String J.Request of- Left err -> errRes jsonStr $ "requet parse error. [" ++ err ++ "]" - Right jsonDat -> sucRes jsonStr jsonDat+handleRequest :: DebugCommandData -> MVar DebugContext -> BSL.ByteString -> BSL.ByteString -> IO ()+handleRequest cmdData mvarCtx contLenStr jsonStr = do+ case J.eitherDecode jsonStr :: Either String J.Request of+ Left err -> do+ let msg = L.intercalate " " ["request request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg -- req_secが不明のため、エラー出力のみ行う。 - where- errRes :: BSL.ByteString -> String -> IO ()- errRes jsonStr msg = do- errorM _LOG_NAME $ msg ++ " [" ++ lbs2str jsonStr ++ "]"- wait cmdData mvarCtx+ Right (J.Request cmd) -> handle contLenStr jsonStr cmd+ + wait cmdData mvarCtx - sucRes jsonStr (J.Request cmd) = do- handle jsonStr cmd- wait cmdData mvarCtx+ where - handle jsonStr "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of- Left err -> errRes jsonStr $ "initialize parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of Right req -> initializeHandler mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["initialize request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ resSeq <- incResSeq mvarCtx+ sendResponse $ J.encode $ J.parseErrorInitializeResponse resSeq msg+ -- putStrLnStderr mvarCtx msg -- initialiezが完了していないと、イベントを受領してくれない。 - handle jsonStr "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of- Left err -> errRes jsonStr $ "launch parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of Right req -> launchHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["launch request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ -- resSeq <- incResSeq mvarCtx+ -- sendResponse $ J.encode $ J.parceErrorLaunchResponse resSeq msg+ putStrLnStderr mvarCtx msg -- req_secが不明のため、エラー出力のみ行う。 - handle jsonStr "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of- Left err -> errRes jsonStr $ "disconnect parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of Right req -> disconnectHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["disconnect request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of- Left err -> errRes jsonStr $ "setBreakpoints parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of Right req -> setBreakpointsHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["setBreakpoints request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of- Left err -> errRes jsonStr $ "continue parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of Right req -> continueHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["continue request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of- Left err -> errRes jsonStr $ "next parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of Right req -> stepOverHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["next request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of- Left err -> errRes jsonStr $ "stepIn parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of Right req -> stepInHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["stepIn request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of- Left err -> errRes jsonStr $ "stepOut parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of Right req -> do resSeq <- incResSeq mvarCtx let res = J.defaultStepOutResponse resSeq req resStr = J.encode $ res{J.successStepOutResponse = False, J.messageStepOutResponse = "unsupported command."} sendResponse resStr - putStrLnStderr mvarCtx "stepout command is not supported."+ putStrLnStderr mvarCtx "stepOut command is not supported." + Left err -> do+ let msg = L.intercalate " " ["stepOut request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of- Left err -> errRes jsonStr $ "pause parse error. [" ++ err ++ "]" ++ handle contLenStr jsonStr "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of Right req -> do resSeq <- incResSeq mvarCtx let res = J.defaultPauseResponse resSeq req@@ -341,25 +403,33 @@ putStrLnStderr mvarCtx "pause command is not supported." + Left err -> do+ let msg = L.intercalate " " ["pause request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of- Left err -> errRes jsonStr $ "stackTrace parse error. [" ++ err ++ "]" ++ handle contLenStr jsonStr "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of Right req -> stackTraceHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["stackTrace request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of- Left err -> errRes jsonStr $ "scopes parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of Right req -> scopesHandler cmdData mvarCtx req-+ Left err -> do+ let msg = L.intercalate " " ["scopes request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of- Left err -> errRes jsonStr $ "variables parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of Right req -> variablesHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["variables request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of- Left err -> errRes jsonStr $ "source parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of Right req -> do resSeq <- incResSeq mvarCtx let res = J.defaultSourceResponse resSeq req@@ -368,42 +438,58 @@ putStrLnStderr mvarCtx "source command is not supported." + Left err -> do+ let msg = L.intercalate " " ["source request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of- Left err -> errRes jsonStr $ "threads parse error. [" ++ err ++ "]" ++ handle contLenStr jsonStr "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of Right req -> threadsHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["threads request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of- Left err -> errRes jsonStr $ "evaluate parse error. [" ++ err ++ "]" + handle contLenStr jsonStr "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of Right req -> evaluateHandler cmdData mvarCtx req+ Left err -> do+ let msg = L.intercalate " " ["evaluate request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]+ putStrLnStderr mvarCtx msg - handle jsonStr cmd = do- putStrLnStderr mvarCtx $ cmd ++ " command is not supported."- putStrLnStderr mvarCtx $ lbs2str jsonStr ++ " is requested."+ handle contLenStr jsonStr cmd = do+ let msg = L.intercalate " " ["unknown request command.", cmd, lbs2str contLenStr, lbs2str jsonStr]+ putStrLnStderr mvarCtx msg -- | -- sendEvent :: BSL.ByteString -> IO ()-sendEvent str = do- infoM _LOG_NAME $ "[EVENT] Content-Length: " ++ show (BSL.length str)- infoM _LOG_NAME $ "[EVENT] " ++ lbs2str str+sendEvent str = sendResponseInternal str - sendResponseInternal str+-- |+--+sendEventL :: BSL.ByteString -> IO ()+sendEventL str = do+ infoM _LOG_NAME $ "[EVENT]" ++ lbs2str str+ sendEvent str + -- | ---sendResponse :: BSL.ByteString -> IO ()-sendResponse str = do- infoM _LOG_NAME $ "[RESPONSE] Content-Length: " ++ show (BSL.length str)- infoM _LOG_NAME $ "[RESPONSE] " ++ lbs2str str+sendResponseL :: BSL.ByteString -> IO ()+sendResponseL str = do+ infoM _LOG_NAME $ "[RESPONSE]" ++ lbs2str str+ sendResponse str - sendResponseInternal str -- | --+sendResponse :: BSL.ByteString -> IO ()+sendResponse str = sendResponseInternal str++-- |+-- sendResponseInternal :: BSL.ByteString -> IO () sendResponseInternal str = do BSL.hPut stdout $ BSL.append "Content-Length: " $ str2lbs $ show (BSL.length str)@@ -419,9 +505,9 @@ -- | -- initializeHandler :: MVar DebugContext -> J.InitializeRequest -> IO ()-initializeHandler mvarCtx (J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do+initializeHandler mvarCtx req@(J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do resSeq <- incResSeq mvarCtx- let capa = J.InitializeResponseCapabilites False False True False []+ let capa = J.InitializeResponseCapabilites False False True True [] res = J.InitializeResponse resSeq "response" seq True "initialize" "" capa sendResponse $ J.encode res@@ -429,103 +515,105 @@ where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "initializeHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["initialize request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponse $ J.encode $ J.errorInitializeResponse resSeq req msg + putStrLnStderr mvarCtx msg + -- | -- launchHandler :: DebugCommandData -> MVar DebugContext -> J.LaunchRequest -> IO () launchHandler cmdData mvarCtx req@(J.LaunchRequest _ _ _ args) = flip E.catches handlers $ do let ws = J.workspaceLaunchRequestArguments args su = J.startupLaunchRequestArguments args+ logFile = J.logFileLaunchRequestArguments args+ logLevelStr = J.logLevelLaunchRequestArguments args+ prmptStr = J.ghciPromptLaunchRequestArguments args + -- コンテキストデータの保持 ctx <- takeMVar mvarCtx putMVar mvarCtx ctx { workspaceDebugContext = ws , startupDebugContext = su } + envSetPromptDebugCommandData cmdData $ prmptStr++ -- ログイング設定+ logLevel <- case readMay logLevelStr of+ Just lv -> return lv+ Nothing -> do+ putStrLnStderr mvarCtx $ "log priority is invalid. WARNING set. [" ++ logLevelStr ++ "]"+ return WARNING++ setupLogger logFile logLevel++ logRequest $ show req++ -- tasks.jsonファイルの準備+ prepareTasksJsonFile mvarCtx ws+++ -- ghciのランチ runGHCi cmdData mvarCtx ws loadHsFile cmdData mvarCtx su + -- レスポンスとinitializedイベント送信 resSeq <- incResSeq mvarCtx- sendResponse $ J.encode $ J.defaultLaunchResponse resSeq req+ sendResponseL $ J.encode $ J.defaultLaunchResponse resSeq req resSeq <- incResSeq mvarCtx- sendEvent $ J.encode $ J.defaultInitializedEvent resSeq+ sendEventL $ J.encode $ J.defaultInitializedEvent resSeq + -- ファイル変更ウォッチの開始 watch cmdData mvarCtx + -- ランチ完了後のメッセージ出力 let infoMsg = [ "" , " Now, ghci initialized." , " Press F5 to start debugging."- , " Or modify source code. it will be loaded to debugger automatically."+ , " Or modify source code. it will be loaded to ghci automatically." , "" ] putStrLnConsole mvarCtx $ L.intercalate "\n" infoMsg- putStrStdout mvarCtx _PHOITYNE_GHCI_PROMPT+ putStrStdout mvarCtx prmptStr where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "launchHandler:" ++ show e- errorM _LOG_NAME msg------ |------ -watch :: DebugCommandData -> MVar DebugContext -> IO ()-watch cmdData mvarCtx = do- _ <- forkIO $ watchFiles cmdData mvarCtx- return ()--watchFiles :: DebugCommandData -> MVar DebugContext -> IO ()-watchFiles cmdData mvarCtx = do- FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce = FSN.Debounce 1} $ \mgr -> do-- ctx <- readMVar mvarCtx- let dir = workspaceDebugContext ctx- - infoM _LOG_NAME $ "start watch files in [" ++ dir ++ "]"- _ <- FSN.watchTree mgr dir hsFilter action- - forever $ threadDelay 1000000-- return ()- - where- hsFilter event = endswith _HS_FILE_EXT $ FSN.eventPath event-- action event = do-- ctx <- readMVar mvarCtx- withDebugStarted event $ debugStartedDebugContext ctx-- withDebugStarted _ True = do+ let msg = L.intercalate " " ["launch request error.", show req, show e] resSeq <- incResSeq mvarCtx- let terminatedEvt = J.defaultTerminatedEvent resSeq- terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True}- sendEvent terminatedEvtStr+ sendResponse $ J.encode $ J.errorLaunchResponse resSeq req msg + putStrLnStderr mvarCtx msg - withDebugStarted event False = do- ctx <- takeMVar mvarCtx- putMVar mvarCtx ctx{modifiedDebugContext = True}- loadHsFile cmdData mvarCtx (FSN.eventPath event) >> return () + -- |+ -- + prepareTasksJsonFile :: MVar DebugContext -> FilePath -> IO ()+ prepareTasksJsonFile mvarCtx ws = do+ let jsonFile = ws </> ".vscode" </> "tasks.json"+ + doesFileExist jsonFile >>= \case+ True -> infoM _LOG_NAME $ "tasks.json file exists. " ++ jsonFile + False -> do+ putStrLnConsole mvarCtx $ "create tasks.json file. " ++ jsonFile+ saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS + -- | -- disconnectHandler :: DebugCommandData -> MVar DebugContext -> J.DisconnectRequest -> IO () disconnectHandler cmdData mvarCtx req = flip E.catches handlers $ do - let exitCmd = stopDebugCommandData cmdData- quitCmd = quitDebugCommandData cmdData- readWhile = readWhileDebugCommandData cmdData+ logRequest $ show req + let exitCmd = stopDebugCommandData cmdData+ quitCmd = quitDebugCommandData cmdData+ readWhile = readWhileDebugCommandData cmdData+ cmdStr <- quitCmd infoM _LOG_NAME cmdStr putStrLnStdout mvarCtx cmdStr@@ -540,19 +628,22 @@ putStrLnStdout mvarCtx $ show code resSeq <- incResSeq mvarCtx- sendResponse $ J.encode $ J.defaultDisconnectResponse resSeq req+ sendResponseL $ J.encode $ J.defaultDisconnectResponse resSeq req where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "disconnectHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["disconnect request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorDisconnectResponse resSeq req msg putStrLnStderr mvarCtx msg + -- | -- setBreakpointsHandler :: DebugCommandData -> MVar DebugContext -> J.SetBreakpointsRequest -> IO () setBreakpointsHandler cmdData mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req ctx <- readMVar mvarCtx let cwd = workspaceDebugContext ctx@@ -566,21 +657,23 @@ resBody <- insert bps resSeq <- incResSeq mvarCtx- let res = J.defaultSetBreakpointsResponse resSeq req+ let res = J.defaultSetBreakpointsResponse resSeq req resStr = J.encode res{J.bodySetBreakpointsResponse = J.SetBreakpointsResponseBody resBody}- sendResponse resStr+ sendResponseL resStr resSeq <- incResSeq mvarCtx let stopEvt = J.defaultStoppedEvent resSeq stopEvtStr = J.encode stopEvt- sendEvent stopEvtStr+ sendEventL stopEvtStr where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "setBreakpointsHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg + putStrLnStderr mvarCtx msg convBp cwd path (J.SourceBreakpoint lineNo _ cond) = BreakPointData {@@ -605,7 +698,6 @@ insert reqBps = do- results <- mapM insertInternal reqBps let addBps = filter (\(_, (J.Breakpoint _ verified _ _ _ _)) -> verified) results resData = map snd results@@ -620,8 +712,8 @@ return resData - insertInternal reqBp@(BreakPointData modName filePath lineNo _ _) = do + insertInternal reqBp@(BreakPointData modName filePath lineNo _ _) = do let src = J.Source (Just modName) filePath Nothing Nothing addBreakPointOnCUI cmdData mvarCtx reqBp >>= \case@@ -635,21 +727,26 @@ -- threadsHandler :: DebugCommandData -> MVar DebugContext -> J.ThreadsRequest -> IO () threadsHandler _ mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req+ resSeq <- incResSeq mvarCtx let resStr = J.encode $ J.defaultThreadsResponse resSeq req- sendResponse resStr+ sendResponseL resStr where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "threadsHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["threads request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorThreadsResponse resSeq req msg + putStrLnStderr mvarCtx msg -- | -- -- scopesHandler :: DebugCommandData -> MVar DebugContext -> J.ScopesRequest -> IO () scopesHandler cmdData mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req let args = J.argumentsScopesRequest req traceId = J.frameIdScopesArguments args@@ -658,77 +755,52 @@ resSeq <- incResSeq mvarCtx let resStr = J.encode $ J.defaultScopesResponse resSeq req- sendResponse resStr+ sendResponseL resStr where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "scopesHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["scopes request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorScopesResponse resSeq req msg + putStrLnStderr mvarCtx msg -- | -- ---moveFrame :: DebugCommandData -> MVar DebugContext -> Int -> IO ()-moveFrame cmdData mvarCtx traceId = do- ctx <- readMVar mvarCtx- let curTraceId = currentFrameIdDebugContext ctx- moveCount = curTraceId - traceId- traceCmd = if 0 > moveCount then traceForwardDebugCommandData cmdData- else traceBackDebugCommandData cmdData- getResult = readDebugCommandData cmdData-- _ <- foldM (go traceCmd getResult) (""::String) [1..(abs moveCount)]-- ctx <- takeMVar mvarCtx- putMVar mvarCtx ctx{currentFrameIdDebugContext = traceId}-- where- go traceCmd getResult _ _ = do-- cmdStr <- traceCmd- infoM _LOG_NAME cmdStr- putStrLnStdout mvarCtx cmdStr-- cmdStr <- getResult- infoM _LOG_NAME cmdStr- putStrStdout mvarCtx cmdStr-- return cmdStr---- |------ variablesHandler :: DebugCommandData -> MVar DebugContext -> J.VariablesRequest -> IO () variablesHandler cmdData mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req vals <- currentBindings resSeq <- incResSeq mvarCtx let res = J.defaultVariablesResponse resSeq req resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals}- sendResponse resStr+ sendResponseL resStr where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "scopesHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["variables request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorVariablesResponse resSeq req msg + putStrLnStderr mvarCtx msg currentBindings = do let bindings = bindingsDebugCommandData cmdData getResult = readDebugCommandData cmdData + prmpt <- envGetPromptDebugCommandData cmdData+ cmdStr <- bindings infoM _LOG_NAME cmdStr- -- putStrLnStdout mvarCtx cmdStr bindStr <- getResult infoM _LOG_NAME bindStr- -- putStrStdout mvarCtx bindStr - case getBindingDataList bindStr of+ case getBindingDataList prmpt bindStr of Left err -> do errorM _LOG_NAME $ show err putStrLnStderr mvarCtx $ show err@@ -744,6 +816,8 @@ -- stackTraceHandler :: DebugCommandData -> MVar DebugContext -> J.StackTraceRequest -> IO () stackTraceHandler cmdData mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req+ ctx <- readMVar mvarCtx case debugStoppedPosDebugContext ctx of Nothing -> do@@ -751,7 +825,7 @@ let body = J.StackTraceBody [] 0 res = J.defaultStackTraceResponse resSeq req resStr = J.encode $ res{J.bodyStackTraceResponse = body}- sendResponse resStr+ sendResponseL resStr Just rangeData -> do resSeq <- incResSeq mvarCtx@@ -762,13 +836,15 @@ let body = J.StackTraceBody (reverse frames) (length frames) res = J.defaultStackTraceResponse resSeq req resStr = J.encode $ res{J.bodyStackTraceResponse = body}- sendResponse resStr+ sendResponseL resStr where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "stackTraceHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["stackTrace request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorStackTraceResponse resSeq req msg + putStrLnStderr mvarCtx msg createStackFrames (HighlightTextRangeData file sl sc _ _) = do@@ -781,23 +857,22 @@ cmdStr <- history infoM _LOG_NAME cmdStr- -- putStrLnStdout mvarCtx cmdStr traceStr <- getResult infoM _LOG_NAME traceStr- -- putStrStdout mvarCtx traceStr case getTraceDataList traceStr of Left err -> do errorM _LOG_NAME $ show err- -- putStrLnStderr mvarCtx $ show err+ putStrLnStderr mvarCtx $ show err return [csf] Right dats -> foldM (convTrace2Frame cwd) [csf] dats convTrace2Frame cwd xs (TraceData traceId _ filePath) = case parse parseHighlightTextRange "getActivatePosFromLine" filePath of Left err -> do- infoM _LOG_NAME $ show err+ errorM _LOG_NAME $ show err+ putStrLnStderr mvarCtx $ show err return xs Right (HighlightTextRangeData file sl sc _ _) -> return $ J.StackFrame (read traceId) traceId (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc : xs@@ -807,6 +882,7 @@ -- evaluateHandler :: DebugCommandData -> MVar DebugContext -> J.EvaluateRequest -> IO () evaluateHandler cmdData mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req let (J.EvaluateArguments exp frameId ctx) = J.argumentsEvaluateRequest req @@ -817,28 +893,29 @@ where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "continueHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["evaluate request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorEvaluateResponse resSeq req msg + putStrLnStderr mvarCtx msg + eval "watch" exp = do let forceVar = forceDebugCommandData cmdData getResult = readDebugCommandData cmdData cmdStr <- forceVar exp infoM _LOG_NAME cmdStr- -- putStrLnStdout mvarCtx cmdStr cmdStr <- getResult infoM _LOG_NAME cmdStr- -- putStrStdout mvarCtx cmdStr - let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr+ let result = normalizeResult cmdStr resSeq <- incResSeq mvarCtx let body = J.EvaluateBody result 0 res = J.defaultEvaluateResponse resSeq req resStr = J.encode res{J.bodyEvaluateResponse = body}- sendResponse resStr+ sendResponseL resStr eval "hover" exp = do@@ -846,41 +923,46 @@ getResult = readDebugCommandData cmdData cmdStr <- info exp+ putStrLnStdout mvarCtx cmdStr infoM _LOG_NAME cmdStr cmdStr <- getResult+ putStrStdout mvarCtx cmdStr infoM _LOG_NAME cmdStr - let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr+ let result = normalizeResult cmdStr resSeq <- incResSeq mvarCtx let body = J.EvaluateBody result 0 res = J.defaultEvaluateResponse resSeq req resStr = J.encode res{J.bodyEvaluateResponse = body}- sendResponse resStr+ sendResponseL resStr eval _ exp = do let exec = execCommandData cmdData getResult = readDebugCommandData cmdData + prmpt <- envGetPromptDebugCommandData cmdData+ cmdStr <- exec exp infoM _LOG_NAME cmdStr cmdStr <- getResult infoM _LOG_NAME cmdStr - let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr+ -- promptを消す+ let result = unlines . init . lines $ cmdStr resSeq <- incResSeq mvarCtx let body = J.EvaluateBody result 0 res = J.defaultEvaluateResponse resSeq req resStr = J.encode res{J.bodyEvaluateResponse = body}- sendResponse resStr+ sendResponseL resStr - putStrStdout mvarCtx $ "\n" ++ _PHOITYNE_GHCI_PROMPT-+ putStrStdout mvarCtx $ "\n" ++ prmpt + normalizeResult = L.intercalate " " . filter (not . startswith "***"). filter (not . null) . map (replace "\t" "") . map strip . init . lines -- |@@ -888,156 +970,21 @@ -- continueHandler :: DebugCommandData -> MVar DebugContext -> J.ContinueRequest -> IO () continueHandler cmdData mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req+ resSeq <- incResSeq mvarCtx let resStr = J.encode $ J.defaultContinueResponse resSeq req- sendResponse resStr+ sendResponseL resStr startDebug cmdData mvarCtx where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "continueHandler:" ++ show e- errorM _LOG_NAME msg----- |-------startDebug :: DebugCommandData -> MVar DebugContext -> IO ()-startDebug cmdData mvarCtx = do- ctx <- readMVar mvarCtx- let started = debugStartedDebugContext ctx- - startDebugInternal started--- where- startDebugInternal True = do- let continue = continueDebugCommandData cmdData- getResult = readDebugCommandData cmdData- - cmdStr <- continue True- infoM _LOG_NAME cmdStr- putStrLnStdout mvarCtx cmdStr-- cmdStr <- getResult- infoM _LOG_NAME cmdStr- putStrStdout mvarCtx cmdStr-- sendEventByDebugStopStatus cmdData mvarCtx cmdStr -- startDebugInternal False = do- ctx <- readMVar mvarCtx- withModified $ modifiedDebugContext ctx-- withModified True = do- resSeq <- incResSeq mvarCtx- let terminatedEvt = J.defaultTerminatedEvent resSeq- terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True}- sendEvent terminatedEvtStr- - withModified False = do- let getResult = readDebugCommandData cmdData- runDebug = runDebugCommandData cmdData- - cmdStr <- runDebug True- infoM _LOG_NAME cmdStr- putStrLnStdout mvarCtx cmdStr- - cmdStr <- getResult- infoM _LOG_NAME cmdStr- putStrStdout mvarCtx cmdStr--- ctx <- takeMVar mvarCtx- putMVar mvarCtx ctx{currentFrameIdDebugContext = 0, debugStartedDebugContext = True}-- sendEventByDebugStopStatus cmdData mvarCtx cmdStr----- |-------sendEventByDebugStopStatus :: DebugCommandData -> MVar DebugContext -> String -> IO ()-sendEventByDebugStopStatus cmdData mvarCtx cmdStr = case getStoppedTextRangeData cmdStr of- Left err -> do- infoM _LOG_NAME $ show err- --putStrLnStdout mvarCtx $ show err-- resSeq <- incResSeq mvarCtx- let terminatedEvt = J.defaultTerminatedEvent resSeq- terminatedEvtStr = J.encode terminatedEvt- sendEvent terminatedEvtStr-- Right pos -> continueWithHighlightTextRangeData cmdData mvarCtx pos----- |-------continueWithHighlightTextRangeData :: DebugCommandData -> MVar DebugContext -> HighlightTextRangeData -> IO ()-continueWithHighlightTextRangeData cmdData mvarCtx pos = do- ctx <- readMVar mvarCtx-- let bpKey = getKeyOfHighlightTextRangeData pos- bpMap = breakPointDatasDebugContext ctx-- case MAP.lookup bpKey bpMap of- Nothing -> do- errorM _LOG_NAME $ "breakpoint not found." ++ show bpKey- sendStopEvent- Just condCmd -> continueWithCondCmd $ conditionBreakPointData condCmd-- where-- -- |- --- continueWithCondCmd Nothing = do- infoM _LOG_NAME "no condition breakpoint"- sendStopEvent- continueWithCondCmd (Just condStr) = do- - let condition = execCommandData cmdData- getResult = readDebugCommandData cmdData-- _ <- condition condStr- infoM _LOG_NAME condStr- putStrLnStdout mvarCtx condStr-- cmdStr <- getResult- infoM _LOG_NAME cmdStr- putStrStdout mvarCtx cmdStr-- condRes <- getConditionResult cmdStr-- continueWithCondResult condRes-- -- |- --- continueWithCondResult False = startDebug cmdData mvarCtx- continueWithCondResult True = sendStopEvent-- -- |- --- getConditionResult res- | L.isPrefixOf "True" res = return True- | L.isPrefixOf "False" res = return False- | otherwise = warningM _LOG_NAME ("invalid condition result. " ++ res) >> return True--- -- |- --- sendStopEvent = do- infoM _LOG_NAME $ show pos- - ctx <- takeMVar mvarCtx- putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos}- + let msg = L.intercalate " " ["continue request error.", show req, show e] resSeq <- incResSeq mvarCtx- let stopEvt = J.defaultStoppedEvent resSeq- stopEvtStr = J.encode stopEvt- sendEvent stopEvtStr+ sendResponseL $ J.encode $ J.errorContinueResponse resSeq req msg + putStrLnStderr mvarCtx msg -- |@@ -1045,20 +992,24 @@ -- stepOverHandler :: DebugCommandData -> MVar DebugContext -> J.NextRequest -> IO () stepOverHandler cmdData mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req+ ctx <- readMVar mvarCtx case debugStoppedPosDebugContext ctx of Nothing -> do resSeq <- incResSeq mvarCtx let res = J.defaultNextResponse resSeq req resStr = J.encode res{J.successNextResponse = False, J.messageNextResponse = "debug is initialized but not started yet. press F5(continue)."}- sendResponse resStr+ sendResponseL resStr Just _ -> stepOver where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "continueHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["stepOver request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorNextResponse resSeq req msg + putStrLnStderr mvarCtx msg stepOver = do let step = stepOverDebugCommandData cmdData@@ -1089,12 +1040,12 @@ resSeq <- incResSeq mvarCtx let res = J.defaultNextResponse resSeq req resStr = J.encode res- sendResponse resStr+ sendResponseL resStr resSeq <- incResSeq mvarCtx let stopEvt = J.defaultStoppedEvent resSeq stopEvtStr = J.encode stopEvt- sendEvent stopEvtStr+ sendEventL stopEvtStr -- |@@ -1102,21 +1053,26 @@ -- stepInHandler :: DebugCommandData -> MVar DebugContext -> J.StepInRequest -> IO () stepInHandler cmdData mvarCtx req = flip E.catches handlers $ do+ logRequest $ show req+ ctx <- readMVar mvarCtx case debugStoppedPosDebugContext ctx of Nothing -> do resSeq <- incResSeq mvarCtx let res = J.defaultStepInResponse resSeq req resStr = J.encode res{J.successStepInResponse = False, J.messageStepInResponse = "debug is initialized but not started yet. press F5(continue)."}- sendResponse resStr+ sendResponseL resStr Just _ -> stepIn where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do- let msg = "continueHandler:" ++ show e- errorM _LOG_NAME msg+ let msg = L.intercalate " " ["stepIn request error.", show req, show e]+ resSeq <- incResSeq mvarCtx+ sendResponseL $ J.encode $ J.errorStepInResponse resSeq req msg + putStrLnStderr mvarCtx msg + stepIn = do let step = stepDebugCommandData cmdData getResult = readDebugCommandData cmdData@@ -1137,7 +1093,7 @@ resSeq <- incResSeq mvarCtx let terminatedEvt = J.defaultTerminatedEvent resSeq terminatedEvtStr = J.encode terminatedEvt- sendEvent terminatedEvtStr+ sendEventL terminatedEvtStr Right pos -> do ctx <- takeMVar mvarCtx@@ -1146,12 +1102,12 @@ resSeq <- incResSeq mvarCtx let res = J.defaultStepInResponse resSeq req resStr = J.encode res- sendResponse resStr+ sendResponseL resStr resSeq <- incResSeq mvarCtx let stopEvt = J.defaultStoppedEvent resSeq stopEvtStr = J.encode stopEvt- sendEvent stopEvtStr+ sendEventL stopEvtStr @@ -1209,7 +1165,16 @@ sendEvent outEvtStr +-- |+--+--+logRequest :: String -> IO ()+logRequest reqStr = do+ let msg = L.intercalate " " ["[REQUEST]", reqStr]+ infoM _LOG_NAME msg ++ -- | -- --@@ -1310,6 +1275,8 @@ cmdStr <- getResult putStrStdout mvarCtx cmdStr infoM _LOG_NAME cmdStr+ + loadModule (last cont) return True | startswith "Failed," (last cont) -> do cmdStr <- getResult@@ -1331,7 +1298,22 @@ curStr | null acc = "" | otherwise = last acc + -- | + -- Ok, modules loaded: Lib, Main, LibSpec.+ -- -> : module +Lib Main LibSpec+ loadModule str = do+ let loadModule = moduleDebugCommandData cmdData+ getResult = readDebugCommandData cmdData+ args = replace "," "" $ replace "Ok, modules loaded: " "+" $ init $ strip str+ + cmdStr <- loadModule args+ putStrLnStdout mvarCtx cmdStr+ infoM _LOG_NAME cmdStr + cmdStr <- getResult+ putStrStdout mvarCtx cmdStr+ infoM _LOG_NAME cmdStr+ -- | -- ブレークポイントをGHCi上でdeleteする --@@ -1358,17 +1340,17 @@ -- GHCi上でブレークポイントを追加する -- addBreakPointOnCUI :: DebugCommandData -> MVar DebugContext -> BreakPointData -> IO (Either String Int)-addBreakPointOnCUI cmdData _ (BreakPointData modName _ lineNo _ _) = do+addBreakPointOnCUI cmdData mvarCtx (BreakPointData modName _ lineNo _ _) = do let setBreak = breakDebugCommandData cmdData getResult = readDebugCommandData cmdData cmdStr <- setBreak modName lineNo- -- putStrLnStdout mvarCtx cmdStr+ putStrLnStdout mvarCtx cmdStr infoM _LOG_NAME cmdStr cmdStr <- getResult- -- putStrStdout mvarCtx cmdStr+ putStrStdout mvarCtx cmdStr infoM _LOG_NAME cmdStr case getBreakPointNo cmdStr of@@ -1395,6 +1377,247 @@ return $ read no +-- |+-- Loggerのセットアップ+-- +setupLogger :: FilePath -> Priority -> IO ()+setupLogger logFile level = do+-- level <- case readMay logLevel of+-- Just a -> return a+-- Nothing -> E.throwIO . E.userError $ "invalid log level[" ++ logLevel ++ "]"++ logStream <- openFile logFile AppendMode+ hSetEncoding logStream utf8++ logH <- LHS.streamHandler logStream level+ + let logHandle = logH {LHS.closeFunc = hClose}+ logFormat = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT+ logHandler = LH.setFormatter logHandle logFormat++ L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle])+ L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler]+ L.updateGlobalLogger _LOG_NAME $ L.setLevel level+++-- |+--+-- +watch :: DebugCommandData -> MVar DebugContext -> IO ()+watch cmdData mvarCtx = do+ _ <- forkIO $ watchFiles cmdData mvarCtx+ return ()++watchFiles :: DebugCommandData -> MVar DebugContext -> IO ()+watchFiles cmdData mvarCtx = do+ FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce = FSN.Debounce 1} $ \mgr -> do++ ctx <- readMVar mvarCtx+ let dir = workspaceDebugContext ctx+ + infoM _LOG_NAME $ "start watch files in [" ++ dir ++ "]"+ _ <- FSN.watchTree mgr dir hsFilter action+ + forever $ threadDelay 1000000++ return ()+ + where+ hsFilter event = endswith _HS_FILE_EXT $ FSN.eventPath event++ action event = do++ ctx <- readMVar mvarCtx+ withDebugStarted event $ debugStartedDebugContext ctx++ withDebugStarted _ True = do+ resSeq <- incResSeq mvarCtx+ let terminatedEvt = J.defaultTerminatedEvent resSeq+ terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True}+ sendEvent terminatedEvtStr++ withDebugStarted event False = do+ ctx <- takeMVar mvarCtx+ putMVar mvarCtx ctx{modifiedDebugContext = True}+ loadHsFile cmdData mvarCtx (FSN.eventPath event) >> return ()+++-- |+--+--+moveFrame :: DebugCommandData -> MVar DebugContext -> Int -> IO ()+moveFrame cmdData mvarCtx traceId = do+ ctx <- readMVar mvarCtx+ let curTraceId = currentFrameIdDebugContext ctx+ moveCount = curTraceId - traceId+ traceCmd = if 0 > moveCount then traceForwardDebugCommandData cmdData+ else traceBackDebugCommandData cmdData+ getResult = readDebugCommandData cmdData++ _ <- foldM (go traceCmd getResult) (""::String) [1..(abs moveCount)]++ ctx <- takeMVar mvarCtx+ putMVar mvarCtx ctx{currentFrameIdDebugContext = traceId}++ where+ go traceCmd getResult _ _ = do++ cmdStr <- traceCmd+ infoM _LOG_NAME cmdStr+ putStrLnStdout mvarCtx cmdStr++ cmdStr <- getResult+ infoM _LOG_NAME cmdStr+ putStrStdout mvarCtx cmdStr++ return cmdStr+++-- |+--+--+startDebug :: DebugCommandData -> MVar DebugContext -> IO ()+startDebug cmdData mvarCtx = do+ ctx <- readMVar mvarCtx+ let started = debugStartedDebugContext ctx+ + startDebugInternal started+++ where+ startDebugInternal True = do+ let continue = continueDebugCommandData cmdData+ getResult = readDebugCommandData cmdData+ + cmdStr <- continue True+ infoM _LOG_NAME cmdStr+ putStrLnStdout mvarCtx cmdStr++ cmdStr <- getResult+ infoM _LOG_NAME cmdStr+ putStrStdout mvarCtx cmdStr++ sendEventByDebugStopStatus cmdData mvarCtx cmdStr ++ startDebugInternal False = do+ ctx <- readMVar mvarCtx+ withModified $ modifiedDebugContext ctx++ withModified True = do+ resSeq <- incResSeq mvarCtx+ let terminatedEvt = J.defaultTerminatedEvent resSeq+ terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True}+ sendEvent terminatedEvtStr+ + withModified False = do+ let getResult = readDebugCommandData cmdData+ runDebug = runDebugCommandData cmdData+ + cmdStr <- runDebug True+ infoM _LOG_NAME cmdStr+ putStrLnStdout mvarCtx cmdStr+ + cmdStr <- getResult+ infoM _LOG_NAME cmdStr+ putStrStdout mvarCtx cmdStr+++ ctx <- takeMVar mvarCtx+ putMVar mvarCtx ctx{currentFrameIdDebugContext = 0, debugStartedDebugContext = True}++ sendEventByDebugStopStatus cmdData mvarCtx cmdStr+++++-- |+--+--+sendEventByDebugStopStatus :: DebugCommandData -> MVar DebugContext -> String -> IO ()+sendEventByDebugStopStatus cmdData mvarCtx cmdStr = case getStoppedTextRangeData cmdStr of+ Left err -> do+ infoM _LOG_NAME $ show err+ --putStrLnStdout mvarCtx $ show err++ resSeq <- incResSeq mvarCtx+ let terminatedEvt = J.defaultTerminatedEvent resSeq+ terminatedEvtStr = J.encode terminatedEvt+ sendEvent terminatedEvtStr++ Right pos -> continueWithHighlightTextRangeData cmdData mvarCtx pos+++-- |+--+--+continueWithHighlightTextRangeData :: DebugCommandData -> MVar DebugContext -> HighlightTextRangeData -> IO ()+continueWithHighlightTextRangeData cmdData mvarCtx pos = do+ ctx <- readMVar mvarCtx++ let bpKey = getKeyOfHighlightTextRangeData pos+ bpMap = breakPointDatasDebugContext ctx++ case MAP.lookup bpKey bpMap of+ Nothing -> do+ errorM _LOG_NAME $ "breakpoint not found." ++ show bpKey+ sendStopEvent+ Just condCmd -> continueWithCondCmd $ conditionBreakPointData condCmd++ where++ -- |+ --+ continueWithCondCmd Nothing = do+ infoM _LOG_NAME "no condition breakpoint"+ sendStopEvent+ continueWithCondCmd (Just condStr) = do+ + let condition = execCommandData cmdData+ getResult = readDebugCommandData cmdData++ _ <- condition condStr+ infoM _LOG_NAME condStr+ putStrLnStdout mvarCtx condStr++ cmdStr <- getResult+ infoM _LOG_NAME cmdStr+ putStrStdout mvarCtx cmdStr++ condRes <- getConditionResult cmdStr++ continueWithCondResult condRes++ -- |+ --+ continueWithCondResult False = startDebug cmdData mvarCtx+ continueWithCondResult True = sendStopEvent++ -- |+ --+ getConditionResult res+ | L.isPrefixOf "True" res = return True+ | L.isPrefixOf "False" res = return False+ | otherwise = warningM _LOG_NAME ("invalid condition result. " ++ res) >> return True+++ -- |+ --+ sendStopEvent = do+ infoM _LOG_NAME $ show pos+ + ctx <- takeMVar mvarCtx+ putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos}+ + resSeq <- incResSeq mvarCtx+ let stopEvt = J.defaultStoppedEvent resSeq+ stopEvtStr = J.encode stopEvt+ sendEvent stopEvtStr++++++ -- |===================================================================== -- -- パーサ@@ -1483,10 +1706,10 @@ -- args :: Project.Argument.ArgData = _ -- _result :: IO Data.ConfigFile.Types.ConfigParser = _ ---getBindingDataList :: String -> Either ParseError [BindingData]-getBindingDataList res = parse parser "getBindingDataList" res+getBindingDataList :: String -> String -> Either ParseError [BindingData]+getBindingDataList prmpt res = parse parser "getBindingDataList" res where- parser = manyTill parser1 (string _PHOITYNE_GHCI_PROMPT)+ parser = manyTill parser1 (string prmpt) parser1 = do varName <- manyTill anyChar (string "::")
app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs view
@@ -30,3 +30,14 @@ ContinueResponse seq "response" reqSeq True "continue" "" +-- |+--+parceErrorContinueResponse :: Int -> String -> ContinueResponse+parceErrorContinueResponse seq msg =+ ContinueResponse seq "response" (-1) False "continue" msg++-- |+--+errorContinueResponse :: Int -> ContinueRequest -> String -> ContinueResponse+errorContinueResponse seq (ContinueRequest reqSeq _ _ _) msg =+ ContinueResponse seq "response" reqSeq False "continue" msg
app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs view
@@ -28,3 +28,15 @@ defaultDisconnectResponse :: Int -> DisconnectRequest -> DisconnectResponse defaultDisconnectResponse seq (DisconnectRequest reqSeq _ _ _) = DisconnectResponse seq "response" reqSeq True "disconnect" ""++-- |+--+parceErrorDisconnectResponse :: Int -> String -> DisconnectResponse+parceErrorDisconnectResponse seq msg =+ DisconnectResponse seq "response" (-1) False "disconnect" msg++-- |+--+errorDisconnectResponse :: Int -> DisconnectRequest -> String -> DisconnectResponse+errorDisconnectResponse seq (DisconnectRequest reqSeq _ _ _) msg =+ DisconnectResponse seq "response" reqSeq False "disconnect" msg
app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs view
@@ -32,3 +32,9 @@ defaultEvaluateResponse seq (EvaluateRequest reqSeq _ _ _) = EvaluateResponse seq "response" reqSeq True "evaluate" "" defaultEvaluateBody +-- |+--+errorEvaluateResponse :: Int -> EvaluateRequest -> String -> EvaluateResponse+errorEvaluateResponse seq (EvaluateRequest reqSeq _ _ _) msg =+ EvaluateResponse seq "response" reqSeq False "evaluate" msg defaultEvaluateBody+
app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs view
@@ -21,3 +21,9 @@ } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilites") } ''InitializeResponseCapabilites)++-- |+--+defaultInitializeResponseCapabilites :: InitializeResponseCapabilites+defaultInitializeResponseCapabilites = InitializeResponseCapabilites False False False False []+
app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs view
@@ -7,6 +7,7 @@ import Phoityne.Utility import Phoityne.IO.GUI.VSCode.TH.InitializeResponseCapabilitesJSON+import Phoityne.IO.GUI.VSCode.TH.InitializeRequestJSON -- | -- Server-initiated response to client request@@ -23,3 +24,17 @@ } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponse") } ''InitializeResponse)+++-- |+--+parseErrorInitializeResponse :: Int -> String -> InitializeResponse+parseErrorInitializeResponse seq msg =+ InitializeResponse seq "response" seq False "initialize" msg defaultInitializeResponseCapabilites++-- |+--+errorInitializeResponse :: Int -> InitializeRequest -> String -> InitializeResponse+errorInitializeResponse seq (InitializeRequest reqSeq _ _ _) msg =+ InitializeResponse seq "response" reqSeq False "initialize" msg defaultInitializeResponseCapabilites+
app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs view
@@ -12,12 +12,15 @@ -- data LaunchRequestArguments = LaunchRequestArguments {- noDebugLaunchRequestArguments :: Bool -- If noDebug is true the launch request should launch the program without enabling debugging.- , nameLaunchRequestArguments :: String -- Phoityne specific argument.- , typeLaunchRequestArguments :: String -- Phoityne specific argument.- , requestLaunchRequestArguments :: String -- Phoityne specific argument. must be "request"- , startupLaunchRequestArguments :: String -- Phoityne specific argument.- , workspaceLaunchRequestArguments :: String -- Phoityne specific argument.+ noDebugLaunchRequestArguments :: Bool -- If noDebug is true the launch request should launch the program without enabling debugging.+ , nameLaunchRequestArguments :: String -- Phoityne specific argument.+ , typeLaunchRequestArguments :: String -- Phoityne specific argument.+ , requestLaunchRequestArguments :: String -- Phoityne specific argument. must be "request"+ , startupLaunchRequestArguments :: String -- Phoityne specific argument.+ , workspaceLaunchRequestArguments :: String -- Phoityne specific argument.+ , logFileLaunchRequestArguments :: String -- Phoityne specific argument.+ , logLevelLaunchRequestArguments :: String -- Phoityne specific argument.+ , ghciPromptLaunchRequestArguments :: String -- Phoityne specific argument. } deriving (Show, Read, Eq)
app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs view
@@ -30,5 +30,17 @@ defaultLaunchResponse seq (LaunchRequest reqSeq _ _ _) = LaunchResponse seq "response" reqSeq True "launch" "" +-- |+--+parceErrorLaunchResponse :: Int -> String -> LaunchResponse+parceErrorLaunchResponse seq msg =+ LaunchResponse seq "response" seq False "launch" msg++-- |+--+errorLaunchResponse :: Int -> LaunchRequest -> String -> LaunchResponse+errorLaunchResponse seq (LaunchRequest reqSeq _ _ _) msg =+ LaunchResponse seq "response" reqSeq False "launch" msg+
app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs view
@@ -30,5 +30,11 @@ NextResponse seq "response" reqSeq True "next" "" +-- |+--+errorNextResponse :: Int -> NextRequest -> String -> NextResponse+errorNextResponse seq (NextRequest reqSeq _ _ _) msg =+ NextResponse seq "response" reqSeq False "next" msg+
app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs view
@@ -33,3 +33,9 @@ ScopesResponse seq "response" reqSeq True "scopes" "" defaultScopesBody +-- |+--+errorScopesResponse :: Int -> ScopesRequest -> String -> ScopesResponse+errorScopesResponse seq (ScopesRequest reqSeq _ _ _) msg =+ ScopesResponse seq "response" reqSeq False "scopes" msg defaultScopesBody+
app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs view
@@ -37,3 +37,9 @@ SetBreakpointsResponse seq "response" reqSeq True "setBreakpoints" "" defaultSetBreakpointsResponseBody +-- |+--+errorSetBreakpointsResponse :: Int -> SetBreakpointsRequest -> String -> SetBreakpointsResponse+errorSetBreakpointsResponse seq (SetBreakpointsRequest reqSeq _ _ _) msg =+ SetBreakpointsResponse seq "response" reqSeq False "setBreakpoints" msg defaultSetBreakpointsResponseBody+
app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs view
@@ -32,3 +32,9 @@ StackTraceResponse seq "response" reqSeq True "stackTrace" "" defaultStackTraceBody +-- |+--+errorStackTraceResponse :: Int -> StackTraceRequest -> String -> StackTraceResponse+errorStackTraceResponse seq (StackTraceRequest reqSeq _ _ _) msg =+ StackTraceResponse seq "response" reqSeq False "stackTrace" msg defaultStackTraceBody+
app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs view
@@ -30,3 +30,9 @@ StepInResponse seq "response" reqSeq True "stepIn" "" +-- |+--+errorStepInResponse :: Int -> StepInRequest -> String -> StepInResponse+errorStepInResponse seq (StepInRequest reqSeq _ _ _) msg =+ StepInResponse seq "response" reqSeq False "stepIn" msg+
app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs view
@@ -31,5 +31,10 @@ StepOutResponse seq "response" reqSeq True "stepOut" "" +-- |+--+errorStepOutResponse :: Int -> StepOutRequest -> String -> StepOutResponse+errorStepOutResponse seq (StepOutRequest reqSeq _ _ _) msg =+ StepOutResponse seq "response" reqSeq False "stepOut" msg
app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs view
@@ -34,5 +34,9 @@ ThreadsResponse seq "response" reqSeq True "threads" "" defaultThreadsResponseBody -+-- |+--+errorThreadsResponse :: Int -> ThreadsRequest -> String -> ThreadsResponse+errorThreadsResponse seq (ThreadsRequest reqSeq _ _) msg =+ ThreadsResponse seq "response" reqSeq False "threads" msg defaultThreadsResponseBody
app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs view
@@ -33,5 +33,10 @@ defaultVariablesResponse seq (VariablesRequest reqSeq _ _ _) = VariablesResponse seq "response" reqSeq True "variables" "" defaultVariablesBody +-- |+--+errorVariablesResponse :: Int -> VariablesRequest -> String -> VariablesResponse+errorVariablesResponse seq (VariablesRequest reqSeq _ _ _) msg =+ VariablesResponse seq "response" reqSeq False "variables" msg defaultVariablesBody
app/Phoityne/IO/Main.hs view
@@ -4,23 +4,17 @@ module Phoityne.IO.Main (run) where -- モジュール-import Phoityne.Constant import qualified Phoityne.Argument as A import qualified Phoityne.IO.Control as CTRL -- システム-import System.IO import Data.Either.Utils-import Safe import qualified Control.Exception as E-import qualified System.IO.Error as E import qualified Data.ConfigFile as C import qualified System.Console.CmdArgs as CMD import qualified System.Log.Logger as L-import qualified System.Log.Formatter as L-import qualified System.Log.Handler as LH-import qualified System.Log.Handler.Simple as LHS + -- | -- アプリケーションメイン -- @@ -33,9 +27,6 @@ -- INI設定ファイルのRead iniSet <- loadIniFile args - -- Loggerのセットアップ- setupLogger iniSet- -- ロジック実行 flip E.finally finalProc $ do CTRL.run args iniSet@@ -50,6 +41,7 @@ ioExcept (e :: E.IOException) = print e >> return 1 someExcept (e :: E.SomeException) = print e >> return 1 + -- | -- 引数データの取得 -- @@ -61,6 +53,7 @@ | "ExitSuccess" == show e -> E.throw A.HelpExitException | otherwise -> E.throwIO e + -- | -- INI設定ファイルデータの取得 -- @@ -72,13 +65,14 @@ return cp{ C.accessfunc = C.interpolatingAccess 5 } + -- | -- デフォルトINI設定 -- defaultIniSetting :: String defaultIniSetting = unlines [ "[DEFAULT]"- , "work_dir = C:/temp/"+ , "work_dir = ./" , "" , "[LOG]" , "file = %(work_dir)sphoityne.log"@@ -86,30 +80,4 @@ , "" , "[PHOITYNE]" ]---- |--- Loggerのセットアップ--- -setupLogger :: C.ConfigParser -- INI設定- -> IO () -- なし-setupLogger cp = do- let logFile = forceEither $ C.get cp _INI_SEC_LOG _INI_LOG_FILE- logLevel = forceEither $ C.get cp _INI_SEC_LOG _INI_LOG_LEVEL-- level <- case readMay logLevel of- Just a -> return a- Nothing -> E.throwIO . E.userError $ "invalid log level[" ++ logLevel ++ "]"-- logStream <- openFile logFile AppendMode- hSetEncoding logStream utf8-- logH <- LHS.streamHandler logStream level- - let logHandle = logH {LHS.closeFunc = hClose}- logFormat = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT- logHandler = LH.setFormatter logHandle logFormat-- L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle])- L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler]- L.updateGlobalLogger _LOG_NAME $ L.setLevel level
phoityne-vscode.cabal view
@@ -1,12 +1,12 @@ name: phoityne-vscode-version: 0.0.2.0+version: 0.0.3.0 synopsis: ghci debug viewer on Visual Studio Code description: Please see README.md license: BSD3 license-file: LICENSE author: phoityne_hs maintainer: phoityne.hs@gmail.com-homepage: https://sites.google.com/site/phoityne/+homepage: https://sites.google.com/site/phoityne/vscode copyright: 2016 phoityne_hs category: Development build-type: Simple
vscode/package.json view
@@ -1,6 +1,6 @@ { "name": "phoityne-vscode",- "displayName": "phoityne",+ "displayName": "Haskell GHCi debug viewer Phoityne", "version": "0.0.1", "publisher": "phoityne.hs", "description": "ghci debug viewer Phoityne, on Visual Studio Code.",@@ -8,9 +8,31 @@ "author": {"name": "phoityne.hs"}, "license": "BSD3", "private": false,- "engines": {"vscode": "^0.10.1"},+ "engines": {"vscode": "^1.0.0"}, "dependencies": {}, "contributes": {+ "keybindings": [+ {+ "key": "f6",+ "command": "workbench.action.tasks.runTask",+ "when": "!inDebugMode"+ },+ {+ "key": "shift+f6",+ "command": "workbench.action.tasks.terminate",+ "when": "!inDebugMode"+ },+ {+ "key": "f7",+ "command": "workbench.action.tasks.build",+ "when": "!inDebugMode"+ },+ {+ "key": "f8",+ "command": "workbench.action.tasks.test",+ "when": "!inDebugMode"+ }+ ], "debuggers": [{ "type": "ghc", "label": "ghci debug viewer Phoityne",@@ -29,6 +51,21 @@ "type": "string", "description": "Absolute path to the startup program.", "default": "${workspaceRoot}/test/Spec.hs"+ },+ "logFile": {+ "type": "string",+ "description": "Absolute path to the log file.",+ "default": "${workspaceRoot}/.vscode/phoityne.log"+ },+ "logLevel": {+ "type": "string",+ "description": "logging level.",+ "default": "WARNING"+ },+ "ghciPrompt": {+ "type": "string",+ "description": "ghci prompt string.",+ "default": "Phoityne>>= " } } }@@ -39,7 +76,10 @@ "name": "ghci debug viewer Phoityne", "request": "launch", "workspace": "${workspaceRoot}",- "startup": "${workspaceRoot}/test/Spec.hs"+ "startup": "${workspaceRoot}/test/Spec.hs",+ "logFile": "${workspaceRoot}/.vscode/phoityne.log",+ "logLevel": "WARNING",+ "ghciPrompt": "H>>= " } ] }]