diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,17 +14,13 @@ 5. Set startup source file. Default file is test/Spec.hs 6. Run debug(F5) -[![Demo Video1](https://sites.google.com/site/phoityne/doc_jp/demo01.gif?attredirects=0)](https://sites.google.com/site/phoityne/doc_jp/demo01.gif?attredirects=0) +[![Demo Video1](https://sites.google.com/site/phoityne/doc_jp/demo01.gif)](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 diff --git a/app/Phoityne/IO/Control.hs b/app/Phoityne/IO/Control.hs --- a/app/Phoityne/IO/Control.hs +++ b/app/Phoityne/IO/Control.hs @@ -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 -- | diff --git a/app/Phoityne/IO/GUI/Control.hs b/app/Phoityne/IO/GUI/Control.hs --- a/app/Phoityne/IO/GUI/Control.hs +++ b/app/Phoityne/IO/GUI/Control.hs @@ -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 "::") diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs @@ -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 diff --git a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs @@ -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 diff --git a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs @@ -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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs @@ -21,3 +21,9 @@ } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilites") } ''InitializeResponseCapabilites) + +-- | +-- +defaultInitializeResponseCapabilites :: InitializeResponseCapabilites +defaultInitializeResponseCapabilites = InitializeResponseCapabilites False False False False [] + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs @@ -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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs @@ -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) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs @@ -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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs @@ -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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs @@ -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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs @@ -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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs @@ -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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs @@ -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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs @@ -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 diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs @@ -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 diff --git a/app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs --- a/app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs +++ b/app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs @@ -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 diff --git a/app/Phoityne/IO/Main.hs b/app/Phoityne/IO/Main.hs --- a/app/Phoityne/IO/Main.hs +++ b/app/Phoityne/IO/Main.hs @@ -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 diff --git a/phoityne-vscode.cabal b/phoityne-vscode.cabal --- a/phoityne-vscode.cabal +++ b/phoityne-vscode.cabal @@ -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 diff --git a/vscode/package.json b/vscode/package.json --- a/vscode/package.json +++ b/vscode/package.json @@ -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>>= " } ] }]