phoityne-vscode 0.0.10.0 → 0.0.11.0

raw patch · 6 files changed

+1751/−1761 lines, 6 files

Files

README.md +26/−5
app/Phoityne/VSCode/IO/Core.hs +1704/−1738
app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs +3/−2
app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs +13/−12
app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs +4/−3
phoityne-vscode.cabal +1/−1

README.md view

@@ -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)

app/Phoityne/VSCode/IO/Core.hs view

@@ -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]<initialize> 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+

app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs view

@@ -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)

app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs view

@@ -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

app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs view

@@ -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)

phoityne-vscode.cabal view

@@ -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