diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,11 +7,11 @@ ## Information -* [2016/10/09] phoityne-vscode released. - * Marketplace [phoityne-vscode-0.0.8](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) - * hackage [phoityne-vscode-0.0.10.0](https://hackage.haskell.org/package/phoityne-vscode) +* [2016/12/18] phoityne-vscode released. + * Marketplace [phoityne-vscode-0.0.9](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) + * hackage [phoityne-vscode-0.0.11.0](https://hackage.haskell.org/package/phoityne-vscode) * Release Summary - * Improvements of repl function. And some bug fixes. + * Support "Hit count break condition". And some bug fixes. ![01_debug.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/01_debug.gif) @@ -77,7 +77,18 @@ ![04_condition.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/04_condition.gif) +### Hit count break condition +Supports these operators. +* == +* /= +* <, > +* <=, >= +* mod, % +* just digit is same with '>=' + +![07_hit_count.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/07_hit_count.gif) + ### Repl & Completions ![06_repl.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/06_repl.gif) @@ -87,6 +98,7 @@ * supportsConfigurationDoneRequest : yes * supportsFunctionBreakpoints : yes * supportsConditionalBreakpoints : yes +* supportsHitConditionalBreakpoints : yes * supportsEvaluateForHovers : yes * exceptionBreakpointFilters : no * supportsStepBack : no @@ -95,7 +107,12 @@ * supportsGotoTargetsRequest : no * supportsStepInTargetsRequest : no * supportsCompletionsRequest : yes - +* supportsModulesRequest : no +* additionalModuleColumns : no +* supportedChecksumAlgorithms : no +* supportsRestartRequest : no +* supportsExceptionOptions : no +* supportsValueFormattingOptions : no ## Configuration @@ -120,6 +137,10 @@ ## Version history + +* [2016/10/09] phoityne-vscode released. + * Marketplace [phoityne-vscode-0.0.8](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) + * hackage [phoityne-vscode-0.0.10.0](https://hackage.haskell.org/package/phoityne-vscode) * [2016/09/19] for VSCode-1.5, updated vscode extension and haskell library. Please use new versions. * Marketplace [phoityne-vscode-0.0.7](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) diff --git a/app/Phoityne/VSCode/IO/Core.hs b/app/Phoityne/VSCode/IO/Core.hs --- a/app/Phoityne/VSCode/IO/Core.hs +++ b/app/Phoityne/VSCode/IO/Core.hs @@ -14,1741 +14,1707 @@ , initializeRequestHandler ) where -import Phoityne.VSCode.Constant -import Phoityne.VSCode.Utility -import Phoityne.VSCode.IO.Utility -import qualified Phoityne.VSCode.TH.BreakpointJSON as J -import qualified Phoityne.VSCode.TH.CompletionsItemJSON as J -import qualified Phoityne.VSCode.TH.CompletionsArgumentsJSON as J -import qualified Phoityne.VSCode.TH.CompletionsResponseBodyJSON as J -import qualified Phoityne.VSCode.TH.CompletionsRequestJSON as J -import qualified Phoityne.VSCode.TH.CompletionsResponseJSON as J -import qualified Phoityne.VSCode.TH.ConfigurationDoneRequestJSON as J -import qualified Phoityne.VSCode.TH.ConfigurationDoneResponseJSON as J -import qualified Phoityne.VSCode.TH.ContinueRequestJSON as J -import qualified Phoityne.VSCode.TH.ContinueResponseJSON as J -import qualified Phoityne.VSCode.TH.DisconnectRequestJSON as J -import qualified Phoityne.VSCode.TH.DisconnectResponseJSON as J -import qualified Phoityne.VSCode.TH.EvaluateArgumentsJSON as J -import qualified Phoityne.VSCode.TH.EvaluateBodyJSON as J -import qualified Phoityne.VSCode.TH.EvaluateRequestJSON as J -import qualified Phoityne.VSCode.TH.EvaluateResponseJSON as J -import qualified Phoityne.VSCode.TH.InitializedEventJSON as J -import qualified Phoityne.VSCode.TH.InitializeRequestJSON as J -import qualified Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON as J -import qualified Phoityne.VSCode.TH.InitializeResponseJSON as J -import qualified Phoityne.VSCode.TH.LaunchRequestArgumentsJSON as J -import qualified Phoityne.VSCode.TH.LaunchRequestJSON as J -import qualified Phoityne.VSCode.TH.LaunchResponseJSON as J -import qualified Phoityne.VSCode.TH.NextRequestJSON as J -import qualified Phoityne.VSCode.TH.NextResponseJSON as J -import qualified Phoityne.VSCode.TH.OutputEventJSON as J -import qualified Phoityne.VSCode.TH.OutputEventBodyJSON as J -import qualified Phoityne.VSCode.TH.PauseRequestJSON as J -import qualified Phoityne.VSCode.TH.PauseResponseJSON as J -import qualified Phoityne.VSCode.TH.RequestJSON as J -import qualified Phoityne.VSCode.TH.ScopesArgumentsJSON as J -import qualified Phoityne.VSCode.TH.ScopesRequestJSON as J -import qualified Phoityne.VSCode.TH.ScopesResponseJSON as J -import qualified Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON as J -import qualified Phoityne.VSCode.TH.SetBreakpointsRequestJSON as J -import qualified Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON as J -import qualified Phoityne.VSCode.TH.SetBreakpointsResponseJSON as J -import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON as J -import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON as J -import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON as J -import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseJSON as J -import qualified Phoityne.VSCode.TH.SourceBreakpointJSON as J -import qualified Phoityne.VSCode.TH.FunctionBreakpointJSON as J -import qualified Phoityne.VSCode.TH.SourceJSON as J -import qualified Phoityne.VSCode.TH.SourceRequestJSON as J -import qualified Phoityne.VSCode.TH.SourceResponseJSON as J -import qualified Phoityne.VSCode.TH.StackFrameJSON as J -import qualified Phoityne.VSCode.TH.StackTraceBodyJSON as J -import qualified Phoityne.VSCode.TH.StackTraceRequestJSON as J -import qualified Phoityne.VSCode.TH.StackTraceResponseJSON as J -import qualified Phoityne.VSCode.TH.StepInRequestJSON as J -import qualified Phoityne.VSCode.TH.StepInResponseJSON as J -import qualified Phoityne.VSCode.TH.StepOutRequestJSON as J -import qualified Phoityne.VSCode.TH.StepOutResponseJSON as J -import qualified Phoityne.VSCode.TH.StoppedEventJSON as J -import qualified Phoityne.VSCode.TH.TerminatedEventJSON as J -import qualified Phoityne.VSCode.TH.TerminatedEventBodyJSON as J -import qualified Phoityne.VSCode.TH.ThreadsRequestJSON as J -import qualified Phoityne.VSCode.TH.ThreadsResponseJSON as J -import qualified Phoityne.VSCode.TH.VariableJSON as J -import qualified Phoityne.VSCode.TH.VariablesBodyJSON as J -import qualified Phoityne.VSCode.TH.VariablesRequestJSON as J -import qualified Phoityne.VSCode.TH.VariablesResponseJSON as J - -import qualified Phoityne.GHCi as G - -import System.IO -import System.FilePath -import System.Directory -import System.Log.Logger -import qualified Data.Aeson as J -import qualified Data.ByteString.Lazy as BSL -import qualified Data.String.Utils as U -import qualified Data.List as L -import qualified Control.Exception as E -import qualified Data.Map as MAP -import Control.Concurrent -import Data.List.Split -import Data.Char -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 -import Text.Parsec - --- | --- --- -data DebugContextData = - DebugContextData { - resSeqDebugContextData :: Int - , functionBreakPointDatasDebugContextData :: BreakPointDatas - , breakPointDatasDebugContextData :: BreakPointDatas - , workspaceDebugContextData :: FilePath - , startupDebugContextData :: FilePath - , debugStartedDebugContextData :: Bool - , debugStoppedPosDebugContextData :: Maybe G.SourcePosition - , currentFrameIdDebugContextData :: Int - , modifiedDebugContextData :: Bool - , ghciProcessDebugContextData :: Maybe G.GHCiProcess - , responseHandlerDebugContextData :: BSL.ByteString -> IO () - } - - --- | --- --- -data BreakPointData = - BreakPointData { - nameBreakPointData :: String - , filePathBreakPointData :: FilePath - , lineNoBreakPointData :: Int - , breakNoBreakPointData :: Maybe Int - , conditionBreakPointData :: Maybe String - } deriving (Show, Read, Eq, Ord) - - --- | --- --- -type BreakPointDataKey = (FilePath, Int) - --- | --- --- -type BreakPointDatas = MAP.Map BreakPointDataKey BreakPointData - - --- | --- --- -_INITIAL_RESPONSE_SEQUENCE :: Int -_INITIAL_RESPONSE_SEQUENCE = 0 - - --- | --- --- -_TWO_CRLF :: String -_TWO_CRLF = "\r\n\r\n" - --- | --- --- -_SEP_WIN :: Char -_SEP_WIN = '\\' - --- | --- --- -_SEP_UNIX :: Char -_SEP_UNIX = '/' - --- | --- --- -_TASKS_JSON_FILE_CONTENTS :: BSL.ByteString -_TASKS_JSON_FILE_CONTENTS = str2lbs $ U.join "\n" $ - [ - "{" - , " // atuomatically created by phoityne-vscode" - , " " - , " \"version\": \"0.1.0\"," - , " \"isShellCommand\": true," - , " \"showOutput\": \"always\"," - , " \"suppressTaskName\": true," - , " \"windows\": {" - , " \"command\": \"cmd\"," - , " \"args\": [\"/c\"]" - , " }," - , " \"linux\": {" - , " \"command\": \"sh\"," - , " \"args\": [\"-c\"]" - , " }," - , " \"osx\": {" - , " \"command\": \"sh\"," - , " \"args\": [\"-c\"]" - , " }," - , " \"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 --test --no-run-tests --file-watch && echo END_STACK_WATCH \" ]" - , " }" - , " ]" - , "}" - ] - - --- | --- --- -_ERR_MSG_URL :: [String] -_ERR_MSG_URL = [ "`stack update` and install new phoityen-vscode." - , "Or check information on https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode" - ] - - --- | --- --- -defaultDebugContextData :: DebugContextData -defaultDebugContextData = DebugContextData _INITIAL_RESPONSE_SEQUENCE (MAP.fromList []) (MAP.fromList []) "" "" False Nothing 0 False Nothing BSL.putStr - --- | --- --- -getKeyOfSourcePosition :: G.SourcePosition -> BreakPointDataKey -getKeyOfSourcePosition (G.SourcePosition file line _ _ _) = (file, line) - - --- | --- --- -handleRequest :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> IO () -handleRequest mvarDat contLenStr jsonStr = do - case J.eitherDecode jsonStr :: Either String J.Request of - Left err -> do - -- req_secが不明のため、エラー出力のみ行う。 - -- ただし、initializeが完了していない場合は、エラー出力イベントが受理されない。 - -- launchしていな場合はログ出力ができない。 - -- 無視して、次のリクエストを待つ。 - let msg = L.intercalate " " [ "request request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) - ++ "\n" - - sendErrorEvent mvarDat msg - - resSeq <- getIncreasedResponseSequence mvarDat - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt - sendEventL terminatedEvtStr - - Right (J.Request cmd) -> handle contLenStr jsonStr cmd - - where - - handle contLenStr jsonStr "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of - Right req -> initializeRequestHandler mvarDat req - Left err -> do - -- initializeが完了していない場合は、エラー出力イベントが受理されない。 - -- responceをエラーで返す。メッセージは1行で作成する必要がある。 - -- launchしていな場合はログ出力ができない。 - -- res_seqは1固定とする。 - let msg = L.intercalate " " $ ["initialize request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] ++ _ERR_MSG_URL - resSeq <- getIncreasedResponseSequence mvarDat - sendResponse $ J.encode $ J.parseErrorInitializeResponse resSeq msg - - handle contLenStr jsonStr "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of - Right req -> launchRequestHandler mvarDat req - Left err -> do - -- launchしていな場合はログ出力ができない。 - -- req_secが不明のため、エラー出力のみ行う。 - let msg = L.intercalate " " ["launch request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - resSeq <- getIncreasedResponseSequence mvarDat - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt - sendEventL terminatedEvtStr - - - handle contLenStr jsonStr "configurationDone" = case J.eitherDecode jsonStr :: Either String J.ConfigurationDoneRequest of - Right req -> configurationDoneRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["configurationDone request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - handle contLenStr jsonStr "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of - Right req -> disconnectRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["disconnect request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of - Right req -> setBreakpointsRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["setBreakpoints request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "setFunctionBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetFunctionBreakpointsRequest of - Right req -> setFunctionBreakpointsRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["setFunctionBreakpoints request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of - Right req -> continueRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["continue request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of - Right req -> nextRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["next request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of - Right req -> stepInRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["stepIn request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - -- | - -- not supported. - -- - handle contLenStr jsonStr "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of - Right req -> do - resSeq <- getIncreasedResponseSequence mvarDat - let res = J.defaultStepOutResponse resSeq req - resStr = J.encode $ res{J.successStepOutResponse = False, J.messageStepOutResponse = "unsupported command."} - sendResponse resStr - - sendErrorEvent mvarDat "stepOut command is not supported." - - Left err -> do - let msg = L.intercalate " " ["stepOut request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - -- | - -- not supported. - -- - handle contLenStr jsonStr "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of - Right req -> do - resSeq <- getIncreasedResponseSequence mvarDat - let res = J.defaultPauseResponse resSeq req - resStr = J.encode $ res{J.successPauseResponse = False, J.messagePauseResponse = "unsupported command."} - sendResponse resStr - - sendErrorEvent mvarDat "pause command is not supported." - - Left err -> do - let msg = L.intercalate " " ["pause request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of - Right req -> stackTraceRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["stackTrace request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of - Right req -> scopesRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["scopes request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of - Right req -> variablesRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["variables request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - -- | - -- not supported. - -- - handle contLenStr jsonStr "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of - Right req -> do - resSeq <- getIncreasedResponseSequence mvarDat - let res = J.defaultSourceResponse resSeq req - resStr = J.encode $ res{J.successSourceResponse = False, J.messageSourceResponse = "unsupported command."} - sendResponse resStr - - sendErrorEvent mvarDat "source command is not supported." - - Left err -> do - let msg = L.intercalate " " ["source request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of - Right req -> threadsRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["threads request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - - handle contLenStr jsonStr "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of - Right req -> evaluateRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["evaluate request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - handle contLenStr jsonStr "completions" = case J.eitherDecode jsonStr :: Either String J.CompletionsRequest of - Right req -> completionsRequestHandler mvarDat req - Left err -> do - let msg = L.intercalate " " ["completions request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] - ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" - sendErrorEvent mvarDat msg - - handle contLenStr jsonStr cmd = do - let msg = L.intercalate " " ["unknown request command.", cmd, lbs2str contLenStr, lbs2str jsonStr] - sendErrorEvent mvarDat msg - - --- | --- -sendEvent :: BSL.ByteString -> IO () -sendEvent str = sendResponseInternal str - --- | --- -sendEventL :: BSL.ByteString -> IO () -sendEventL str = do - infoM _LOG_NAME $ "[EVENT]" ++ lbs2str str - sendEvent str - - --- | --- -sendResponseL :: BSL.ByteString -> IO () -sendResponseL str = do - infoM _LOG_NAME $ "[RESPONSE]" ++ lbs2str str - sendResponse str - - --- | --- -sendResponse :: BSL.ByteString -> IO () -sendResponse str = sendResponseInternal str - --- | --- -sendResponse2 :: MVar DebugContextData -> BSL.ByteString -> IO () -sendResponse2 mvarCtx str = do - ctx <- readMVar mvarCtx - responseHandlerDebugContextData ctx str - -- "{\"seq\":1,\"type\":\"response\",\"request_seq\":1,\"success\":true,\"command\":\"initialize\",\"message\":\"\",\"body\":{\"supportsCompletionsRequest\":true}}" - -- responseHandlerDebugContextData ctx $ "{\"seq\":1,\"type\":\"response\",\"request_seq\":1,\"success\":true,\"command\":\"initialize\",\"message\":\"\",\"body\":{\"supportsConfigurationDoneRequest\":true,\"supportsFunctionBreakpoints\":false,\"supportsConditionalBreakpoints\":true,\"supportsEvaluateForHovers\":true,\"exceptionBreakpointFilters\":[],\"supportsStepBack\":false,\"supportsSetVariable\":false,\"supportsRestartFrame\":false,\"supportsGotoTargetsRequest\":false,\"supportsStepInTargetsRequest\":false,\"supportsCompletionsRequest\":false}}" - --- | --- -sendResponseInternal :: BSL.ByteString -> IO () -sendResponseInternal str = do - BSL.hPut stdout $ BSL.append "Content-Length: " $ str2lbs $ show (BSL.length str) - BSL.hPut stdout $ str2lbs _TWO_CRLF - BSL.hPut stdout str - hFlush stdout - --- | --- --- -sendConsoleEvent :: MVar DebugContextData -> String -> IO () -sendConsoleEvent mvarCtx msg = do - resSeq <- getIncreasedResponseSequence mvarCtx - let outEvt = J.defaultOutputEvent resSeq - outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "console" msg Nothing } - sendEvent outEvtStr - --- | --- --- -sendStdoutEvent :: MVar DebugContextData -> String -> IO () -sendStdoutEvent mvarCtx msg = do - resSeq <- getIncreasedResponseSequence mvarCtx - let outEvt = J.defaultOutputEvent resSeq - outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "stdout" msg Nothing } - sendEvent outEvtStr - --- | --- --- -sendErrorEvent :: MVar DebugContextData -> String -> IO () -sendErrorEvent mvarCtx msg = do - resSeq <- getIncreasedResponseSequence mvarCtx - let outEvt = J.defaultOutputEvent resSeq - outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "stderr" msg Nothing } - sendEvent outEvtStr - --- |===================================================================== --- --- Handlers - --- | --- -initializeRequestHandler :: MVar DebugContextData -> J.InitializeRequest -> IO () -initializeRequestHandler mvarCtx req@(J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do - resSeq <- getIncreasedResponseSequence mvarCtx - let capa = J.InitializeResponseCapabilites True True True True [] False False False False False True - res = J.InitializeResponse resSeq "response" seq True "initialize" "" capa - - sendResponse2 mvarCtx $ J.encode res - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["initialize request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse $ J.encode $ J.errorInitializeResponse resSeq req msg - sendErrorEvent mvarCtx msg - - --- | --- -launchRequestHandler :: MVar DebugContextData -> J.LaunchRequest -> IO () -launchRequestHandler 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 - cmdStr = J.ghciCmdLaunchRequestArguments args - - -- コンテキストデータの保持 - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx { - workspaceDebugContextData = ws - , startupDebugContextData = su - } - - -- ロギング設定 - logLevel <- case readMay logLevelStr of - Just lv -> return lv - Nothing -> do - sendErrorEvent mvarCtx $ "log priority is invalid. WARNING set. [" ++ logLevelStr ++ "]\n" - return WARNING - - setupLogger logFile logLevel - - logRequest $ show req - - -- tasks.jsonファイルの準備 - prepareTasksJsonFile mvarCtx ws - - - -- ghciのランチ - runGHCi mvarCtx cmdStr ws prmptStr >>= ghciLaunched - - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["launch request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse $ J.encode $ J.errorLaunchResponse resSeq req msg - sendErrorEvent mvarCtx $ msg ++ "\n" - - -- | - -- - prepareTasksJsonFile :: MVar DebugContextData -> 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 - sendConsoleEvent mvarCtx $ "create tasks.json file. " ++ jsonFile ++ "\n" - saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS - - -- | - -- - ghciLaunched (Left err) = do - let msg = L.intercalate " " ["ghci launch error.", err] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse $ J.encode $ J.errorLaunchResponse resSeq req msg - sendErrorEvent mvarCtx $ msg ++ "\n" - - ghciLaunched (Right ghciProc) = do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{ghciProcessDebugContextData = Just ghciProc} - - startupRes <- loadHsFile mvarCtx (J.startupLaunchRequestArguments args) - - when (False == startupRes) $ do - let msg = L.intercalate " " ["startup load error.", J.startupLaunchRequestArguments args] - sendErrorEvent mvarCtx $ msg ++ "\n" - - -- レスポンスとinitializedイベント送信 - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.defaultLaunchResponse resSeq req - - resSeq <- getIncreasedResponseSequence mvarCtx - sendEventL $ J.encode $ J.defaultInitializedEvent resSeq - - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEventL stopEvtStr - - -- ファイル変更ウォッチの開始 - watch mvarCtx - - --sendStdoutEvent mvarCtx $ J.ghciPromptLaunchRequestArguments args - --- | --- -configurationDoneRequestHandler :: MVar DebugContextData -> J.ConfigurationDoneRequest -> IO () -configurationDoneRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["configurationDone request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorConfigurationDoneResponse resSeq req msg - sendErrorEvent mvarCtx msg - - infoMsg = [ - "" - , " Now, ghci launched and configuration done." - , " Press F5 to start debugging." - , " Or modify source code. it will be loaded to ghci automatically." - , " " - ] - - withProcess Nothing = do - errorM _LOG_NAME "[disconnectRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[disconnectRequestHandler] ghci not started." - - withProcess (Just ghciProc) = do - sendConsoleEvent mvarCtx $ L.intercalate "\n" infoMsg - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.defaultConfigurationDoneResponse resSeq req - - --- | --- -disconnectRequestHandler :: MVar DebugContextData -> J.DisconnectRequest -> IO () -disconnectRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["disconnect request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorDisconnectResponse resSeq req msg - sendErrorEvent mvarCtx msg - - withProcess Nothing = do - errorM _LOG_NAME "[disconnectRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[disconnectRequestHandler] ghci not started." - - withProcess (Just ghciProc) = G.quit ghciProc outHdl >>= withExitCode - - withExitCode (Left err) = do - errorM _LOG_NAME $ "[disconnectRequestHandler] ghci quit error. " ++ err - sendErrorEvent mvarCtx $ "[disconnectRequestHandler] ghci quit error. " ++ err - - withExitCode (Right code) = do - infoM _LOG_NAME $ show code - sendStdoutEvent mvarCtx $ show code - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.defaultDisconnectResponse resSeq req - - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - --- | --- -setBreakpointsRequestHandler :: MVar DebugContextData -> J.SetBreakpointsRequest -> IO () -setBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - ctx <- readMVar mvarCtx - let cwd = workspaceDebugContextData ctx - args = J.argumentsSetBreakpointsRequest req - source = J.sourceSetBreakpointsRequestArguments args - path = J.pathSource source - reqBps = J.breakpointsSetBreakpointsRequestArguments args - bps = map (convBp cwd path) reqBps - - delete path - resBody <- insert bps - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultSetBreakpointsResponse resSeq req - resStr = J.encode res{J.bodySetBreakpointsResponse = J.SetBreakpointsResponseBody resBody} - sendResponseL resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg - sendErrorEvent mvarCtx msg - - convBp cwd path (J.SourceBreakpoint lineNo _ cond) = - BreakPointData { - nameBreakPointData = src2mod cwd path - , filePathBreakPointData = path - , lineNoBreakPointData = lineNo - , breakNoBreakPointData = Nothing - , conditionBreakPointData = normalizeCond cond - } - - normalizeCond Nothing = Nothing - normalizeCond (Just c) - | null (U.strip c) = Nothing - | otherwise = Just c - - delete path = do - ctx <- takeMVar mvarCtx - let bps = breakPointDatasDebugContextData ctx - newBps = MAP.filterWithKey (\(p,_) _-> path /= p) bps - delBps = MAP.elems $ MAP.filterWithKey (\(p,_) _-> path == p) bps - - putMVar mvarCtx ctx{breakPointDatasDebugContextData = newBps} - - debugM _LOG_NAME $ "del bps:" ++ show delBps - - mapM_ (deleteBreakPointOnGHCi mvarCtx) delBps - - - insert reqBps = do - results <- mapM insertInternal reqBps - let addBps = filter (\(_, (J.Breakpoint _ verified _ _ _ _)) -> verified) results - resData = map snd results - - debugM _LOG_NAME $ "add bps:" ++ show addBps - debugM _LOG_NAME $ "response bps:" ++ show resData - - ctx <- takeMVar mvarCtx - let bps = breakPointDatasDebugContextData ctx - newBps = foldr (\v@(BreakPointData _ p l _ _)->MAP.insert (p,l) v) bps $ map fst results - putMVar mvarCtx ctx{breakPointDatasDebugContextData = newBps} - - return resData - - - insertInternal reqBp@(BreakPointData modName filePath lineNo _ _) = do - let src = J.Source (Just modName) filePath Nothing Nothing - - addBreakPointOnGHCi mvarCtx reqBp >>= \case - Right no -> do - --putStrLnStdout mvarCtx $ "set breakpoint on " ++ filePathBreakPointData reqBp ++ ":L" ++ show (lineNoBreakPointData reqBp) - return (reqBp{breakNoBreakPointData = Just no}, J.Breakpoint (Just no) True "" src lineNo 1) - Left err -> return (reqBp, J.Breakpoint Nothing False err src lineNo 1) - --- | --- -setFunctionBreakpointsRequestHandler :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> IO () -setFunctionBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - let args = J.argumentsSetFunctionBreakpointsRequest req - reqBps = J.breakpointsSetFunctionBreakpointsRequestArguments args - bps = map convBp reqBps - - delete - resBody <- insert bps - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultSetFunctionBreakpointsResponse resSeq req - resStr = J.encode res{J.bodySetFunctionBreakpointsResponse = J.SetFunctionBreakpointsResponseBody resBody} - sendResponseL resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorSetFunctionBreakpointsResponse resSeq req msg - sendErrorEvent mvarCtx msg - - convBp (J.FunctionBreakpoint name cond) = - BreakPointData { - nameBreakPointData = name - , filePathBreakPointData = "" - , lineNoBreakPointData = -1 - , breakNoBreakPointData = Nothing - , conditionBreakPointData = normalizeCond cond - } - - normalizeCond Nothing = Nothing - normalizeCond (Just c) - | null (U.strip c) = Nothing - | otherwise = Just c - - delete = do - ctx <- takeMVar mvarCtx - let bps = functionBreakPointDatasDebugContextData ctx - delBps = MAP.elems bps - - putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = MAP.fromList []} - - debugM _LOG_NAME $ "del bps:" ++ show delBps - - mapM_ (deleteBreakPointOnGHCi mvarCtx) delBps - - - insert reqBps = do - results <- mapM insertInternal reqBps - let addBps = filter (\(_, (J.Breakpoint _ verified _ _ _ _)) -> verified) results - resData = map snd results - - debugM _LOG_NAME $ "add funBPs:" ++ show addBps - debugM _LOG_NAME $ "response funBPs:" ++ show resData - - ctx <- takeMVar mvarCtx - let bps = functionBreakPointDatasDebugContextData ctx - newBps = foldr (\v@(BreakPointData _ p l _ _)->MAP.insert (p,l) v) bps $ map fst results - putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = newBps} - - return resData - - - insertInternal reqBp@(BreakPointData funcName _ _ _ _) = do - addFunctionBreakPointOnGHCi mvarCtx reqBp >>= \case - Right (no, (G.SourcePosition path sl sc _ _)) -> do - --putStrLnStdout mvarCtx $ "set breakpoint on " ++ filePathBreakPointData reqBp ++ ":L" ++ show (lineNoBreakPointData reqBp) - return ( reqBp{ breakNoBreakPointData = Just no - , filePathBreakPointData = path - , lineNoBreakPointData = sl - } - , J.Breakpoint (Just no) True "" (J.Source (Just funcName) path Nothing Nothing) sl sc) - Left err -> return (reqBp, J.Breakpoint Nothing False err (J.Source (Just funcName) "" Nothing Nothing) (-1) (-1)) - --- | --- --- -continueRequestHandler :: MVar DebugContextData -> J.ContinueRequest -> IO () -continueRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["continue request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorContinueResponse resSeq req msg - sendErrorEvent mvarCtx msg - - withProcess Nothing = do - errorM _LOG_NAME "[continueRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[continueRequestHandler] ghci not started." - - withProcess (Just _) = do - resSeq <- getIncreasedResponseSequence mvarCtx - let resStr = J.encode $ J.defaultContinueResponse resSeq req - sendResponseL resStr - - startDebug mvarCtx - - --- | --- --- -nextRequestHandler :: MVar DebugContextData -> J.NextRequest -> IO () -nextRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - ctx <- readMVar mvarCtx - case debugStoppedPosDebugContextData ctx of - Nothing -> do - resSeq <- getIncreasedResponseSequence 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)."} - sendResponseL resStr - Just _ -> next - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["stepOver request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorNextResponse resSeq req msg - sendErrorEvent mvarCtx msg - - next = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - withProcess Nothing = do - errorM _LOG_NAME "[nextRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[nextRequestHandler] ghci not started." - - withProcess (Just ghciProc) = G.stepLocal ghciProc outHdl >>= \case - Left err -> do - infoM _LOG_NAME $ show err - --putStrLnStdout mvarCtx $ show err - - resSeq <- getIncreasedResponseSequence mvarCtx - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt - sendEventL terminatedEvtStr - - Right pos -> do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultNextResponse resSeq req - resStr = J.encode res - sendResponseL resStr - - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEventL stopEvtStr - - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - --- | --- --- -stepInRequestHandler :: MVar DebugContextData -> J.StepInRequest -> IO () -stepInRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - ctx <- readMVar mvarCtx - case debugStoppedPosDebugContextData ctx of - Nothing -> do - resSeq <- getIncreasedResponseSequence 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)."} - sendResponseL resStr - Just _ -> stepIn - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["stepIn request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorStepInResponse resSeq req msg - sendErrorEvent mvarCtx msg - - stepIn = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - withProcess Nothing = do - errorM _LOG_NAME "[stepInRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[stepInRequestHandler] ghci not started." - - withProcess (Just ghciProc) = G.step ghciProc outHdl >>= \case - Left err -> do - infoM _LOG_NAME $ show err - --putStrLnStdout mvarCtx $ show err - - resSeq <- getIncreasedResponseSequence mvarCtx - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt - sendEventL terminatedEvtStr - - Right pos -> do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultStepInResponse resSeq req - resStr = J.encode res - sendResponseL resStr - - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEventL stopEvtStr - - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - --- | --- --- -stackTraceRequestHandler :: MVar DebugContextData -> J.StackTraceRequest -> IO () -stackTraceRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - ctx <- readMVar mvarCtx - case debugStoppedPosDebugContextData ctx of - Nothing -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let body = J.StackTraceBody [] 0 - res = J.defaultStackTraceResponse resSeq req - resStr = J.encode $ res{J.bodyStackTraceResponse = body} - sendResponseL resStr - - Just rangeData -> do - frames <- createStackFrames rangeData - debugM _LOG_NAME $ show frames - - resSeq <- getIncreasedResponseSequence mvarCtx - let body = J.StackTraceBody (reverse frames) (length frames) - res = J.defaultStackTraceResponse resSeq req - resStr = J.encode $ res{J.bodyStackTraceResponse = body} - sendResponseL resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["stackTrace request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorStackTraceResponse resSeq req msg - sendErrorEvent mvarCtx msg - - createStackFrames pos = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess pos - - withProcess pos Nothing = do - errorM _LOG_NAME "[stackTraceRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[stackTraceRequestHandler] ghci not started." - defaultFrame pos - - withProcess pos (Just ghciProc) = G.history ghciProc outHdl >>= \case - Left err -> do - errorM _LOG_NAME $ show err - sendErrorEvent mvarCtx $ show err - defaultFrame pos - - Right dats -> do - cwd <- workspaceDebugContextData <$> readMVar mvarCtx - cfs <- defaultFrame pos - foldM (convTrace2Frame cwd) cfs dats - - convTrace2Frame cwd xs (G.StackFrame traceId funcName (G.SourcePosition file sl sc el ec)) = return $ - J.StackFrame traceId funcName (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec : xs - - defaultFrame (G.SourcePosition file sl sc el ec) = do - ctx <- readMVar mvarCtx - let cwd = workspaceDebugContextData ctx - csf = J.StackFrame 0 "[BP]" (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec - return [csf] - - outHdl msg = do - --sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - --- | --- --- -scopesRequestHandler :: MVar DebugContextData -> J.ScopesRequest -> IO () -scopesRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - let args = J.argumentsScopesRequest req - traceId = J.frameIdScopesArguments args - - moveFrame mvarCtx traceId - - resSeq <- getIncreasedResponseSequence mvarCtx - let resStr = J.encode $ J.defaultScopesResponse resSeq req - sendResponseL resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["scopes request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorScopesResponse resSeq req msg - sendErrorEvent mvarCtx msg - --- | --- --- -variablesRequestHandler :: MVar DebugContextData -> J.VariablesRequest -> IO () -variablesRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - vals <- currentBindings - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultVariablesResponse resSeq req - resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals} - sendResponseL resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["variables request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorVariablesResponse resSeq req msg - sendErrorEvent mvarCtx msg - - currentBindings = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - withProcess Nothing = do - errorM _LOG_NAME "[variablesRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[variablesRequestHandler] ghci not started." - return [] - - withProcess (Just ghciProc) = G.bindings ghciProc outHdl >>= \case - Left err -> do - errorM _LOG_NAME $ show err - sendErrorEvent mvarCtx $ show err - return [] - - Right dats -> return $ map convBind2Vals dats - - convBind2Vals (G.BindingData varName modName val) = J.Variable varName modName val 0 - - outHdl msg = do - --sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - --- | --- --- -threadsRequestHandler :: MVar DebugContextData -> J.ThreadsRequest -> IO () -threadsRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - resSeq <- getIncreasedResponseSequence mvarCtx - let resStr = J.encode $ J.defaultThreadsResponse resSeq req - sendResponseL resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["threads request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorThreadsResponse resSeq req msg - sendErrorEvent mvarCtx msg - - --- | --- --- -evaluateRequestHandler :: MVar DebugContextData -> J.EvaluateRequest -> IO () -evaluateRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - let (J.EvaluateArguments exp _ ctx) = J.argumentsEvaluateRequest req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess ctx exp - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["evaluate request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorEvaluateResponse resSeq req msg - sendErrorEvent mvarCtx msg - - withProcess _ _ Nothing = do - errorM _LOG_NAME "[evaluateRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[evaluateRequestHandler] ghci not started." - - withProcess "watch" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case - Left err -> do - errorM _LOG_NAME $ show err - evaluateResponse err "" - - Right typeStr -> case isFunction typeStr of - True -> evaluateResponse "" (getOnlyType typeStr) - False -> G.force ghciProc outHdl exp >>= \case - Right valStr -> evaluateResponse (getOnlyValue valStr) (getOnlyType typeStr) - Left _ -> evaluateResponse "" (getOnlyType typeStr) - - withProcess "hover" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case - Left err -> do - errorM _LOG_NAME $ show err - evaluateResponse err "" - Right typeStr -> evaluateResponse typeStr (getOnlyType typeStr) - - withProcess _ exp (Just ghciProc) - | null (U.strip exp) = do - evaluateResponse "" "" - sendStdoutEvent mvarCtx (G.promptGHCiProcess ghciProc) - | otherwise = replHandler ghciProc $ map U.rstrip (lines exp) - - replHandler _ [] = do - errorM _LOG_NAME "[replHandler] invalid inputs." - evaluateResponse "" "" - - replHandler ghciProc (exp:[]) - | isPermitCmd (U.strip exp) = G.exec ghciProc outHdl exp >>= \case - Left err -> do - errorM _LOG_NAME $ show err - evaluateResponse "" "" - sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ show err - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - Right cmdStr -> do - evaluateResponse "" "" - sendStdoutEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ cmdStr - infoM _LOG_NAME $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ cmdStr - | otherwise = do - evaluateResponse "" "" - sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n can not use these commands.\n" ++ show notPermit ++ "\n" - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - infoM _LOG_NAME $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n can not use these commands.\n" ++ show notPermit ++ "\n" - - replHandler ghciProc exps = G.exec ghciProc outHdl ":{" >>= \case - Left err -> do - errorM _LOG_NAME $ show err - evaluateResponse "" "" - sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ ":{\n" ++ show err - Right cmdStr -> replsHandler ghciProc (exps ++ [":}"]) $ (G.promptGHCiProcess ghciProc) ++ ":{\n" ++ cmdStr - - replsHandler _ [] acc = do - evaluateResponse "" "" - sendStdoutEvent mvarCtx acc - infoM _LOG_NAME acc - - replsHandler ghciProc (x:xs) acc - | isPermitCmd (U.strip x) = G.exec ghciProc outHdl x >>= \case - Left err -> do - evaluateResponse "" "" - sendErrorEvent mvarCtx $ acc ++ x ++ "\n" ++ show err - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - errorM _LOG_NAME $ acc ++ x ++ "\n" ++ show err - - Right cmdStr -> replsHandler ghciProc xs $ acc ++ x ++ "\n" ++ cmdStr - | otherwise = do - evaluateResponse "" "" - sendErrorEvent mvarCtx $ acc ++ x ++ "\n can not use these commands.\n" ++ show notPermit ++ "\n" - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - infoM _LOG_NAME $ acc ++ x ++ "\n can not use these commands.\n" ++ show notPermit ++ "\n" - - isPermitCmd c = 0 == (length ( filter (flip U.startswith c) notPermit)) - - notPermit = [":{", ":abandon", ":back", ":break", ":continue", ":delete", ":force", ":forward" - , ":history", ":list", ":print", ":sprint", ":step", ":steplocal", ":stepmodule", ":trace" - ] - - outHdl msg = do - --sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - isFunction str = case parse isFunctionParser "isFunction" str of - Right _ -> True - Left _ -> False - - isFunctionParser = manyTill anyChar (string "->") - - evaluateResponse msg typeStr = do - resSeq <- getIncreasedResponseSequence mvarCtx - let body = J.EvaluateBody msg typeStr 0 - res = J.defaultEvaluateResponse resSeq req - resStr = J.encode res{J.bodyEvaluateResponse = body} - sendResponseL resStr - - -- | - -- force結果のパーサ - -- - -- parser of - -- Phoityne>>= :force x - -- x = 8 - -- Phoityne>>= - -- - getOnlyValue :: String -> String - getOnlyValue str = case parse getOnlyValueParser "getOnlyValue" str of - Right vals -> vals - Left _ -> str - where - getOnlyValueParser = do - _ <- manyTill anyChar (string " = ") - manyTill anyChar eof - - -- | - -- type結果のパーサ - -- - -- parser of - -- Phoityne>>= :type x - -- x :: Int -> Int - -- Phoityne>>= - -- - getOnlyType :: String -> String - getOnlyType str = case parse getOnlyTypeParser "getOnlyType" str of - Right vals -> vals - Left _ -> str - where - getOnlyTypeParser = do - _ <- manyTill anyChar (string " :: ") - manyTill anyChar eof - - --- | --- --- -completionsRequestHandler :: MVar DebugContextData -> J.CompletionsRequest -> IO () -completionsRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - let (J.CompletionsArguments _ key _ _) = J.argumentsCompletionsRequest req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess key - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["completions request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponseL $ J.encode $ J.errorCompletionsResponse resSeq req msg - sendErrorEvent mvarCtx msg - - withProcess _ Nothing = do - errorM _LOG_NAME "[completionsRequestHandler] ghci not started." - sendErrorEvent mvarCtx "[completionsRequestHandler] ghci not started." - - withProcess key (Just ghciProc) = G.complete ghciProc outHdl key 50 >>= \case - Left err -> do - errorM _LOG_NAME $ show err - resSeq <- getIncreasedResponseSequence mvarCtx - let resStr = J.encode $ J.errorCompletionsResponse resSeq req $ show err - sendResponseL resStr - - Right xs -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let bd = J.CompletionsResponseBody $ map createItem xs - res = J.defaultCompletionsResponse resSeq req - - let resStr = J.encode $ res {J.bodyCompletionsResponse = bd} - sendResponseL resStr - - createItem (':':xs) = J.CompletionsItem xs - createItem xs = J.CompletionsItem xs - - outHdl msg = do - --sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - --- |===================================================================== --- --- utility - - --- | --- --- -logRequest :: String -> IO () -logRequest reqStr = do - let msg = L.intercalate " " ["[REQUEST]", reqStr] - infoM _LOG_NAME msg - - - --- | --- --- -src2mod :: FilePath -> FilePath -> String -src2mod cwd src - | length cwd >= length src = "" - | otherwise = L.intercalate "." - $ map takeBaseName - $ reverse - $ takeWhile startUpperCase - $ reverse - $ splitOneOf [_SEP_WIN, _SEP_UNIX] - $ drop (length cwd) src - - where - startUpperCase modName - | null modName = True - | otherwise = isUpper $ head modName - - --- | --- --- -getIncreasedResponseSequence :: MVar DebugContextData -> IO Int -getIncreasedResponseSequence mvarCtx = do - ctx <- takeMVar mvarCtx - let resSec = 1 + resSeqDebugContextData ctx - putMVar mvarCtx ctx{resSeqDebugContextData = resSec} - return resSec - - --- | --- --- -runGHCi :: MVar DebugContextData -> String -> FilePath -> String -> IO (Either G.ErrorData G.GHCiProcess) -runGHCi mvarCtx cmdStr cwd pmt = do - let cmdList = filter (not.null) $ U.split " " cmdStr - cmd = head cmdList - opts = tail cmdList - - G.start outHdl cmd opts cwd pmt - - where - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - --- | --- --- -loadHsFile :: MVar DebugContextData -> FilePath -> IO Bool -loadHsFile mvarCtx path = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case - Nothing -> do - errorM _LOG_NAME $ "load file fail.[" ++ path ++ "]" ++ " ghci not started." - sendErrorEvent mvarCtx $ "load file fail.[" ++ path ++ "]" ++ " ghci not started." - return False - Just ghciProc -> G.loadFile ghciProc outHdl path >>= withFileLoadResult ghciProc - - where - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - withFileLoadResult _ (Left err) = do - errorM _LOG_NAME $ "load file fail.[" ++ path ++ "]" ++ " " ++ err - sendErrorEvent mvarCtx $ "load file fail.[" ++ path ++ "]" ++ " " ++ err - return False - - withFileLoadResult ghciProc (Right mods) = G.loadModule ghciProc outHdl mods >>= \case - Left err -> do - errorM _LOG_NAME $ "load module fail. " ++ show mods ++ " " ++ err - sendErrorEvent mvarCtx $ "load module fail. " ++ show mods ++ " " ++ err - return False - Right _ -> return True - - --- | --- ブレークポイントをGHCi上でdeleteする --- -deleteBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO () -deleteBreakPointOnGHCi mvarCtx bp@(BreakPointData _ _ _ (Just breakNo) _) = - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case - Nothing -> do - errorM _LOG_NAME $ "[deleteBreakPointOnGHCi] ghci not started. " ++ show bp - sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] ghci not started. " ++ show bp - Just ghciProc -> G.delete ghciProc outHdl breakNo >>= withResult - - where - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - withResult (Left err) = do - errorM _LOG_NAME $ "[deleteBreakPointOnGHCi] " ++ err ++ " " ++ show bp - sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] " ++ err ++ " " ++ show bp - - withResult (Right _) = return () - -deleteBreakPointOnGHCi mvarCtx bp = do - let err = "[deleteBreakPointOnGHCi] invalid delete break point. " ++ show bp - sendErrorEvent mvarCtx err - errorM _LOG_NAME err - --- | --- GHCi上でブレークポイントを追加する --- -addBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String Int) -addBreakPointOnGHCi mvarCtx bp@(BreakPointData modName _ lineNo _ _) = - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case - Nothing -> do - errorM _LOG_NAME $ "[addBreakPointOnGHCi] ghci not started. " ++ show bp - return $ Left $ "[addBreakPointOnGHCi] ghci not started. " ++ show bp - Just ghciProc -> G.setBreak ghciProc outHdl modName lineNo - - where - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - --- | --- GHCi上で関数ブレークポイントを追加する --- -addFunctionBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String (Int, G.SourcePosition)) -addFunctionBreakPointOnGHCi mvarCtx bp@(BreakPointData name _ _ _ _) = - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case - Nothing -> do - errorM _LOG_NAME $ "[addFunctionBreakPointOnGHCi] ghci not started. " ++ show bp - return $ Left $ "[addFunctionBreakPointOnGHCi] ghci not started. " ++ show bp - Just ghciProc -> G.setFuncBreak ghciProc outHdl name - - where - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - --- | --- 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 :: MVar DebugContextData -> IO () -watch mvarCtx = do - _ <- forkIO $ watchFiles mvarCtx - return () - -watchFiles :: MVar DebugContextData -> IO () -watchFiles mvarCtx = do - FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce = FSN.Debounce 1} $ \mgr -> do - - ctx <- readMVar mvarCtx - let dir = workspaceDebugContextData ctx - - infoM _LOG_NAME $ "start watch files in [" ++ dir ++ "]" - _ <- FSN.watchTree mgr dir hsFilter action - - forever $ threadDelay 1000000 - - return () - - where - hsFilter event = U.endswith _HS_FILE_EXT $ FSN.eventPath event - - action event = do - - ctx <- readMVar mvarCtx - withDebugStarted event $ debugStartedDebugContextData ctx - - withDebugStarted _ True = do - resSeq <- getIncreasedResponseSequence mvarCtx - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True} - sendEventL terminatedEvtStr - - withDebugStarted event False = do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{modifiedDebugContextData = True} - loadHsFile mvarCtx (FSN.eventPath event) >> return () - - --- | --- --- -moveFrame :: MVar DebugContextData -> Int -> IO () -moveFrame mvarCtx traceId = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - where - withProcess Nothing = do - errorM _LOG_NAME "[moveFrame] ghci not started." - sendErrorEvent mvarCtx "[moveFrame] ghci not started." - - withProcess (Just ghciProc) = do - ctx <- readMVar mvarCtx - let curTraceId = currentFrameIdDebugContextData ctx - moveCount = curTraceId - traceId - traceCmd = if 0 > moveCount then G.back ghciProc outHdl - else G.forward ghciProc outHdl - - -- _ <- traceCmd (abs moveCount) - mapM_ traceCmd [1..(abs moveCount)] - - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{currentFrameIdDebugContextData = traceId} - - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - --- | --- --- -startDebug :: MVar DebugContextData -> IO () -startDebug mvarCtx = do - ctx <- readMVar mvarCtx - let started = debugStartedDebugContextData ctx - - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= startDebugInternal started - - - where - startDebugInternal _ Nothing = do - errorM _LOG_NAME "[startDebug] ghci not started." - sendErrorEvent mvarCtx "[startDebug] ghci not started." - - startDebugInternal True (Just ghciProc) = G.trace ghciProc outHdl >>= \case - Left err -> do - infoM _LOG_NAME $ show err - --putStrLnStdout mvarCtx $ show err - - resSeq <- getIncreasedResponseSequence mvarCtx - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt - sendEventL terminatedEvtStr - - Right pos -> continueWithSourcePosition mvarCtx pos - - startDebugInternal False (Just ghciProc) = do - ctx <- readMVar mvarCtx - withModified ghciProc $ modifiedDebugContextData ctx - - withModified _ True = do - resSeq <- getIncreasedResponseSequence mvarCtx - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True} - sendEventL terminatedEvtStr - - withModified ghciProc False = G.traceMain ghciProc outHdl >>= \case - Left err -> do - infoM _LOG_NAME $ show err - --putStrLnStdout mvarCtx $ show err - - resSeq <- getIncreasedResponseSequence mvarCtx - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt - sendEventL terminatedEvtStr - - Right pos -> do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{currentFrameIdDebugContextData = 0, debugStartedDebugContextData = True} - continueWithSourcePosition mvarCtx pos - - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - --- | --- --- -continueWithSourcePosition :: MVar DebugContextData -> G.SourcePosition -> IO () -continueWithSourcePosition mvarCtx pos = do - ctx <- readMVar mvarCtx - - let bpKey = getKeyOfSourcePosition pos - bpMap = breakPointDatasDebugContextData ctx - funcBpMap = functionBreakPointDatasDebugContextData ctx - - case MAP.lookup bpKey bpMap of - Nothing -> case MAP.lookup bpKey funcBpMap of - Nothing -> do - errorM _LOG_NAME $ "breakpoint not found." ++ show bpKey - sendStopEvent - Just condCmd -> continueWithCondCmd $ conditionBreakPointData condCmd - Just condCmd -> continueWithCondCmd $ conditionBreakPointData condCmd - - where - - -- | - -- - continueWithCondCmd Nothing = do - infoM _LOG_NAME "no condition breakpoint" - sendStopEvent - continueWithCondCmd (Just condStr) = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess condStr - - withProcess _ Nothing = do - errorM _LOG_NAME "[continueWithSourcePosition] ghci not started." - sendErrorEvent mvarCtx "[continueWithSourcePosition] ghci not started." - withProcess condStr (Just ghciProc) = do - forceBindings ghciProc outHdl - G.execBool ghciProc outHdl condStr >>= withResult - - withResult (Left err) = do - infoM _LOG_NAME err - continueWithCondResult True - withResult (Right condRes) = continueWithCondResult condRes - - outHdl msg = do - sendStdoutEvent mvarCtx msg - infoM _LOG_NAME msg - - forceBindings ghciProc outHdl = G.bindings ghciProc outHdl >>= \case - Left err -> do - errorM _LOG_NAME $ "[forceBindings] " ++ err - sendErrorEvent mvarCtx $ "[forceBindings] " ++ err - return () - Right bs -> do - mapM_ (forceBind ghciProc outHdl . G.nameBindingData) bs - return () - - forceBind ghciProc outHdl name = G.force ghciProc outHdl name >>= \case - Left err -> do - errorM _LOG_NAME $ "[forceBindings] " ++ err - sendErrorEvent mvarCtx $ "[forceBindings] " ++ err - return () - Right _ -> return () - - -- | - -- - continueWithCondResult False = do - sendConsoleEvent mvarCtx "[INFO] continueed because condition False." - startDebug mvarCtx - continueWithCondResult True = do - sendConsoleEvent mvarCtx "[INFO] stopped because condition not False." - sendStopEvent - - -- | - -- - sendStopEvent = do - infoM _LOG_NAME $ show pos - - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} - - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEvent stopEvtStr + +import qualified Phoityne.GHCi as G + +import Control.Concurrent +import Control.Monad +import Data.List.Split +import Data.Char +import Safe +import System.IO +import System.FilePath +import System.Directory +import System.Log.Logger +import Text.Parsec +import qualified Control.Exception as E +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as BSL +import qualified Data.String.Utils as U +import qualified Data.List as L +import qualified Data.Map as MAP +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 Phoityne.VSCode.Constant +import Phoityne.VSCode.Utility +import Phoityne.VSCode.IO.Utility +import qualified Phoityne.VSCode.TH.BreakpointJSON as J +import qualified Phoityne.VSCode.TH.CompletionsItemJSON as J +import qualified Phoityne.VSCode.TH.CompletionsArgumentsJSON as J +import qualified Phoityne.VSCode.TH.CompletionsResponseBodyJSON as J +import qualified Phoityne.VSCode.TH.CompletionsRequestJSON as J +import qualified Phoityne.VSCode.TH.CompletionsResponseJSON as J +import qualified Phoityne.VSCode.TH.ConfigurationDoneRequestJSON as J +import qualified Phoityne.VSCode.TH.ConfigurationDoneResponseJSON as J +import qualified Phoityne.VSCode.TH.ContinueRequestJSON as J +import qualified Phoityne.VSCode.TH.ContinueResponseJSON as J +import qualified Phoityne.VSCode.TH.DisconnectRequestJSON as J +import qualified Phoityne.VSCode.TH.DisconnectResponseJSON as J +import qualified Phoityne.VSCode.TH.EvaluateArgumentsJSON as J +import qualified Phoityne.VSCode.TH.EvaluateBodyJSON as J +import qualified Phoityne.VSCode.TH.EvaluateRequestJSON as J +import qualified Phoityne.VSCode.TH.EvaluateResponseJSON as J +import qualified Phoityne.VSCode.TH.InitializedEventJSON as J +import qualified Phoityne.VSCode.TH.InitializeRequestJSON as J +import qualified Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON as J +import qualified Phoityne.VSCode.TH.InitializeResponseJSON as J +import qualified Phoityne.VSCode.TH.LaunchRequestArgumentsJSON as J +import qualified Phoityne.VSCode.TH.LaunchRequestJSON as J +import qualified Phoityne.VSCode.TH.LaunchResponseJSON as J +import qualified Phoityne.VSCode.TH.NextRequestJSON as J +import qualified Phoityne.VSCode.TH.NextResponseJSON as J +import qualified Phoityne.VSCode.TH.OutputEventJSON as J +import qualified Phoityne.VSCode.TH.OutputEventBodyJSON as J +import qualified Phoityne.VSCode.TH.PauseRequestJSON as J +import qualified Phoityne.VSCode.TH.PauseResponseJSON as J +import qualified Phoityne.VSCode.TH.RequestJSON as J +import qualified Phoityne.VSCode.TH.ScopesArgumentsJSON as J +import qualified Phoityne.VSCode.TH.ScopesRequestJSON as J +import qualified Phoityne.VSCode.TH.ScopesResponseJSON as J +import qualified Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON as J +import qualified Phoityne.VSCode.TH.SetBreakpointsRequestJSON as J +import qualified Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON as J +import qualified Phoityne.VSCode.TH.SetBreakpointsResponseJSON as J +import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON as J +import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON as J +import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON as J +import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseJSON as J +import qualified Phoityne.VSCode.TH.SourceBreakpointJSON as J +import qualified Phoityne.VSCode.TH.FunctionBreakpointJSON as J +import qualified Phoityne.VSCode.TH.SourceJSON as J +import qualified Phoityne.VSCode.TH.SourceRequestJSON as J +import qualified Phoityne.VSCode.TH.SourceResponseJSON as J +import qualified Phoityne.VSCode.TH.StackFrameJSON as J +import qualified Phoityne.VSCode.TH.StackTraceBodyJSON as J +import qualified Phoityne.VSCode.TH.StackTraceRequestJSON as J +import qualified Phoityne.VSCode.TH.StackTraceResponseJSON as J +import qualified Phoityne.VSCode.TH.StepInRequestJSON as J +import qualified Phoityne.VSCode.TH.StepInResponseJSON as J +import qualified Phoityne.VSCode.TH.StepOutRequestJSON as J +import qualified Phoityne.VSCode.TH.StepOutResponseJSON as J +import qualified Phoityne.VSCode.TH.StoppedEventJSON as J +import qualified Phoityne.VSCode.TH.TerminatedEventJSON as J +import qualified Phoityne.VSCode.TH.TerminatedEventBodyJSON as J +import qualified Phoityne.VSCode.TH.ThreadsRequestJSON as J +import qualified Phoityne.VSCode.TH.ThreadsResponseJSON as J +import qualified Phoityne.VSCode.TH.VariableJSON as J +import qualified Phoityne.VSCode.TH.VariablesBodyJSON as J +import qualified Phoityne.VSCode.TH.VariablesRequestJSON as J +import qualified Phoityne.VSCode.TH.VariablesResponseJSON as J + +-- | +-- +-- +data DebugContextData = + DebugContextData { + resSeqDebugContextData :: Int + , functionBreakPointDatasDebugContextData :: BreakPointDatas + , breakPointDatasDebugContextData :: BreakPointDatas + , workspaceDebugContextData :: FilePath + , startupDebugContextData :: FilePath + , debugStartedDebugContextData :: Bool + , debugStoppedPosDebugContextData :: Maybe G.SourcePosition + , currentFrameIdDebugContextData :: Int + , modifiedDebugContextData :: Bool + , ghciProcessDebugContextData :: Maybe G.GHCiProcess + , responseHandlerDebugContextData :: BSL.ByteString -> IO () + } + + +-- | +-- +-- +data BreakPointData = + BreakPointData { + nameBreakPointData :: String + , filePathBreakPointData :: FilePath + , lineNoBreakPointData :: Int + , breakNoBreakPointData :: Maybe Int + , conditionBreakPointData :: Maybe String + , hitConditionBreakPointData :: Maybe String + , hitCountBreakPointData :: Int + } deriving (Show, Read, Eq, Ord) + + +-- | +-- +-- +type BreakPointDataKey = (FilePath, Int) + +-- | +-- +-- +type BreakPointDatas = MAP.Map BreakPointDataKey BreakPointData + +-- | +-- +-- +getBreakPointKey :: BreakPointData -> BreakPointDataKey +getBreakPointKey bp = (filePathBreakPointData bp, lineNoBreakPointData bp) + + +-- | +-- +incrementBreakPointHitCount :: BreakPointData -> BreakPointData +incrementBreakPointHitCount bp = bp{hitCountBreakPointData = 1 + hitCountBreakPointData bp} + + + +-- | +-- +-- +_INITIAL_RESPONSE_SEQUENCE :: Int +_INITIAL_RESPONSE_SEQUENCE = 0 + + +-- | +-- +-- +_TWO_CRLF :: String +_TWO_CRLF = "\r\n\r\n" + +-- | +-- +-- +_SEP_WIN :: Char +_SEP_WIN = '\\' + +-- | +-- +-- +_SEP_UNIX :: Char +_SEP_UNIX = '/' + +-- | +-- +-- +_TASKS_JSON_FILE_CONTENTS :: BSL.ByteString +_TASKS_JSON_FILE_CONTENTS = str2lbs $ U.join "\n" $ + [ + "{" + , " // atuomatically created by phoityne-vscode" + , " " + , " \"version\": \"0.1.0\"," + , " \"isShellCommand\": true," + , " \"showOutput\": \"always\"," + , " \"suppressTaskName\": true," + , " \"windows\": {" + , " \"command\": \"cmd\"," + , " \"args\": [\"/c\"]" + , " }," + , " \"linux\": {" + , " \"command\": \"sh\"," + , " \"args\": [\"-c\"]" + , " }," + , " \"osx\": {" + , " \"command\": \"sh\"," + , " \"args\": [\"-c\"]" + , " }," + , " \"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 --test --no-run-tests --file-watch && echo END_STACK_WATCH \" ]" + , " }" + , " ]" + , "}" + ] + + +-- | +-- +-- +_ERR_MSG_URL :: [String] +_ERR_MSG_URL = [ "`stack update` and install new phoityen-vscode." + , "Or check information on https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode" + ] + + +-- | +-- +-- +_DEBUG_START_MSG :: [String] +_DEBUG_START_MSG = [ + "" + , " Now, ghci launched and configuration done." + , " Press F5 to start debugging." + , " Or modify source code. it will be loaded to ghci automatically." + , " " + ] + +-- | +-- +-- +_NOT_PERMIT_REPL_COMMANDS :: [String] +_NOT_PERMIT_REPL_COMMANDS = [ + ":{" + , ":abandon", ":back", ":break", ":continue", ":delete", ":force", ":forward" + , ":history", ":list", ":print", ":sprint", ":step", ":steplocal", ":stepmodule", ":trace" + ] + +-- | +-- +-- +defaultDebugContextData :: DebugContextData +defaultDebugContextData = DebugContextData _INITIAL_RESPONSE_SEQUENCE (MAP.fromList []) (MAP.fromList []) "" "" False Nothing 0 False Nothing BSL.putStr + +-- | +-- +-- +getKeyOfSourcePosition :: G.SourcePosition -> BreakPointDataKey +getKeyOfSourcePosition (G.SourcePosition file line _ _ _) = (file, line) + + + +-- |===================================================================== +-- Request / Response / Event +-- + + +-- | +-- +-- +logRequest :: String -> IO () +logRequest reqStr = infoM _LOG_NAME $ "[REQUEST] " ++ reqStr + + +-- | +-- +isLoggingStarted :: MVar DebugContextData -> IO Bool +isLoggingStarted mvarCtx = do + ctx <- readMVar mvarCtx + return . not . null $ workspaceDebugContextData ctx + +-- | +-- +sendResponse :: MVar DebugContextData -> BSL.ByteString -> IO () +sendResponse mvarCtx str = do + doLog <- isLoggingStarted mvarCtx + when doLog $ infoM _LOG_NAME $ "[RESPONSE]" ++ lbs2str str + + ctx <- readMVar mvarCtx + responseHandlerDebugContextData ctx str + + +-- | +-- +-- +sendConsoleEvent :: MVar DebugContextData -> String -> IO () +sendConsoleEvent mvarCtx msg = sendOutputEventWithType mvarCtx msg "console" + + +-- | +-- +-- +sendStdoutEvent :: MVar DebugContextData -> String -> IO () +sendStdoutEvent mvarCtx msg = sendOutputEventWithType mvarCtx msg "stdout" + + +-- | +-- +-- +sendErrorEvent :: MVar DebugContextData -> String -> IO () +sendErrorEvent mvarCtx msg = do + doLog <- isLoggingStarted mvarCtx + when doLog $ errorM _LOG_NAME msg + sendOutputEventWithType mvarCtx msg "stderr" + + +-- | +-- +-- +sendOutputEventWithType :: MVar DebugContextData -> String -> String -> IO () +sendOutputEventWithType mvarCtx msg msgType= do + resSeq <- getIncreasedResponseSequence mvarCtx + let outEvt = J.defaultOutputEvent resSeq + outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody msgType msg Nothing } + sendEvent mvarCtx outEvtStr + + +-- | +-- +sendEvent :: MVar DebugContextData -> BSL.ByteString -> IO () +sendEvent mvarCtx str = do + doLog <- isLoggingStarted mvarCtx + when doLog $ infoM _LOG_NAME $ "[EVENT]" ++ lbs2str str + + ctx <- readMVar mvarCtx + responseHandlerDebugContextData ctx str + + +-- | +-- +sendTerminateEvent :: MVar DebugContextData -> IO () +sendTerminateEvent mvarDat = do + resSeq <- getIncreasedResponseSequence mvarDat + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt + sendEvent mvarDat terminatedEvtStr + + +-- |===================================================================== +-- Handlers + +-- | +-- +-- +handleRequest :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> IO () +handleRequest mvarDat contLenStr jsonStr = do + case J.eitherDecode jsonStr :: Either String J.Request of + Right (J.Request cmd) -> handle cmd + Left err -> sendParseErrorAndTerminate err "request" + + where + sendParseErrorAndTerminate err typ = do + let msg = L.intercalate "\n" + $ [ "[CRITICAL]"++"<"++typ++">"++" request parce error." + , lbs2str contLenStr + , lbs2str jsonStr + , show err, "" + ] ++ _ERR_MSG_URL ++ ["", ""] + sendErrorEvent mvarDat msg + sendTerminateEvent mvarDat + + handle "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of + Right req -> initializeRequestHandler mvarDat req + Left err -> do + let cont = L.intercalate " " $ map U.strip $ lines $ lbs2str contLenStr + json = L.intercalate " " $ map U.strip $ lines $ lbs2str jsonStr + er = L.intercalate " " $ map U.strip $ lines $ show err + msg = L.intercalate " " $ ["[CRITICAL] request parce error.", cont, json, er] ++ _ERR_MSG_URL + resSeq <- getIncreasedResponseSequence mvarDat + sendResponse mvarDat $ J.encode $ J.parseErrorInitializeResponse resSeq msg + sendParseErrorAndTerminate err "initialize" + + handle "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of + Right req -> launchRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "launch" + + handle "configurationDone" = case J.eitherDecode jsonStr :: Either String J.ConfigurationDoneRequest of + Right req -> configurationDoneRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "configurationDone" + + handle "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of + Right req -> disconnectRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "disconnect" + + handle "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of + Right req -> setBreakpointsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "setBreakpoints" + + handle "setFunctionBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetFunctionBreakpointsRequest of + Right req -> setFunctionBreakpointsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "setFunctionBreakpoints" + + handle "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of + Right req -> continueRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "continue" + + handle "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of + Right req -> nextRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "next" + + handle "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of + Right req -> stepInRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "stepIn" + + handle "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of + Right req -> stackTraceRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "stackTrace" + + handle "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of + Right req -> scopesRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "scopes" + + handle "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of + Right req -> variablesRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "variables" + + handle "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of + Right req -> threadsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "threads" + + handle "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of + Right req -> evaluateRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "evaluate" + + handle "completions" = case J.eitherDecode jsonStr :: Either String J.CompletionsRequest of + Right req -> completionsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "completions" + + -- | + -- not supported. + -- + handle "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of + Left err -> sendParseErrorAndTerminate err "stepOut" + Right req -> do + resSeq <- getIncreasedResponseSequence mvarDat + let res = J.defaultStepOutResponse resSeq req + resStr = J.encode $ res{J.successStepOutResponse = False, J.messageStepOutResponse = "unsupported command."} + sendResponse mvarDat resStr + sendErrorEvent mvarDat "[WARN] stepOut command is not supported. ignored." + + handle "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of + Left err -> sendParseErrorAndTerminate err "pause" + Right req -> do + resSeq <- getIncreasedResponseSequence mvarDat + let res = J.defaultPauseResponse resSeq req + resStr = J.encode $ res{J.successPauseResponse = False, J.messagePauseResponse = "unsupported command."} + sendResponse mvarDat resStr + + sendErrorEvent mvarDat "[WARN] pause command is not supported. ignored." + + handle "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of + Left err -> sendParseErrorAndTerminate err "source" + Right req -> do + resSeq <- getIncreasedResponseSequence mvarDat + let res = J.defaultSourceResponse resSeq req + resStr = J.encode $ res{J.successSourceResponse = False, J.messageSourceResponse = "unsupported command."} + sendResponse mvarDat resStr + + sendErrorEvent mvarDat "[WARN] source command is not supported. ignored." + + handle cmd = do + let msg = L.intercalate " " ["[WARN] unknown request command. ignored.", cmd, lbs2str contLenStr, lbs2str jsonStr] + sendErrorEvent mvarDat msg + + +-- | +-- +initializeRequestHandler :: MVar DebugContextData -> J.InitializeRequest -> IO () +initializeRequestHandler mvarCtx req@(J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do + resSeq <- getIncreasedResponseSequence mvarCtx + let capa = J.InitializeResponseCapabilites True True True True True [] False False False False False True + res = J.InitializeResponse resSeq "response" seq True "initialize" "" capa + + sendResponse mvarCtx $ J.encode res + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["initialize request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorInitializeResponse resSeq req msg + sendErrorEvent mvarCtx msg + + +-- | +-- +launchRequestHandler :: MVar DebugContextData -> J.LaunchRequest -> IO () +launchRequestHandler mvarCtx req@(J.LaunchRequest _ _ _ args) = flip E.catches handlers $ do + + -- コンテキストデータの保持 + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx { + workspaceDebugContextData = J.workspaceLaunchRequestArguments args + , startupDebugContextData = J.startupLaunchRequestArguments args + } + + -- ロギング設定 + let logLevelStr = J.logLevelLaunchRequestArguments args + logLevel <- case readMay logLevelStr of + Just lv -> return lv + Nothing -> do + sendErrorEvent mvarCtx $ "log priority is invalid. WARNING set. [" ++ logLevelStr ++ "]\n" + return WARNING + + setupLogger (J.logFileLaunchRequestArguments args) logLevel + + logRequest $ show req + + -- tasks.jsonファイルの準備 + prepareTasksJsonFile + + + -- ghciのランチ + runGHCi mvarCtx (J.ghciCmdLaunchRequestArguments args) (J.ghciPromptLaunchRequestArguments args) >>= ghciLaunched + + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["launch request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorLaunchResponse resSeq req msg + sendErrorEvent mvarCtx $ msg ++ "\n" + + -- | + -- + prepareTasksJsonFile = do + ctx <- readMVar mvarCtx + let jsonFile = workspaceDebugContextData ctx ".vscode" "tasks.json" + + doesFileExist jsonFile >>= \case + True -> debugM _LOG_NAME $ "tasks.json file exists. " ++ jsonFile + False -> do + sendConsoleEvent mvarCtx $ "create tasks.json file. " ++ jsonFile ++ "\n" + saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS + + -- | + -- + ghciLaunched (Left err) = do + let msg = L.intercalate " " ["ghci launch error.", err] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorLaunchResponse resSeq req msg + sendErrorEvent mvarCtx $ msg ++ "\n" + + sendTerminateEvent mvarCtx + + + ghciLaunched (Right ghciProc) = do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{ghciProcessDebugContextData = Just ghciProc} + + startupRes <- loadHsFile mvarCtx (J.startupLaunchRequestArguments args) + + when (False == startupRes) $ do + let msg = L.intercalate " " ["startup load error.", J.startupLaunchRequestArguments args] + sendErrorEvent mvarCtx $ msg ++ "\n" + + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultLaunchResponse resSeq req + + resSeq <- getIncreasedResponseSequence mvarCtx + sendEvent mvarCtx $ J.encode $ J.defaultInitializedEvent resSeq + + -- ファイル変更ウォッチの開始 + watch mvarCtx + +-- | +-- +configurationDoneRequestHandler :: MVar DebugContextData -> J.ConfigurationDoneRequest -> IO () +configurationDoneRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["configurationDone request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorConfigurationDoneResponse resSeq req msg + sendErrorEvent mvarCtx msg + + withProcess Nothing = sendErrorEvent mvarCtx "[withProcess] ghci not started." + + withProcess (Just ghciProc) = do + sendConsoleEvent mvarCtx $ L.intercalate "\n" _DEBUG_START_MSG + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultConfigurationDoneResponse resSeq req + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + +-- | +-- +disconnectRequestHandler :: MVar DebugContextData -> J.DisconnectRequest -> IO () +disconnectRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["disconnect request error.", show req, show e] + sendErrorEvent mvarCtx msg + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req + + withProcess Nothing = do + sendErrorEvent mvarCtx "[disconnectRequestHandler] ghci not started." + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req + + withProcess (Just ghciProc) = G.quit ghciProc outHdl >>= withExitCode + + withExitCode (Left err) = do + sendErrorEvent mvarCtx $ "[disconnectRequestHandler] ghci quit error. " ++ err + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req + + withExitCode (Right code) = do + sendStdoutEvent mvarCtx $ show code + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req + + outHdl = sendStdoutEvent mvarCtx + +-- | +-- +setBreakpointsRequestHandler :: MVar DebugContextData -> J.SetBreakpointsRequest -> IO () +setBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + ctx <- readMVar mvarCtx + let cwd = workspaceDebugContextData ctx + args = J.argumentsSetBreakpointsRequest req + source = J.sourceSetBreakpointsRequestArguments args + path = J.pathSource source + reqBps = J.breakpointsSetBreakpointsRequestArguments args + bps = map (convBp cwd path) reqBps + + delete path + resBody <- insert bps + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultSetBreakpointsResponse resSeq req + resStr = J.encode res{J.bodySetBreakpointsResponse = J.SetBreakpointsResponseBody resBody} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + convBp cwd path (J.SourceBreakpoint lineNo _ cond hitCond) = + BreakPointData { + nameBreakPointData = src2mod cwd path + , filePathBreakPointData = path + , lineNoBreakPointData = lineNo + , breakNoBreakPointData = Nothing + , conditionBreakPointData = normalizeCond cond + , hitConditionBreakPointData = hitCond + , hitCountBreakPointData = 0 + } + + normalizeCond Nothing = Nothing + normalizeCond (Just c) + | null (U.strip c) = Nothing + | otherwise = Just c + + delete path = do + ctx <- takeMVar mvarCtx + let bps = breakPointDatasDebugContextData ctx + newBps = MAP.filterWithKey (\(p,_) _-> path /= p) bps + delBps = MAP.elems $ MAP.filterWithKey (\(p,_) _-> path == p) bps + + putMVar mvarCtx ctx{breakPointDatasDebugContextData = newBps} + + debugM _LOG_NAME $ "del bps:" ++ show delBps + + mapM_ (deleteBreakPointOnGHCi mvarCtx) delBps + + + insert reqBps = do + results <- mapM insertInternal reqBps + let addBps = filter (\(_, (J.Breakpoint _ verified _ _ _ _)) -> verified) results + resData = map snd results + + debugM _LOG_NAME $ "add bps:" ++ show addBps + debugM _LOG_NAME $ "response bps:" ++ show resData + + ctx <- takeMVar mvarCtx + let bps = breakPointDatasDebugContextData ctx + newBps = foldr (\v@(BreakPointData _ p l _ _ _ _)->MAP.insert (p,l) v) bps $ map fst results + putMVar mvarCtx ctx{breakPointDatasDebugContextData = newBps} + + return resData + + + insertInternal reqBp@(BreakPointData modName filePath lineNo _ _ _ _) = do + let src = J.Source (Just modName) filePath Nothing Nothing + + addBreakPointOnGHCi mvarCtx reqBp >>= \case + Right no -> do + --putStrLnStdout mvarCtx $ "set breakpoint on " ++ filePathBreakPointData reqBp ++ ":L" ++ show (lineNoBreakPointData reqBp) + return (reqBp{breakNoBreakPointData = Just no}, J.Breakpoint (Just no) True "" src lineNo 1) + Left err -> return (reqBp, J.Breakpoint Nothing False err src lineNo 1) + +-- | +-- +setFunctionBreakpointsRequestHandler :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> IO () +setFunctionBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let args = J.argumentsSetFunctionBreakpointsRequest req + reqBps = J.breakpointsSetFunctionBreakpointsRequestArguments args + bps = map convBp reqBps + + delete + resBody <- insert bps + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultSetFunctionBreakpointsResponse resSeq req + resStr = J.encode res{J.bodySetFunctionBreakpointsResponse = J.SetFunctionBreakpointsResponseBody resBody} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorSetFunctionBreakpointsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + convBp (J.FunctionBreakpoint name cond hitCond) = + BreakPointData { + nameBreakPointData = name + , filePathBreakPointData = "" + , lineNoBreakPointData = -1 + , breakNoBreakPointData = Nothing + , conditionBreakPointData = normalizeCond cond + , hitConditionBreakPointData = hitCond + , hitCountBreakPointData = 0 + } + + normalizeCond Nothing = Nothing + normalizeCond (Just c) + | null (U.strip c) = Nothing + | otherwise = Just c + + delete = do + ctx <- takeMVar mvarCtx + let bps = functionBreakPointDatasDebugContextData ctx + delBps = MAP.elems bps + + putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = MAP.fromList []} + + debugM _LOG_NAME $ "del bps:" ++ show delBps + + mapM_ (deleteBreakPointOnGHCi mvarCtx) delBps + + + insert reqBps = do + results <- mapM insertInternal reqBps + let addBps = filter (\(_, (J.Breakpoint _ verified _ _ _ _)) -> verified) results + resData = map snd results + + debugM _LOG_NAME $ "add funBPs:" ++ show addBps + debugM _LOG_NAME $ "response funBPs:" ++ show resData + + ctx <- takeMVar mvarCtx + let bps = functionBreakPointDatasDebugContextData ctx + newBps = foldr (\v@(BreakPointData _ p l _ _ _ _)->MAP.insert (p,l) v) bps $ map fst results + putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = newBps} + + return resData + + + insertInternal reqBp@(BreakPointData funcName _ _ _ _ _ _) = do + addFunctionBreakPointOnGHCi mvarCtx reqBp >>= \case + Right (no, (G.SourcePosition path sl sc _ _)) -> do + --putStrLnStdout mvarCtx $ "set breakpoint on " ++ filePathBreakPointData reqBp ++ ":L" ++ show (lineNoBreakPointData reqBp) + return ( reqBp{ breakNoBreakPointData = Just no + , filePathBreakPointData = path + , lineNoBreakPointData = sl + } + , J.Breakpoint (Just no) True "" (J.Source (Just funcName) path Nothing Nothing) sl sc) + Left err -> return (reqBp, J.Breakpoint Nothing False err (J.Source (Just funcName) "" Nothing Nothing) (-1) (-1)) + +-- | +-- +-- +continueRequestHandler :: MVar DebugContextData -> J.ContinueRequest -> IO () +continueRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + resSeq <- getIncreasedResponseSequence mvarCtx + let resStr = J.encode $ J.defaultContinueResponse resSeq req + sendResponse mvarCtx resStr + + proceedDebug mvarCtx + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["continue request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorContinueResponse resSeq req msg + sendErrorEvent mvarCtx msg + + +-- | +-- +-- +nextRequestHandler :: MVar DebugContextData -> J.NextRequest -> IO () +nextRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + ctx <- readMVar mvarCtx + case debugStoppedPosDebugContextData ctx of + Nothing -> do + resSeq <- getIncreasedResponseSequence 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 mvarCtx resStr + Just _ -> next + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["stepOver request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorNextResponse resSeq req msg + sendErrorEvent mvarCtx msg + + next = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + withProcess Nothing = sendErrorEvent mvarCtx "[nextRequestHandler] ghci not started." + + withProcess (Just ghciProc) = G.stepLocal ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + sendTerminateEvent mvarCtx + + Right pos -> do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultNextResponse resSeq req + resStr = J.encode res + sendResponse mvarCtx resStr + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- +-- +stepInRequestHandler :: MVar DebugContextData -> J.StepInRequest -> IO () +stepInRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + ctx <- readMVar mvarCtx + case debugStoppedPosDebugContextData ctx of + Nothing -> do + resSeq <- getIncreasedResponseSequence 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 mvarCtx resStr + Just _ -> stepIn + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["stepIn request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorStepInResponse resSeq req msg + sendErrorEvent mvarCtx msg + + stepIn = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + withProcess Nothing = sendErrorEvent mvarCtx "[stepInRequestHandler] ghci not started." + + withProcess (Just ghciProc) = G.step ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + sendTerminateEvent mvarCtx + + Right pos -> do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultStepInResponse resSeq req + resStr = J.encode res + sendResponse mvarCtx resStr + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- +-- +stackTraceRequestHandler :: MVar DebugContextData -> J.StackTraceRequest -> IO () +stackTraceRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + ctx <- readMVar mvarCtx + case debugStoppedPosDebugContextData ctx of + Nothing -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let body = J.StackTraceBody [] 0 + res = J.defaultStackTraceResponse resSeq req + resStr = J.encode $ res{J.bodyStackTraceResponse = body} + sendResponse mvarCtx resStr + + Just rangeData -> do + frames <- createStackFrames rangeData + debugM _LOG_NAME $ show frames + + resSeq <- getIncreasedResponseSequence mvarCtx + let body = J.StackTraceBody (reverse frames) (length frames) + res = J.defaultStackTraceResponse resSeq req + resStr = J.encode $ res{J.bodyStackTraceResponse = body} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["stackTrace request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorStackTraceResponse resSeq req msg + sendErrorEvent mvarCtx msg + + createStackFrames pos = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess pos + + withProcess pos Nothing = do + sendErrorEvent mvarCtx "[stackTraceRequestHandler] ghci not started." + defaultFrame pos + + withProcess pos (Just ghciProc) = G.history ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + defaultFrame pos + + Right dats -> do + cwd <- workspaceDebugContextData <$> readMVar mvarCtx + cfs <- defaultFrame pos + foldM (convTrace2Frame cwd) cfs dats + + convTrace2Frame cwd xs (G.StackFrame traceId funcName (G.SourcePosition file sl sc el ec)) = return $ + J.StackFrame traceId funcName (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec : xs + + defaultFrame (G.SourcePosition file sl sc el ec) = do + ctx <- readMVar mvarCtx + let cwd = workspaceDebugContextData ctx + csf = J.StackFrame 0 "[BP]" (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec + return [csf] + + outHdl = debugM _LOG_NAME + + +-- | +-- +-- +scopesRequestHandler :: MVar DebugContextData -> J.ScopesRequest -> IO () +scopesRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let args = J.argumentsScopesRequest req + traceId = J.frameIdScopesArguments args + + moveFrame mvarCtx traceId + + resSeq <- getIncreasedResponseSequence mvarCtx + let resStr = J.encode $ J.defaultScopesResponse resSeq req + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["scopes request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorScopesResponse resSeq req msg + sendErrorEvent mvarCtx msg + +-- | +-- +-- +variablesRequestHandler :: MVar DebugContextData -> J.VariablesRequest -> IO () +variablesRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + vals <- currentBindings + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultVariablesResponse resSeq req + resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["variables request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorVariablesResponse resSeq req msg + sendErrorEvent mvarCtx msg + + currentBindings = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + withProcess Nothing = do + sendErrorEvent mvarCtx "[variablesRequestHandler] ghci not started." + return [] + + withProcess (Just ghciProc) = G.bindings ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + return [] + + Right dats -> return $ map convBind2Vals dats + + convBind2Vals (G.BindingData varName modName val) = J.Variable varName modName val 0 + + outHdl = debugM _LOG_NAME + + +-- | +-- +-- +threadsRequestHandler :: MVar DebugContextData -> J.ThreadsRequest -> IO () +threadsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + resSeq <- getIncreasedResponseSequence mvarCtx + let resStr = J.encode $ J.defaultThreadsResponse resSeq req + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["threads request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorThreadsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + +-- | +-- +-- +evaluateRequestHandler :: MVar DebugContextData -> J.EvaluateRequest -> IO () +evaluateRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let (J.EvaluateArguments exp _ ctx) = J.argumentsEvaluateRequest req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess ctx exp + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["evaluate request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorEvaluateResponse resSeq req msg + sendErrorEvent mvarCtx msg + + withProcess _ _ Nothing = sendErrorEvent mvarCtx "[evaluateRequestHandler] ghci not started." + + withProcess "watch" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case + Left err -> do + errorM _LOG_NAME $ show err + evaluateResponse err "" + + Right typeStr -> case isFunction typeStr of + True -> evaluateResponse "" (getOnlyType typeStr) + False -> G.force ghciProc outHdl exp >>= \case + Right valStr -> evaluateResponse (getOnlyValue valStr) (getOnlyType typeStr) + Left _ -> evaluateResponse "" (getOnlyType typeStr) + + withProcess "hover" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case + Left err -> do + errorM _LOG_NAME $ show err + evaluateResponse err "" + Right typeStr -> evaluateResponse typeStr (getOnlyType typeStr) + + withProcess _ exp (Just ghciProc) + | null (U.strip exp) = do + evaluateResponse "" "" + sendStdoutEvent mvarCtx (G.promptGHCiProcess ghciProc) + | otherwise = replHandler ghciProc $ map U.rstrip (lines exp) + + replHandler _ [] = do + errorM _LOG_NAME "[replHandler] invalid inputs." + evaluateResponse "" "" + + replHandler ghciProc (exp:[]) + | isPermitCmd (U.strip exp) = G.exec ghciProc outHdl exp >>= \case + Left err -> do + errorM _LOG_NAME $ show err + evaluateResponse "" "" + sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ show err + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + Right cmdStr -> do + evaluateResponse "" "" + sendStdoutEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ cmdStr + | otherwise = do + evaluateResponse "" "" + sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n can not use these commands.\n" ++ show _NOT_PERMIT_REPL_COMMANDS ++ "\n" + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + + replHandler ghciProc exps = G.exec ghciProc outHdl ":{" >>= \case + Left err -> do + errorM _LOG_NAME $ show err + evaluateResponse "" "" + sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ ":{\n" ++ show err + Right cmdStr -> replsHandler ghciProc (exps ++ [":}"]) $ (G.promptGHCiProcess ghciProc) ++ ":{\n" ++ cmdStr + + replsHandler _ [] acc = do + evaluateResponse "" "" + sendStdoutEvent mvarCtx acc + + replsHandler ghciProc (x:xs) acc + | isPermitCmd (U.strip x) = G.exec ghciProc outHdl x >>= \case + Left err -> do + evaluateResponse "" "" + sendErrorEvent mvarCtx $ acc ++ x ++ "\n" ++ show err + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + + Right cmdStr -> replsHandler ghciProc xs $ acc ++ x ++ "\n" ++ cmdStr + | otherwise = do + evaluateResponse "" "" + sendErrorEvent mvarCtx $ acc ++ x ++ "\n can not use these commands.\n" ++ show _NOT_PERMIT_REPL_COMMANDS ++ "\n" + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + + isPermitCmd c = 0 == (length ( filter (flip U.startswith c) _NOT_PERMIT_REPL_COMMANDS)) + + outHdl = debugM _LOG_NAME + + isFunction str = case parse isFunctionParser "isFunction" str of + Right _ -> True + Left _ -> False + + isFunctionParser = manyTill anyChar (string "->") + + evaluateResponse msg typeStr = do + resSeq <- getIncreasedResponseSequence mvarCtx + let body = J.EvaluateBody msg typeStr 0 + res = J.defaultEvaluateResponse resSeq req + resStr = J.encode res{J.bodyEvaluateResponse = body} + sendResponse mvarCtx resStr + + -- | + -- force結果のパーサ + -- + -- parser of + -- Phoityne>>= :force x + -- x = 8 + -- Phoityne>>= + -- + getOnlyValue :: String -> String + getOnlyValue str = case parse getOnlyValueParser "getOnlyValue" str of + Right vals -> vals + Left _ -> str + where + getOnlyValueParser = do + _ <- manyTill anyChar (string " = ") + manyTill anyChar eof + + -- | + -- type結果のパーサ + -- + -- parser of + -- Phoityne>>= :type x + -- x :: Int -> Int + -- Phoityne>>= + -- + getOnlyType :: String -> String + getOnlyType str = case parse getOnlyTypeParser "getOnlyType" str of + Right vals -> vals + Left _ -> str + where + getOnlyTypeParser = do + _ <- manyTill anyChar (string " :: ") + manyTill anyChar eof + + +-- | +-- +-- +completionsRequestHandler :: MVar DebugContextData -> J.CompletionsRequest -> IO () +completionsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let (J.CompletionsArguments _ key _ _) = J.argumentsCompletionsRequest req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess key + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["completions request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorCompletionsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + withProcess _ Nothing = sendErrorEvent mvarCtx "[completionsRequestHandler] ghci not started." + + withProcess key (Just ghciProc) = G.complete ghciProc outHdl key 50 >>= \case + Left err -> do + errorM _LOG_NAME $ show err + resSeq <- getIncreasedResponseSequence mvarCtx + let resStr = J.encode $ J.errorCompletionsResponse resSeq req $ show err + sendResponse mvarCtx resStr + + Right xs -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let bd = J.CompletionsResponseBody $ map createItem xs + res = J.defaultCompletionsResponse resSeq req + + let resStr = J.encode $ res {J.bodyCompletionsResponse = bd} + sendResponse mvarCtx resStr + + createItem (':':xs) = J.CompletionsItem xs + createItem xs = J.CompletionsItem xs + + outHdl = debugM _LOG_NAME + + +-- |===================================================================== +-- +-- Utility + +-- | +-- +-- +src2mod :: FilePath -> FilePath -> String +src2mod cwd src + | length cwd >= length src = "" + | otherwise = L.intercalate "." + $ map takeBaseName + $ reverse + $ takeWhile startUpperCase + $ reverse + $ splitOneOf [_SEP_WIN, _SEP_UNIX] + $ drop (length cwd) src + + where + startUpperCase modName + | null modName = True + | otherwise = isUpper $ head modName + + +-- | +-- +-- +getIncreasedResponseSequence :: MVar DebugContextData -> IO Int +getIncreasedResponseSequence mvarCtx = do + ctx <- takeMVar mvarCtx + let resSec = 1 + resSeqDebugContextData ctx + putMVar mvarCtx ctx{resSeqDebugContextData = resSec} + return resSec + + +-- | +-- +-- +runGHCi :: MVar DebugContextData -> String -> String -> IO (Either G.ErrorData G.GHCiProcess) +runGHCi mvarCtx cmdStr pmt = do + ctx <- readMVar mvarCtx + let cmdList = filter (not.null) $ U.split " " cmdStr + cmd = head cmdList + opts = tail cmdList + cwd = workspaceDebugContextData ctx + + G.start outHdl cmd opts cwd pmt + + where + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- +-- +loadHsFile :: MVar DebugContextData -> FilePath -> IO Bool +loadHsFile mvarCtx path = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case + Nothing -> do + sendErrorEvent mvarCtx $ "load file fail.[" ++ path ++ "]" ++ " ghci not started." + return False + Just ghciProc -> G.loadFile ghciProc outHdl path >>= withFileLoadResult ghciProc + + where + outHdl msg = do + sendStdoutEvent mvarCtx msg + + withFileLoadResult _ (Left err) = do + sendErrorEvent mvarCtx $ "load file fail.[" ++ path ++ "]" ++ " " ++ err + return False + + withFileLoadResult ghciProc (Right mods) = G.loadModule ghciProc outHdl mods >>= \case + Left err -> do + sendErrorEvent mvarCtx $ "load module fail. " ++ show mods ++ " " ++ err + return False + Right _ -> return True + + +-- | +-- ブレークポイントをGHCi上でdeleteする +-- +deleteBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO () +deleteBreakPointOnGHCi mvarCtx bp@(BreakPointData _ _ _ (Just breakNo) _ _ _) = + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case + Nothing -> sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] ghci not started. " ++ show bp + Just ghciProc -> G.delete ghciProc outHdl breakNo >>= withResult + + where + outHdl = sendStdoutEvent mvarCtx + + withResult (Left err) = sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] " ++ err ++ " " ++ show bp + withResult (Right _) = return () + +deleteBreakPointOnGHCi mvarCtx bp = sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] invalid delete break point. " ++ show bp + +-- | +-- GHCi上でブレークポイントを追加する +-- +addBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String Int) +addBreakPointOnGHCi mvarCtx bp@(BreakPointData modName _ lineNo _ _ _ _) = + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case + Nothing -> do + errorM _LOG_NAME $ "[addBreakPointOnGHCi] ghci not started. " ++ show bp + return $ Left $ "[addBreakPointOnGHCi] ghci not started. " ++ show bp + Just ghciProc -> G.setBreak ghciProc outHdl modName lineNo + + where + outHdl = sendStdoutEvent mvarCtx + +-- | +-- GHCi上で関数ブレークポイントを追加する +-- +addFunctionBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String (Int, G.SourcePosition)) +addFunctionBreakPointOnGHCi mvarCtx bp@(BreakPointData name _ _ _ _ _ _) = + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case + Nothing -> do + errorM _LOG_NAME $ "[addFunctionBreakPointOnGHCi] ghci not started. " ++ show bp + return $ Left $ "[addFunctionBreakPointOnGHCi] ghci not started. " ++ show bp + Just ghciProc -> G.setFuncBreak ghciProc outHdl name + + where + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- Loggerのセットアップ +-- +setupLogger :: FilePath -> Priority -> IO () +setupLogger logFile level = do + 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 :: MVar DebugContextData -> IO () +watch mvarCtx = do + _ <- forkIO $ watchFiles mvarCtx + return () + +watchFiles :: MVar DebugContextData -> IO () +watchFiles mvarCtx = do + FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce = FSN.Debounce 1} $ \mgr -> do + + ctx <- readMVar mvarCtx + let dir = workspaceDebugContextData ctx + + debugM _LOG_NAME $ "start watch files in [" ++ dir ++ "]" + _ <- FSN.watchTree mgr dir hsFilter action + + forever $ threadDelay 1000000 + + return () + + where + hsFilter event = U.endswith _HS_FILE_EXT $ FSN.eventPath event + + action event = do + + ctx <- readMVar mvarCtx + withDebugStarted event $ debugStartedDebugContextData ctx + + withDebugStarted _ True = do + resSeq <- getIncreasedResponseSequence mvarCtx + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True} + sendEvent mvarCtx terminatedEvtStr + + withDebugStarted event False = do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{modifiedDebugContextData = True} + loadHsFile mvarCtx (FSN.eventPath event) >> return () + + +-- | +-- +-- +moveFrame :: MVar DebugContextData -> Int -> IO () +moveFrame mvarCtx traceId = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + where + withProcess Nothing = sendErrorEvent mvarCtx "[moveFrame] ghci not started." + withProcess (Just ghciProc) = do + ctx <- readMVar mvarCtx + let curTraceId = currentFrameIdDebugContextData ctx + moveCount = curTraceId - traceId + traceCmd = if 0 > moveCount then G.back ghciProc outHdl + else G.forward ghciProc outHdl + + -- _ <- traceCmd (abs moveCount) + mapM_ traceCmd [1..(abs moveCount)] + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{currentFrameIdDebugContextData = traceId} + + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- +-- +proceedDebug :: MVar DebugContextData -> IO () +proceedDebug mvarCtx = do + ctx <- readMVar mvarCtx + let started = debugStartedDebugContextData ctx + proc = ghciProcessDebugContextData ctx + + proceed started proc + + where + -- | + -- + proceed _ Nothing = sendErrorEvent mvarCtx "[proceedDebug] ghci not started." + proceed True (Just ghciProc) = G.trace ghciProc outHdl >>= \case + Left err -> do + -- end of debugging + debugM _LOG_NAME $ show err + resSeq <- getIncreasedResponseSequence mvarCtx + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt + sendEvent mvarCtx terminatedEvtStr + + Right pos -> breakOrContinue pos + + proceed False (Just ghciProc) = do + ctx <- readMVar mvarCtx + withModified (modifiedDebugContextData ctx) ghciProc + + -- | + -- + withModified True _ = do + resSeq <- getIncreasedResponseSequence mvarCtx + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True} + sendEvent mvarCtx terminatedEvtStr + + withModified False ghciProc = G.traceMain ghciProc outHdl >>= \case + Left err -> do + -- end of debugging + debugM _LOG_NAME $ show err + resSeq <- getIncreasedResponseSequence mvarCtx + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt + sendEvent mvarCtx terminatedEvtStr + + Right pos -> do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{currentFrameIdDebugContextData = 0, debugStartedDebugContextData = True} + breakOrContinue pos + + breakOrContinue pos = findBreakPointType mvarCtx pos >>= \case + UnknownBreakPoint -> do + sendErrorEvent mvarCtx $ "[proceedDebug] invalid break point status. " ++ show pos + sendTerminateEvent mvarCtx + + SourceBreakPoint bp -> do + breakOrContinueSourceBreakPoint mvarCtx bp >>= \case + DoBreak -> sendStopEvent pos + DoContinue -> proceedDebug mvarCtx + DoError m -> do + sendErrorEvent mvarCtx m + sendTerminateEvent mvarCtx + + FunctionBreakPoint bp -> do + breakOrContinueFunctionBreakPoint mvarCtx bp >>= \case + DoBreak -> sendStopEvent pos + DoContinue -> proceedDebug mvarCtx + DoError m -> do + sendErrorEvent mvarCtx m + sendTerminateEvent mvarCtx + + -- | + -- + outHdl = sendStdoutEvent mvarCtx + + -- | + -- + sendStopEvent pos = do + debugM _LOG_NAME $ show pos + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + + +-- | +-- +data BreakPointType = + SourceBreakPoint BreakPointData + | FunctionBreakPoint BreakPointData + | UnknownBreakPoint deriving (Show, Read, Eq) + + +-- | +-- +data BreakOrContinueType = DoBreak | DoContinue | DoError String deriving (Show, Read, Eq) + + +-- | +-- +findBreakPointType :: MVar DebugContextData -> G.SourcePosition -> IO BreakPointType +findBreakPointType mvarCtx pos = do + ctx <- readMVar mvarCtx + + let bpKey = getKeyOfSourcePosition pos + bpMap = breakPointDatasDebugContextData ctx + funcMap = functionBreakPointDatasDebugContextData ctx + + case MAP.lookup bpKey bpMap of + Just bp -> return $ SourceBreakPoint bp + Nothing -> case MAP.lookup bpKey funcMap of + Just bp -> return $ FunctionBreakPoint bp + Nothing -> return UnknownBreakPoint + + +-- | +-- +breakOrContinueSourceBreakPoint :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType +breakOrContinueSourceBreakPoint mvarCtx bp = do + ctx <- takeMVar mvarCtx + let bpMap = breakPointDatasDebugContextData ctx + newMap = MAP.adjust incrementBreakPointHitCount (getBreakPointKey bp) bpMap + putMVar mvarCtx ctx{breakPointDatasDebugContextData = newMap} + + breakOrContinueByCondition mvarCtx $ incrementBreakPointHitCount bp + + +-- | +-- +breakOrContinueFunctionBreakPoint :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType +breakOrContinueFunctionBreakPoint mvarCtx bp = do + ctx <- takeMVar mvarCtx + let bpMap = functionBreakPointDatasDebugContextData ctx + newMap = MAP.adjust incrementBreakPointHitCount (getBreakPointKey bp) bpMap + putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = newMap} + + breakOrContinueByCondition mvarCtx $ incrementBreakPointHitCount bp + +-- | +-- +breakOrContinueByCondition :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType +breakOrContinueByCondition _ (BreakPointData _ _ _ _ Nothing Nothing _) = return DoBreak +breakOrContinueByCondition _ (BreakPointData _ _ _ _ Nothing (Just hitCond) hitCount) = breakOrContinueByHitCount hitCond hitCount +breakOrContinueByCondition mvarCtx (BreakPointData _ _ _ _ (Just condStr) Nothing _) = breakOrContinueByOpCond mvarCtx condStr +breakOrContinueByCondition mvarCtx (BreakPointData _ _ _ _ (Just condStr) (Just hitCond) hitCount) = + breakOrContinueByHitCount hitCond hitCount >>= \case + DoError m -> return $ DoError m + DoContinue -> return DoContinue + DoBreak -> breakOrContinueByOpCond mvarCtx condStr + +-- | +-- +breakOrContinueByOpCond :: MVar DebugContextData -> String -> IO BreakOrContinueType +breakOrContinueByOpCond mvarCtx condStr = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + where + -- | + -- + withProcess Nothing = return $ DoError "[breakOrContinueByOpCond] ghci not started." + withProcess (Just ghciProc) = do + forceBindings ghciProc outHdl + G.execBool ghciProc outHdl condStr >>= \case + Left err -> return . DoError $ "[breakOrContinueByCondition] " ++ err ++ ". '" ++ condStr ++ "'" + Right False -> do + debugM _LOG_NAME $ "continued because condition False. " ++ condStr + return DoContinue + Right True -> do + debugM _LOG_NAME $ "stopped because condition not False. " ++ condStr + return DoBreak + + -- | + -- + outHdl msg = do + sendStdoutEvent mvarCtx msg + debugM _LOG_NAME msg + + -- | + -- + forceBindings ghciProc outHdl = G.bindings ghciProc outHdl >>= \case + Left err -> sendErrorEvent mvarCtx $ "[forceBindings] " ++ err + Right bs -> mapM_ (forceBind ghciProc outHdl . G.nameBindingData) bs + + forceBind ghciProc outHdl name = G.force ghciProc outHdl name >>= \case + Left err -> sendErrorEvent mvarCtx $ "[forceBindings] " ++ err + Right _ -> return () + + +-- | +-- +breakOrContinueByHitCount :: String -> Int -> IO BreakOrContinueType +breakOrContinueByHitCount hitCondStr hitCount = case parse hitCondParser "Hit count condition parser" (U.strip hitCondStr) of + Left msg -> return . DoError $ show msg ++ ". '" ++ hitCondStr ++ "'" + Right func -> if func hitCount + then do + debugM _LOG_NAME $ "stopped because satisfy hit count. " ++ hitCondStr ++ ", " ++ show hitCount + return DoBreak + else do + debugM _LOG_NAME $ "continued because not satisfy hit count. " ++ hitCondStr ++ ", " ++ show hitCount + return DoContinue + + where + -- | + -- + hitCondParser = try digitCondParser <|> opCondParser + + -- | + -- + digitCondParser = do + valStr <- manyTill digit eof + return $ (<=) (read valStr) + + -- | + -- + opCondParser = do + op <- manyTill anyChar (space <|> lookAhead digit) + many space + valStr <- manyTill digit eof + let val = read valStr + case op of + "==" -> return $ (==) val + "/=" -> return $ (/=) val + "<" -> return $ flip (<) val + ">" -> return $ flip (>) val + "<=" -> return $ flip (<=) val + ">=" -> return $ flip (>=) val + "%" -> return $ modInternal val + "mod" -> return $ modInternal val + other -> fail other + + -- | + -- + modInternal :: Int -> Int -> Bool + modInternal a b = mod b a == 0 + diff --git a/app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs b/app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs --- a/app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs +++ b/app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs @@ -11,8 +11,9 @@ -- data FunctionBreakpoint = FunctionBreakpoint { - nameFunctionBreakpoint :: String -- The name of the function. - , conditionFunctionBreakpoint :: Maybe String -- An optional expression for conditional breakpoints. + nameFunctionBreakpoint :: String -- The name of the function. + , conditionFunctionBreakpoint :: Maybe String -- An optional expression for conditional breakpoints. + , hitConditionFunctionBreakpoint :: Maybe String -- An optional expression that controls how many hits of the breakpoint are ignored. The backend is expected to interpret the expression as needed. } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "FunctionBreakpoint") } ''FunctionBreakpoint) diff --git a/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs --- a/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs +++ b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs @@ -13,17 +13,18 @@ -- data InitializeResponseCapabilites = InitializeResponseCapabilites { - supportsConfigurationDoneRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the configurationDoneRequest. - , supportsFunctionBreakpointsInitializeResponseCapabilites :: Bool -- The debug adapter supports functionBreakpoints. - , supportsConditionalBreakpointsInitializeResponseCapabilites :: Bool -- The debug adapter supports conditionalBreakpoints. - , supportsEvaluateForHoversInitializeResponseCapabilites :: Bool -- The debug adapter supports a (side effect free) evaluate request for data hovers. - , exceptionBreakpointFiltersInitializeResponseCapabilites :: [ExceptionBreakpointsFilter] -- Available filters for the setExceptionBreakpoints request. - , supportsStepBackInitializeResponseCapabilites :: Bool -- The debug adapter supports stepping back. - , supportsSetVariableInitializeResponseCapabilites :: Bool -- The debug adapter supports setting a variable to a value. - , supportsRestartFrameInitializeResponseCapabilites :: Bool -- The debug adapter supports restarting a frame. - , supportsGotoTargetsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the gotoTargetsRequest. - , supportsStepInTargetsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the stepInTargetsRequest. - , supportsCompletionsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the completionsRequest. + supportsConfigurationDoneRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the configurationDoneRequest. + , supportsFunctionBreakpointsInitializeResponseCapabilites :: Bool -- The debug adapter supports functionBreakpoints. + , supportsConditionalBreakpointsInitializeResponseCapabilites :: Bool -- The debug adapter supports conditionalBreakpoints. + , supportsHitConditionalBreakpointsInitializeResponseCapabilites :: Bool -- The debug adapter supports breakpoints that break execution after a specified number of hits. + , supportsEvaluateForHoversInitializeResponseCapabilites :: Bool -- The debug adapter supports a (side effect free) evaluate request for data hovers. + , exceptionBreakpointFiltersInitializeResponseCapabilites :: [ExceptionBreakpointsFilter] -- Available filters for the setExceptionBreakpoints request. + , supportsStepBackInitializeResponseCapabilites :: Bool -- The debug adapter supports stepping back. + , supportsSetVariableInitializeResponseCapabilites :: Bool -- The debug adapter supports setting a variable to a value. + , supportsRestartFrameInitializeResponseCapabilites :: Bool -- The debug adapter supports restarting a frame. + , supportsGotoTargetsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the gotoTargetsRequest. + , supportsStepInTargetsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the stepInTargetsRequest. + , supportsCompletionsRequestInitializeResponseCapabilites :: Bool -- The debug adapter supports the completionsRequest. } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilites") } ''InitializeResponseCapabilites) @@ -31,5 +32,5 @@ -- | -- defaultInitializeResponseCapabilites :: InitializeResponseCapabilites -defaultInitializeResponseCapabilites = InitializeResponseCapabilites False False False False [] False False False False False False +defaultInitializeResponseCapabilites = InitializeResponseCapabilites False False False False False [] False False False False False False diff --git a/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs b/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs --- a/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs +++ b/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs @@ -11,9 +11,10 @@ -- data SourceBreakpoint = SourceBreakpoint { - lineSourceBreakpoint :: Int -- The source line of the breakpoint. - , columnSourceBreakpoint :: Maybe Int -- An optional source column of the breakpoint. - , conditionSourceBreakpoint :: Maybe String -- An optional expression for conditional breakpoints. + lineSourceBreakpoint :: Int -- The source line of the breakpoint. + , columnSourceBreakpoint :: Maybe Int -- An optional source column of the breakpoint. + , conditionSourceBreakpoint :: Maybe String -- An optional expression for conditional breakpoints. + , hitConditionSourceBreakpoint :: Maybe String -- An optional expression that controls how many hits of the breakpoint are ignored. The backend is expected to interpret the expression as needed. } deriving (Show, Read, Eq) $(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceBreakpoint") } ''SourceBreakpoint) diff --git a/phoityne-vscode.cabal b/phoityne-vscode.cabal --- a/phoityne-vscode.cabal +++ b/phoityne-vscode.cabal @@ -1,5 +1,5 @@ name: phoityne-vscode -version: 0.0.10.0 +version: 0.0.11.0 synopsis: ghci debug viewer on Visual Studio Code description: Please see README.md license: BSD3