phoityne-vscode-0.0.6.0: app/Phoityne/IO/GUI/Control.hs
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Phoityne.IO.GUI.Control (
run
, DebugCommandData(..)
) where
import Phoityne.Constant
import Phoityne.Utility
import Phoityne.IO.Utility
import qualified Phoityne.IO.GUI.VSCode.TH.BreakpointJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ContinueRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ContinueResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.DisconnectRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.DisconnectResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.EvaluateArgumentsJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.EvaluateBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.EvaluateRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.EvaluateResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.InitializedEventJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.InitializeRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.InitializeResponseCapabilitesJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.InitializeResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.LaunchRequestArgumentsJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.LaunchRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.LaunchResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.NextRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.NextResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.OutputEventJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.OutputEventBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.PauseRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.PauseResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.RequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ScopesArgumentsJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ScopesRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ScopesResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestArgumentsJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SourceBreakpointJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SourceJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SourceRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SourceResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StackFrameJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StackTraceBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StackTraceRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StackTraceResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StepInRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StepInResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StepOutRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StepOutResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StoppedEventJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.TerminatedEventJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.TerminatedEventBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ThreadsRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ThreadsResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.VariableJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.VariablesBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.VariablesRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.VariablesResponseJSON as J
import System.IO
import System.Exit
import System.FilePath
import System.Directory
import System.Log.Logger
import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy as BSL
import Text.Parsec
import Data.String.Utils
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 Data.Maybe
import Data.Functor.Identity
import Control.Monad
import qualified System.FSNotify as FSN
import qualified System.Log.Logger as L
import qualified System.Log.Formatter as L
import qualified System.Log.Handler as LH
import qualified System.Log.Handler.Simple as LHS
import Safe
-- |
--
--
data DebugContext =
DebugContext {
resSeqDebugContext :: Int
, breakPointDatasDebugContext :: BreakPointDatas
, workspaceDebugContext :: FilePath
, startupDebugContext :: FilePath
, debugStartedDebugContext :: Bool
, debugStoppedPosDebugContext :: Maybe HighlightTextRangeData
, currentFrameIdDebugContext :: Int
, modifiedDebugContext :: Bool
} deriving (Show, Read, Eq, Ord)
-- |
--
--
data DebugCommandData =
DebugCommandData {
startDebugCommandData :: String -> [String] -> FilePath -> IO ()
, stopDebugCommandData :: IO ExitCode
, readDebugCommandData :: IO String
, readLinesDebugCommandData :: ([String] -> IO Bool) -> IO [String]
, promptDebugCommandData :: IO String
, breakDebugCommandData :: ModuleName -> Int -> IO String
, bindingsDebugCommandData :: IO String
, runDebugCommandData :: Bool -> IO String
, continueDebugCommandData :: Bool -> IO String
, stepDebugCommandData :: IO String
, stepOverDebugCommandData :: IO String
, printEvldDebugCommandData :: IO String
, deleteBreakDebugCommandData :: Int -> IO String
, traceHistDebugCommandData :: IO String
, traceBackDebugCommandData :: IO String
, traceForwardDebugCommandData :: IO String
, forceDebugCommandData :: String -> IO String
, execCommandData :: String -> IO String
, quitDebugCommandData :: IO String
, buildStartDebugCommandData :: FilePath -> IO ()
, cleanStartDebugCommandData :: FilePath -> IO ()
, loadFileDebugCommandData :: FilePath -> IO String
, readWhileDebugCommandData :: (String -> Bool) -> IO String
, infoDebugCommandData :: String -> IO String
, typeDebugCommandData :: String -> IO String
, moduleDebugCommandData :: String -> IO String
, envSetPromptDebugCommandData :: String -> IO ()
, envGetPromptDebugCommandData :: IO String
}
-- |
--
--
data HighlightTextRangeData = HighlightTextRangeData {
filePathHighlightTextRangeData :: FilePath
, startLineNoHighlightTextRangeData :: Int
, startColNoHighlightTextRangeData :: Int
, endLineNoHighlightTextRangeData :: Int
, endColNoHighlightTextRangeData :: Int
} deriving (Show, Read, Eq, Ord)
-- |
--
--
data BreakPointData =
BreakPointData {
moduleNameBreakPointData :: String
, filePathBreakPointData :: FilePath
, lineNoBreakPointData :: Int
, breakNoBreakPointData :: Maybe Int
, conditionBreakPointData :: Maybe String
} deriving (Show, Read, Eq, Ord)
-- |
--
--
data TraceData = TraceData {
traceIdTraceData :: String
, functionTraceData :: String
, filePathTraceData :: String
} deriving (Show, Read, Eq, Ord)
-- |
--
--
data BindingData = BindingData {
varNameBindingData :: String
, modNameBindingData :: String
, valueBindingData :: 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 $ Data.String.Utils.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 --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"
]
-- |
--
--
defaultDebugContext :: DebugContext
defaultDebugContext = DebugContext _INITIAL_RESPONSE_SEQUENCE (MAP.fromList []) "" "" False Nothing 0 False
-- |
--
--
getKeyOfHighlightTextRangeData :: HighlightTextRangeData -> BreakPointDataKey
getKeyOfHighlightTextRangeData (HighlightTextRangeData file line _ _ _) = (file, line)
-- |
--
--
run :: DebugCommandData -> IO ()
run cmdData = do
hSetBuffering stdin NoBuffering
hSetEncoding stdin utf8
hSetBuffering stdout NoBuffering
hSetEncoding stdout utf8
mvarCtx <- newMVar defaultDebugContext
wait cmdData mvarCtx
-- |
--
--
wait :: DebugCommandData -> MVar DebugContext -> IO ()
wait cmdData mvarCtx = go BSL.empty
where
go :: BSL.ByteString -> IO ()
go buf = do
c <- BSL.hGet stdin 1
let newBuf = BSL.append buf c
case readContentLength (lbs2str newBuf) of
Left _ -> go newBuf
Right len -> do
cnt <- BSL.hGet stdin len
handleRequest cmdData mvarCtx newBuf cnt
where
readContentLength :: String -> Either ParseError Int
readContentLength = parse parser "readContentLength"
parser = do
string "Content-Length: "
len <- manyTill digit (string _TWO_CRLF)
return . read $ len
-- |
--
--
handleRequest :: DebugCommandData -> MVar DebugContext -> BSL.ByteString -> BSL.ByteString -> IO ()
handleRequest cmdData mvarCtx contLenStr jsonStr = do
case J.eitherDecode jsonStr :: Either String J.Request of
Left err -> do
-- 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"
putStrLnStderr mvarCtx msg
resSeq <- incResSeq mvarCtx
let terminatedEvt = J.defaultTerminatedEvent resSeq
terminatedEvtStr = J.encode terminatedEvt
sendEventL terminatedEvtStr
Right (J.Request cmd) -> handle contLenStr jsonStr cmd
wait cmdData mvarCtx
where
handle contLenStr jsonStr "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of
Right req -> initializeHandler mvarCtx 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 <- incResSeq mvarCtx
sendResponse $ J.encode $ J.parseErrorInitializeResponse resSeq msg
handle contLenStr jsonStr "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of
Right req -> launchHandler cmdData mvarCtx 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"
putStrLnStderr mvarCtx msg
resSeq <- incResSeq mvarCtx
let terminatedEvt = J.defaultTerminatedEvent resSeq
terminatedEvtStr = J.encode terminatedEvt
sendEventL terminatedEvtStr
handle contLenStr jsonStr "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of
Right req -> disconnectHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["disconnect request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of
Right req -> setBreakpointsHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["setBreakpoints request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of
Right req -> continueHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["continue request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of
Right req -> stepOverHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["next request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of
Right req -> stepInHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["stepIn request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of
Right req -> do
resSeq <- incResSeq mvarCtx
let res = J.defaultStepOutResponse resSeq req
resStr = J.encode $ res{J.successStepOutResponse = False, J.messageStepOutResponse = "unsupported command."}
sendResponse resStr
putStrLnStderr mvarCtx "stepOut command is not supported."
Left err -> do
let msg = L.intercalate " " ["stepOut request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of
Right req -> do
resSeq <- incResSeq mvarCtx
let res = J.defaultPauseResponse resSeq req
resStr = J.encode $ res{J.successPauseResponse = False, J.messagePauseResponse = "unsupported command."}
sendResponse resStr
putStrLnStderr mvarCtx "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"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of
Right req -> stackTraceHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["stackTrace request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of
Right req -> scopesHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["scopes request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of
Right req -> variablesHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["variables request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of
Right req -> do
resSeq <- incResSeq mvarCtx
let res = J.defaultSourceResponse resSeq req
resStr = J.encode $ res{J.successSourceResponse = False, J.messageSourceResponse = "unsupported command."}
sendResponse resStr
putStrLnStderr mvarCtx "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"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of
Right req -> threadsHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["threads request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of
Right req -> evaluateHandler cmdData mvarCtx req
Left err -> do
let msg = L.intercalate " " ["evaluate request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
putStrLnStderr mvarCtx msg
handle contLenStr jsonStr cmd = do
let msg = L.intercalate " " ["unknown request command.", cmd, lbs2str contLenStr, lbs2str jsonStr]
putStrLnStderr mvarCtx msg
-- |
--
sendEvent :: BSL.ByteString -> IO ()
sendEvent str = 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
-- |
--
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
-- |=====================================================================
--
-- Handlers
-- |
--
initializeHandler :: MVar DebugContext -> J.InitializeRequest -> IO ()
initializeHandler mvarCtx req@(J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do
resSeq <- incResSeq mvarCtx
let capa = J.InitializeResponseCapabilites False False True True []
res = J.InitializeResponse resSeq "response" seq True "initialize" "" capa
sendResponse $ 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 <- incResSeq mvarCtx
sendResponse $ J.encode $ J.errorInitializeResponse resSeq req msg
putStrLnStderr mvarCtx msg
-- |
--
launchHandler :: DebugCommandData -> MVar DebugContext -> J.LaunchRequest -> IO ()
launchHandler cmdData mvarCtx req@(J.LaunchRequest _ _ _ args) = flip E.catches handlers $ do
let ws = J.workspaceLaunchRequestArguments args
su = J.startupLaunchRequestArguments args
logFile = J.logFileLaunchRequestArguments args
logLevelStr = J.logLevelLaunchRequestArguments args
prmptStr = J.ghciPromptLaunchRequestArguments args
cmdStr = J.ghciCmdLaunchRequestArguments args
-- コンテキストデータの保持
ctx <- takeMVar mvarCtx
putMVar mvarCtx ctx {
workspaceDebugContext = ws
, startupDebugContext = su
}
envSetPromptDebugCommandData cmdData $ prmptStr
-- ロギング設定
logLevel <- case readMay logLevelStr of
Just lv -> return lv
Nothing -> do
putStrLnStderr mvarCtx $ "log priority is invalid. WARNING set. [" ++ logLevelStr ++ "]"
return WARNING
setupLogger logFile logLevel
logRequest $ show req
-- tasks.jsonファイルの準備
prepareTasksJsonFile mvarCtx ws
-- ghciのランチ
runGHCi cmdData mvarCtx cmdStr ws >>= ghciLaunched
where
handlers = [ E.Handler someExcept ]
someExcept (e :: E.SomeException) = do
let msg = L.intercalate " " ["launch request error.", show req, show e]
resSeq <- incResSeq mvarCtx
sendResponse $ J.encode $ J.errorLaunchResponse resSeq req msg
putStrLnStderr mvarCtx msg
-- |
--
prepareTasksJsonFile :: MVar DebugContext -> FilePath -> IO ()
prepareTasksJsonFile mvarCtx ws = do
let jsonFile = ws </> ".vscode" </> "tasks.json"
doesFileExist jsonFile >>= \case
True -> infoM _LOG_NAME $ "tasks.json file exists. " ++ jsonFile
False -> do
putStrLnConsole mvarCtx $ "create tasks.json file. " ++ jsonFile
saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS
-- |
--
ghciLaunched False = do
let msg = L.intercalate " " ["ghci launch error."]
resSeq <- incResSeq mvarCtx
sendResponse $ J.encode $ J.errorLaunchResponse resSeq req msg
putStrLnStderr mvarCtx msg
ghciLaunched True = do
startupRes <- loadHsFile cmdData mvarCtx (J.startupLaunchRequestArguments args)
when (False == startupRes) $ do
let msg = L.intercalate " " ["startup load error.", J.startupLaunchRequestArguments args]
putStrLnStderr mvarCtx msg
-- レスポンスとinitializedイベント送信
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.defaultLaunchResponse resSeq req
resSeq <- incResSeq mvarCtx
sendEventL $ J.encode $ J.defaultInitializedEvent resSeq
-- ファイル変更ウォッチの開始
watch cmdData mvarCtx
putStrLnConsole mvarCtx $ L.intercalate "\n" infoMsg
putStrStdout mvarCtx $ J.ghciPromptLaunchRequestArguments args
-- ランチ完了後のメッセージ出力
infoMsg = [
""
, " Now, ghci initialized."
, " Press F5 to start debugging."
, " Or modify source code. it will be loaded to ghci automatically."
, ""
]
-- |
--
disconnectHandler :: DebugCommandData -> MVar DebugContext -> J.DisconnectRequest -> IO ()
disconnectHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
let exitCmd = stopDebugCommandData cmdData
quitCmd = quitDebugCommandData cmdData
readWhile = readWhileDebugCommandData cmdData
cmdStr <- quitCmd
infoM _LOG_NAME cmdStr
putStrLnStdout mvarCtx cmdStr
str <- readWhile $ const True
infoM _LOG_NAME str
putStrLnStdout mvarCtx str
code <- exitCmd
infoM _LOG_NAME $ show code
putStrLnStdout mvarCtx $ show code
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.defaultDisconnectResponse resSeq req
where
handlers = [ E.Handler someExcept ]
someExcept (e :: E.SomeException) = do
let msg = L.intercalate " " ["disconnect request error.", show req, show e]
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorDisconnectResponse resSeq req msg
putStrLnStderr mvarCtx msg
-- |
--
setBreakpointsHandler :: DebugCommandData -> MVar DebugContext -> J.SetBreakpointsRequest -> IO ()
setBreakpointsHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
ctx <- readMVar mvarCtx
let cwd = workspaceDebugContext ctx
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 <- incResSeq mvarCtx
let res = J.defaultSetBreakpointsResponse resSeq req
resStr = J.encode res{J.bodySetBreakpointsResponse = J.SetBreakpointsResponseBody resBody}
sendResponseL resStr
resSeq <- incResSeq mvarCtx
let stopEvt = J.defaultStoppedEvent resSeq
stopEvtStr = J.encode stopEvt
sendEventL stopEvtStr
where
handlers = [ E.Handler someExcept ]
someExcept (e :: E.SomeException) = do
let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e]
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg
putStrLnStderr mvarCtx msg
convBp cwd path (J.SourceBreakpoint lineNo _ cond) =
BreakPointData {
moduleNameBreakPointData = src2mod cwd path
, filePathBreakPointData = path
, lineNoBreakPointData = lineNo
, breakNoBreakPointData = Nothing
, conditionBreakPointData = cond
}
delete path = do
ctx <- takeMVar mvarCtx
let bps = breakPointDatasDebugContext ctx
newBps = MAP.filterWithKey (\(p,_) _-> path /= p) bps
delBps = MAP.elems $ MAP.filterWithKey (\(p,_) _-> path == p) bps
putMVar mvarCtx ctx{breakPointDatasDebugContext = newBps}
debugM _LOG_NAME $ "del bps:" ++ show delBps
mapM_ (deleteBreakPointOnCUI cmdData 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 = breakPointDatasDebugContext ctx
newBps = foldr (\v@(BreakPointData _ p l _ _)->MAP.insert (p,l) v) bps $ map fst results
putMVar mvarCtx ctx{breakPointDatasDebugContext = newBps}
return resData
insertInternal reqBp@(BreakPointData modName filePath lineNo _ _) = do
let src = J.Source (Just modName) filePath Nothing Nothing
addBreakPointOnCUI cmdData 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)
-- |
--
--
threadsHandler :: DebugCommandData -> MVar DebugContext -> J.ThreadsRequest -> IO ()
threadsHandler _ mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
resSeq <- incResSeq mvarCtx
let resStr = J.encode $ J.defaultThreadsResponse resSeq req
sendResponseL resStr
where
handlers = [ E.Handler someExcept ]
someExcept (e :: E.SomeException) = do
let msg = L.intercalate " " ["threads request error.", show req, show e]
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorThreadsResponse resSeq req msg
putStrLnStderr mvarCtx msg
-- |
--
--
scopesHandler :: DebugCommandData -> MVar DebugContext -> J.ScopesRequest -> IO ()
scopesHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
let args = J.argumentsScopesRequest req
traceId = J.frameIdScopesArguments args
moveFrame cmdData mvarCtx traceId
resSeq <- incResSeq 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 <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorScopesResponse resSeq req msg
putStrLnStderr mvarCtx msg
-- |
--
--
variablesHandler :: DebugCommandData -> MVar DebugContext -> J.VariablesRequest -> IO ()
variablesHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
vals <- currentBindings
resSeq <- incResSeq mvarCtx
let res = J.defaultVariablesResponse resSeq req
resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals}
sendResponseL resStr
where
handlers = [ E.Handler someExcept ]
someExcept (e :: E.SomeException) = do
let msg = L.intercalate " " ["variables request error.", show req, show e]
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorVariablesResponse resSeq req msg
putStrLnStderr mvarCtx msg
currentBindings = do
let bindings = bindingsDebugCommandData cmdData
getResult = readDebugCommandData cmdData
prmpt <- envGetPromptDebugCommandData cmdData
cmdStr <- bindings
infoM _LOG_NAME cmdStr
bindStr <- getResult
infoM _LOG_NAME bindStr
case getBindingDataList prmpt bindStr of
Left err -> do
errorM _LOG_NAME $ show err
putStrLnStderr mvarCtx $ show err
return []
Right dats -> return $ map convBind2Vals dats
convBind2Vals (BindingData varName _ val) = J.Variable varName val 0
-- |
--
--
stackTraceHandler :: DebugCommandData -> MVar DebugContext -> J.StackTraceRequest -> IO ()
stackTraceHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
ctx <- readMVar mvarCtx
case debugStoppedPosDebugContext ctx of
Nothing -> do
resSeq <- incResSeq mvarCtx
let body = J.StackTraceBody [] 0
res = J.defaultStackTraceResponse resSeq req
resStr = J.encode $ res{J.bodyStackTraceResponse = body}
sendResponseL resStr
Just rangeData -> do
resSeq <- incResSeq mvarCtx
frames <- createStackFrames rangeData
debugM _LOG_NAME $ show frames
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 <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorStackTraceResponse resSeq req msg
putStrLnStderr mvarCtx msg
createStackFrames (HighlightTextRangeData file sl sc _ _) = do
ctx <- readMVar mvarCtx
let cwd = workspaceDebugContext ctx
csf = J.StackFrame 0 "[BP]" (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc
let getResult = readDebugCommandData cmdData
history = traceHistDebugCommandData cmdData
cmdStr <- history
infoM _LOG_NAME cmdStr
traceStr <- getResult
infoM _LOG_NAME traceStr
case getTraceDataList traceStr of
Left err -> do
errorM _LOG_NAME $ show err
putStrLnStderr mvarCtx $ show err
return [csf]
Right dats -> foldM (convTrace2Frame cwd) [csf] dats
convTrace2Frame cwd xs (TraceData traceId funcName filePath) = case parse parseHighlightTextRange "getActivatePosFromLine" filePath of
Left err -> do
errorM _LOG_NAME $ show err
putStrLnStderr mvarCtx $ show err
return xs
Right (HighlightTextRangeData file sl sc _ _) -> return $
J.StackFrame (read traceId) funcName (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc : xs
-- |
--
--
evaluateHandler :: DebugCommandData -> MVar DebugContext -> J.EvaluateRequest -> IO ()
evaluateHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
let (J.EvaluateArguments exp frameId ctx) = J.argumentsEvaluateRequest req
moveFrame cmdData mvarCtx $ if isJust frameId then fromJust frameId else 0
eval ctx exp
where
handlers = [ E.Handler someExcept ]
someExcept (e :: E.SomeException) = do
let msg = L.intercalate " " ["evaluate request error.", show req, show e]
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorEvaluateResponse resSeq req msg
putStrLnStderr mvarCtx msg
eval "watch" exp = do
let forceVar = forceDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- forceVar exp
infoM _LOG_NAME cmdStr
cmdStr <- getResult
infoM _LOG_NAME cmdStr
let result = normalizeResult cmdStr
resSeq <- incResSeq mvarCtx
let body = J.EvaluateBody result 0
res = J.defaultEvaluateResponse resSeq req
resStr = J.encode res{J.bodyEvaluateResponse = body}
sendResponseL resStr
eval "hover" exp = do
let info = infoDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- info exp
putStrLnStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
cmdStr <- getResult
putStrStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
let result = normalizeResult cmdStr
resSeq <- incResSeq mvarCtx
let body = J.EvaluateBody result 0
res = J.defaultEvaluateResponse resSeq req
resStr = J.encode res{J.bodyEvaluateResponse = body}
sendResponseL resStr
eval _ exp = do
let exec = execCommandData cmdData
getResult = readDebugCommandData cmdData
prmpt <- envGetPromptDebugCommandData cmdData
cmdStr <- exec exp
infoM _LOG_NAME cmdStr
cmdStr <- getResult
infoM _LOG_NAME cmdStr
-- promptを消す
let result = unlines . init . lines $ cmdStr
resSeq <- incResSeq mvarCtx
let body = J.EvaluateBody result 0
res = J.defaultEvaluateResponse resSeq req
resStr = J.encode res{J.bodyEvaluateResponse = body}
sendResponseL resStr
putStrStdout mvarCtx $ "\n" ++ prmpt
normalizeResult = L.intercalate " " . filter (not . startswith "***"). filter (not . null) . map (replace "\t" "") . map strip . init . lines
-- |
--
--
continueHandler :: DebugCommandData -> MVar DebugContext -> J.ContinueRequest -> IO ()
continueHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
resSeq <- incResSeq mvarCtx
let resStr = J.encode $ J.defaultContinueResponse resSeq req
sendResponseL resStr
startDebug cmdData mvarCtx
where
handlers = [ E.Handler someExcept ]
someExcept (e :: E.SomeException) = do
let msg = L.intercalate " " ["continue request error.", show req, show e]
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorContinueResponse resSeq req msg
putStrLnStderr mvarCtx msg
-- |
--
--
stepOverHandler :: DebugCommandData -> MVar DebugContext -> J.NextRequest -> IO ()
stepOverHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
ctx <- readMVar mvarCtx
case debugStoppedPosDebugContext ctx of
Nothing -> do
resSeq <- incResSeq mvarCtx
let res = J.defaultNextResponse resSeq req
resStr = J.encode res{J.successNextResponse = False, J.messageNextResponse = "debug is initialized but not started yet. press F5(continue)."}
sendResponseL resStr
Just _ -> stepOver
where
handlers = [ E.Handler someExcept ]
someExcept (e :: E.SomeException) = do
let msg = L.intercalate " " ["stepOver request error.", show req, show e]
resSeq <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorNextResponse resSeq req msg
putStrLnStderr mvarCtx msg
stepOver = do
let step = stepOverDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- step
infoM _LOG_NAME cmdStr
putStrLnStdout mvarCtx cmdStr
cmdStr <- getResult
infoM _LOG_NAME cmdStr
putStrStdout mvarCtx cmdStr
case getStoppedTextRangeData cmdStr of
Left err -> do
infoM _LOG_NAME $ show err
--putStrLnStdout mvarCtx $ show err
resSeq <- incResSeq mvarCtx
let terminatedEvt = J.defaultTerminatedEvent resSeq
terminatedEvtStr = J.encode terminatedEvt
sendEvent terminatedEvtStr
Right pos -> do
ctx <- takeMVar mvarCtx
putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos}
resSeq <- incResSeq mvarCtx
let res = J.defaultNextResponse resSeq req
resStr = J.encode res
sendResponseL resStr
resSeq <- incResSeq mvarCtx
let stopEvt = J.defaultStoppedEvent resSeq
stopEvtStr = J.encode stopEvt
sendEventL stopEvtStr
-- |
--
--
stepInHandler :: DebugCommandData -> MVar DebugContext -> J.StepInRequest -> IO ()
stepInHandler cmdData mvarCtx req = flip E.catches handlers $ do
logRequest $ show req
ctx <- readMVar mvarCtx
case debugStoppedPosDebugContext ctx of
Nothing -> do
resSeq <- incResSeq mvarCtx
let res = J.defaultStepInResponse resSeq req
resStr = J.encode res{J.successStepInResponse = False, J.messageStepInResponse = "debug is initialized but not started yet. press F5(continue)."}
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 <- incResSeq mvarCtx
sendResponseL $ J.encode $ J.errorStepInResponse resSeq req msg
putStrLnStderr mvarCtx msg
stepIn = do
let step = stepDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- step
infoM _LOG_NAME cmdStr
putStrLnStdout mvarCtx cmdStr
cmdStr <- getResult
infoM _LOG_NAME cmdStr
putStrStdout mvarCtx cmdStr
case getStoppedTextRangeData cmdStr of
Left err -> do
infoM _LOG_NAME $ show err
--putStrLnStdout mvarCtx $ show err
resSeq <- incResSeq mvarCtx
let terminatedEvt = J.defaultTerminatedEvent resSeq
terminatedEvtStr = J.encode terminatedEvt
sendEventL terminatedEvtStr
Right pos -> do
ctx <- takeMVar mvarCtx
putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos}
resSeq <- incResSeq mvarCtx
let res = J.defaultStepInResponse resSeq req
resStr = J.encode res
sendResponseL resStr
resSeq <- incResSeq mvarCtx
let stopEvt = J.defaultStoppedEvent resSeq
stopEvtStr = J.encode stopEvt
sendEventL stopEvtStr
-- |=====================================================================
--
-- utility
-- |
--
--
putStrLnConsole :: MVar DebugContext -> String -> IO ()
putStrLnConsole mvarCtx msg = putStrConsole mvarCtx (msg ++ "\n")
-- |
--
--
putStrConsole :: MVar DebugContext -> String -> IO ()
putStrConsole mvarCtx msg = do
resSeq <- incResSeq mvarCtx
let outEvt = J.defaultOutputEvent resSeq
outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "console" msg Nothing }
sendEvent outEvtStr
-- |
--
--
putStrLnStdout :: MVar DebugContext -> String -> IO ()
putStrLnStdout mvarCtx msg = putStrStdout mvarCtx (msg ++ "\n")
-- |
--
--
putStrStdout :: MVar DebugContext -> String -> IO ()
putStrStdout mvarCtx msg = do
resSeq <- incResSeq mvarCtx
let outEvt = J.defaultOutputEvent resSeq
outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "stdout" msg Nothing }
sendEvent outEvtStr
-- |
--
--
putStrLnStderr :: MVar DebugContext -> String -> IO ()
putStrLnStderr mvarCtx msg = putStrStderr mvarCtx (msg ++ "\n")
-- |
--
--
putStrStderr :: MVar DebugContext -> String -> IO ()
putStrStderr mvarCtx msg = do
resSeq <- incResSeq mvarCtx
let outEvt = J.defaultOutputEvent resSeq
outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "stderr" msg Nothing }
sendEvent outEvtStr
-- |
--
--
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
-- |
--
--
incResSeq :: MVar DebugContext -> IO Int
incResSeq mvarCtx = do
ctx <- takeMVar mvarCtx
let resSec = 1 + resSeqDebugContext ctx
putMVar mvarCtx ctx{resSeqDebugContext = resSec}
return resSec
-- |
--
--
runGHCi :: DebugCommandData -> MVar DebugContext -> String -> FilePath -> IO Bool
runGHCi cmdData mvarCtx cmdStr cwd = do
let startCmd = startDebugCommandData cmdData
readWhile = readWhileDebugCommandData cmdData
cmdList = filter (not.null) $ Data.String.Utils.split " " cmdStr
cmd = head cmdList
opts = tail cmdList
cmdLogStr = L.intercalate " " $ cmd : opts
infoM _LOG_NAME $ cmdLogStr ++ "\n"
putStrLnStdout mvarCtx $ cmdLogStr ++ "\n"
startCmd cmd opts cwd
str <- readWhile $ not . endswith _GHCI_PROMPT
infoM _LOG_NAME str
putStrStdout mvarCtx str
withStarted $ endswith _GHCI_PROMPT str
where
withStarted False = return False
withStarted True = do
readAndSetPrompt
return True
readAndSetPrompt = do
let setPrompt = promptDebugCommandData cmdData
getResult = readDebugCommandData cmdData
printEvld = printEvldDebugCommandData cmdData
promptStr <- setPrompt
putStrLnStdout mvarCtx promptStr
infoM _LOG_NAME promptStr
cmdStr <- getResult
putStrStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
cmdStr <- printEvld
putStrLnStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
cmdStr <- getResult
putStrStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
-- |
--
--
loadHsFile :: DebugCommandData -> MVar DebugContext -> FilePath -> IO Bool
loadHsFile cmdData mvarCtx path
| (False == endswith _HS_FILE_EXT path) = return False
| otherwise = do
let loadFile = loadFileDebugCommandData cmdData
readLines = readLinesDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- loadFile path
putStrLnStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
cont <- readLines debugStartResultHandler
if | null cont -> return False
| startswith "Ok," (last cont) -> do
cmdStr <- getResult
putStrStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
loadModule (last cont)
return True
| startswith "Failed," (last cont) -> do
cmdStr <- getResult
putStrStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
return False
| otherwise -> do
errorM _LOG_NAME $ "load file fail.["++ path ++"]"
putStrLnStderr mvarCtx $ "load file fail.["++ path ++"]"
return False
where
debugStartResultHandler :: [String] -> IO Bool
debugStartResultHandler acc = putStrLnStdout mvarCtx curStr >> infoM _LOG_NAME curStr >> if
| L.isPrefixOf "Ok," curStr -> return False
| L.isPrefixOf "Failed," curStr -> return False
| otherwise -> return True
where
curStr | null acc = ""
| otherwise = last acc
-- |
-- Ok, modules loaded: Lib, Main, LibSpec.
-- -> : module +Lib Main LibSpec
loadModule str = do
let loadModule = moduleDebugCommandData cmdData
getResult = readDebugCommandData cmdData
args = replace "," "" $ replace "Ok, modules loaded: " "+" $ init $ strip str
cmdStr <- loadModule args
putStrLnStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
cmdStr <- getResult
putStrStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
-- |
-- ブレークポイントをGHCi上でdeleteする
--
deleteBreakPointOnCUI :: DebugCommandData -> MVar DebugContext -> BreakPointData -> IO ()
deleteBreakPointOnCUI cmdData _ (BreakPointData _ _ _ (Just breakNo) _) = do
let deleteBreak = deleteBreakDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- deleteBreak breakNo
-- putStrLnStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
cmdStr <- getResult
-- putStrStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
deleteBreakPointOnCUI _ mvarCtx bp = do
let err = "invalid delete break point." ++ show bp
putStrLnStderr mvarCtx err
errorM _LOG_NAME err
-- |
-- GHCi上でブレークポイントを追加する
--
addBreakPointOnCUI :: DebugCommandData -> MVar DebugContext -> BreakPointData -> IO (Either String Int)
addBreakPointOnCUI cmdData _ (BreakPointData modName _ lineNo _ _) = do
let setBreak = breakDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- setBreak modName lineNo
-- putStrLnStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
cmdStr <- getResult
-- putStrStdout mvarCtx cmdStr
infoM _LOG_NAME cmdStr
case getBreakPointNo cmdStr of
Right no -> return $ Right no
Left err -> if L.isPrefixOf _NO_BREAK_POINT_LOCATION cmdStr
then return $ Left _NO_BREAK_POINT_LOCATION
else do
let msg = "unexpected break set result. " ++ show err ++ cmdStr
errorM _LOG_NAME msg
return $ Left msg
where
-- |
-- parser of
-- Breakpoint 0 activated at src\Main.hs:(21,3)-(23,35)
--
getBreakPointNo :: String -> Either ParseError Int
getBreakPointNo res = parse parser "getBreakPointNo" res
where
parser = do
_ <- manyTill anyChar (string "Breakpoint ")
no <- manyTill digit (string " activated at")
return $ read no
-- |
-- Loggerのセットアップ
--
setupLogger :: FilePath -> Priority -> IO ()
setupLogger logFile level = do
-- level <- case readMay logLevel of
-- Just a -> return a
-- Nothing -> E.throwIO . E.userError $ "invalid log level[" ++ logLevel ++ "]"
logStream <- openFile logFile AppendMode
hSetEncoding logStream utf8
logH <- LHS.streamHandler logStream level
let logHandle = logH {LHS.closeFunc = hClose}
logFormat = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT
logHandler = LH.setFormatter logHandle logFormat
L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle])
L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler]
L.updateGlobalLogger _LOG_NAME $ L.setLevel level
-- |
--
--
watch :: DebugCommandData -> MVar DebugContext -> IO ()
watch cmdData mvarCtx = do
_ <- forkIO $ watchFiles cmdData mvarCtx
return ()
watchFiles :: DebugCommandData -> MVar DebugContext -> IO ()
watchFiles cmdData mvarCtx = do
FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce = FSN.Debounce 1} $ \mgr -> do
ctx <- readMVar mvarCtx
let dir = workspaceDebugContext ctx
infoM _LOG_NAME $ "start watch files in [" ++ dir ++ "]"
_ <- FSN.watchTree mgr dir hsFilter action
forever $ threadDelay 1000000
return ()
where
hsFilter event = endswith _HS_FILE_EXT $ FSN.eventPath event
action event = do
ctx <- readMVar mvarCtx
withDebugStarted event $ debugStartedDebugContext ctx
withDebugStarted _ True = do
resSeq <- incResSeq mvarCtx
let terminatedEvt = J.defaultTerminatedEvent resSeq
terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True}
sendEvent terminatedEvtStr
withDebugStarted event False = do
ctx <- takeMVar mvarCtx
putMVar mvarCtx ctx{modifiedDebugContext = True}
loadHsFile cmdData mvarCtx (FSN.eventPath event) >> return ()
-- |
--
--
moveFrame :: DebugCommandData -> MVar DebugContext -> Int -> IO ()
moveFrame cmdData mvarCtx traceId = do
ctx <- readMVar mvarCtx
let curTraceId = currentFrameIdDebugContext ctx
moveCount = curTraceId - traceId
traceCmd = if 0 > moveCount then traceForwardDebugCommandData cmdData
else traceBackDebugCommandData cmdData
getResult = readDebugCommandData cmdData
_ <- foldM (go traceCmd getResult) (""::String) [1..(abs moveCount)]
ctx <- takeMVar mvarCtx
putMVar mvarCtx ctx{currentFrameIdDebugContext = traceId}
where
go traceCmd getResult _ _ = do
cmdStr <- traceCmd
infoM _LOG_NAME cmdStr
putStrLnStdout mvarCtx cmdStr
cmdStr <- getResult
infoM _LOG_NAME cmdStr
putStrStdout mvarCtx cmdStr
return cmdStr
-- |
--
--
startDebug :: DebugCommandData -> MVar DebugContext -> IO ()
startDebug cmdData mvarCtx = do
ctx <- readMVar mvarCtx
let started = debugStartedDebugContext ctx
startDebugInternal started
where
startDebugInternal True = do
let continue = continueDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- continue True
infoM _LOG_NAME cmdStr
putStrLnStdout mvarCtx cmdStr
cmdStr <- getResult
infoM _LOG_NAME cmdStr
putStrStdout mvarCtx cmdStr
sendEventByDebugStopStatus cmdData mvarCtx cmdStr
startDebugInternal False = do
ctx <- readMVar mvarCtx
withModified $ modifiedDebugContext ctx
withModified True = do
resSeq <- incResSeq mvarCtx
let terminatedEvt = J.defaultTerminatedEvent resSeq
terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True}
sendEvent terminatedEvtStr
withModified False = do
let getResult = readDebugCommandData cmdData
runDebug = runDebugCommandData cmdData
cmdStr <- runDebug True
infoM _LOG_NAME cmdStr
putStrLnStdout mvarCtx cmdStr
cmdStr <- getResult
infoM _LOG_NAME cmdStr
putStrStdout mvarCtx cmdStr
ctx <- takeMVar mvarCtx
putMVar mvarCtx ctx{currentFrameIdDebugContext = 0, debugStartedDebugContext = True}
sendEventByDebugStopStatus cmdData mvarCtx cmdStr
-- |
--
--
sendEventByDebugStopStatus :: DebugCommandData -> MVar DebugContext -> String -> IO ()
sendEventByDebugStopStatus cmdData mvarCtx cmdStr = case getStoppedTextRangeData cmdStr of
Left err -> do
infoM _LOG_NAME $ show err
--putStrLnStdout mvarCtx $ show err
resSeq <- incResSeq mvarCtx
let terminatedEvt = J.defaultTerminatedEvent resSeq
terminatedEvtStr = J.encode terminatedEvt
sendEvent terminatedEvtStr
Right pos -> continueWithHighlightTextRangeData cmdData mvarCtx pos
-- |
--
--
continueWithHighlightTextRangeData :: DebugCommandData -> MVar DebugContext -> HighlightTextRangeData -> IO ()
continueWithHighlightTextRangeData cmdData mvarCtx pos = do
ctx <- readMVar mvarCtx
let bpKey = getKeyOfHighlightTextRangeData pos
bpMap = breakPointDatasDebugContext ctx
case MAP.lookup bpKey bpMap of
Nothing -> do
errorM _LOG_NAME $ "breakpoint not found." ++ show bpKey
sendStopEvent
Just condCmd -> continueWithCondCmd $ conditionBreakPointData condCmd
where
-- |
--
continueWithCondCmd Nothing = do
infoM _LOG_NAME "no condition breakpoint"
sendStopEvent
continueWithCondCmd (Just condStr) = do
let condition = execCommandData cmdData
getResult = readDebugCommandData cmdData
_ <- condition condStr
infoM _LOG_NAME condStr
putStrLnStdout mvarCtx condStr
cmdStr <- getResult
infoM _LOG_NAME cmdStr
putStrStdout mvarCtx cmdStr
condRes <- getConditionResult cmdStr
continueWithCondResult condRes
-- |
--
continueWithCondResult False = startDebug cmdData mvarCtx
continueWithCondResult True = sendStopEvent
-- |
--
getConditionResult res
| L.isPrefixOf "True" res = return True
| L.isPrefixOf "False" res = return False
| otherwise = warningM _LOG_NAME ("invalid condition result. " ++ res) >> return True
-- |
--
sendStopEvent = do
infoM _LOG_NAME $ show pos
ctx <- takeMVar mvarCtx
putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos}
resSeq <- incResSeq mvarCtx
let stopEvt = J.defaultStoppedEvent resSeq
stopEvtStr = J.encode stopEvt
sendEvent stopEvtStr
-- |=====================================================================
--
-- パーサ
--
-- |
--
--
getStoppedTextRangeData :: String -> Either ParseError HighlightTextRangeData
getStoppedTextRangeData = parse parser "getStoppedTextRangeData"
where
parser = try parse7 <|> try parse8
parse7 = do
_ <- manyTill anyChar (try (string "Stopped at "))
parseHighlightTextRange
parse8 = do
_ <- manyTill anyChar (try (string "Stopped in "))
_ <- manyTill anyChar (try (string ", "))
parseHighlightTextRange
-- |
--
drive2lower :: FilePath -> FilePath
drive2lower (x : ':' : xs) = toLower x : ':' : xs
drive2lower xs = xs
-- |
-- parser of
-- A) src\Phoityne\IO\Main.hs:31:11-14
-- B) src\Main.hs:(17,3)-(19,35)
-- C) src\Phoityne\IO\Main.hs:31:11
-- src\Phoityne\IO\Main.hs:31:11:
--
parseHighlightTextRange :: forall u. ParsecT String u Identity HighlightTextRangeData
parseHighlightTextRange = do
path <- manyTill anyChar (string (_HS_FILE_EXT ++ ":"))
(sl, sn, el, en) <- try parseA <|> try parseB <|> try parseC
return $ HighlightTextRangeData (drive2lower path ++ _HS_FILE_EXT) sl sn el en
where
parseA = do
ln <- manyTill digit (char ':')
sn <- manyTill digit (char '-')
en <- try (manyTill digit endOfLine) <|> try (manyTill digit eof)
return ((read ln), (read sn), (read ln), (read en))
parseB = do
_ <- char '('
sl <- manyTill digit (char ',')
sn <- manyTill digit (char ')')
_ <- string "-("
el <- manyTill digit (char ',')
en <- manyTill digit (char ')')
return ((read sl), (read sn), (read el), (read en))
parseC = do
ln <- manyTill digit (char ':')
sn <- try (manyTill digit (char ':')) <|> try (manyTill digit endOfLine) <|> try (manyTill digit eof)
return ((read ln), (read sn), (read ln), (read sn))
-- |
-- トレース情報のパーサ
--
-- parser of
-- Phoityne>>= :history
-- -1 : config:confB (src\Project\Argument.hs:85:17-28)
-- -2 : config:confB (src\Project\Argument.hs:87:17-36)
-- src\Project\IO\Main.hs:(70,9)-(71,65)
--
-- -1 : main (D:\haskell\vsc-sample\app\Main.hs:6:8-15)
--
getTraceDataList :: String -> Either ParseError [TraceData]
getTraceDataList res = go [] $ reverse $ filter (L.isPrefixOf "-") $ lines res
where
go acc [] = Right acc
go acc (x:xs) = case parse parser "getTraceDataList" x of
Left err -> Left err
Right dat -> go (dat:acc) xs
parser = do
traceId <- manyTill anyChar (many1 space >> char ':' >> space)
funcName <- manyTill anyChar (space >> char '(')
filePath <- manyTill anyChar eof
return $ TraceData (strip traceId) (removeColorCode funcName) (init (strip filePath))
-- |
--
removeColorCode :: String -> String
removeColorCode str = case parse parser "removeColorCode" str of
Right res -> res
Left _ -> str
where
parser = do
let _esc_code = chr 27
char _esc_code >> char '[' >> anyChar >> char 'm'
funcName <- manyTill anyChar (char _esc_code)
return funcName
-- |
-- バインディング値のパーサ
--
-- parser of
-- args :: Project.Argument.ArgData = _
-- _result :: IO Data.ConfigFile.Types.ConfigParser = _
--
getBindingDataList :: String -> String -> Either ParseError [BindingData]
getBindingDataList prmpt res = parse parser "getBindingDataList" res
where
parser = manyTill parser1 (string prmpt)
parser1 = do
varName <- manyTill anyChar (string "::")
modName <- manyTill anyChar (try (string "="))
valStr <- manyTill anyChar lineSep <|> manyTill anyChar eof
return $ BindingData (strip varName) (strip modName) valStr
lineSep = try $ endOfLine >> notFollowedBy space