diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,4 +1,8 @@ +20160804 phoityne-vscode-0.0.8.0 + * [Modify] モジュール構成の変更。 + * [Modify] debugger adopter interface Capabilitiesの変更に対応した。 + 20160704 phoityne-vscode-0.0.7.0 * [Modify] debugger adopter interface Capabilitiesの変更に対応した。 * [Modify] debugger adopter interface StackFrameの変更に対応した。(endLin, endColumnの追加) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -55,6 +55,61 @@ 1. ctrlr + p on Visual Studio Code 2. ext install haskell ... 3. select "[Haskell GHCi debug viewer Phoityne](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode)" +## Capabilites +* supportsConfigurationDoneRequest : no +* supportsFunctionBreakpoints : no +* supportsConditionalBreakpoints : yes +* supportsEvaluateForHovers : yes +* exceptionBreakpointFilters : no +* supportsStepBack : no +* supportsSetVariable : no +* supportsRestartFrame : no + + +## Configuration + +### .vscode/launch.json + +* startup + * required + * default : ${workspaceRoot}/test/Spec.hs + * debug startup file, will be loaded automatically. +* ghciCmd + * required + * default: stack ghci --test --no-load --no-build + * launch ghci command, must be Prelude module loaded. + For example, "ghci -i${workspaceRoot}/src", "cabal exec -- ghci -i${workspaceRoot}/src" +* ghciPrompt + * required + * default: H>>= + * ghci command prompt string. +* logFile + * required + * default: ${workspaceRoot}/.vscode/phoityne.log + * internal log file. +* logLevel + * required + * default: WARNING + * internal log level. + +### .vscode/tasks.json + +* stack build + * required + * default: stack build + * task definition for F6 shortcut key. +* stack clean & build + * required + * default: stack clean && stack build + * task definition for F7 shortcut key. +* stack test + * required + * default: stack test + * task definition for F8 shortcut key. +* stack watch + * required + * default: stack build --test --no-run-tests --file-watch + * task definition for F6 shortcut key. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,7 @@ module Main where -- モジュール -import qualified Phoityne.IO.Main as M +import qualified Phoityne.VSCode.IO.Main as M -- システム import System.Exit diff --git a/app/Phoityne/Argument.hs b/app/Phoityne/Argument.hs deleted file mode 100644 --- a/app/Phoityne/Argument.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -fno-cse #-} - -module Phoityne.Argument ( - HelpExitException(..) -, ArgData(..) -, config -) where - --- システム -import System.Console.CmdArgs -import qualified Control.Exception as E - -import Paths_phoityne_vscode (version) -import Data.Version (showVersion) - --- | --- ヘルプ表示時の例外 --- -data HelpExitException = HelpExitException - deriving (Show, Typeable) - -instance E.Exception HelpExitException - --- | --- コマンドライン引数データ設定 --- モードを使用する場合のサンプル --- -data ArgData = ModeA deriving (Data, Typeable, Show, Read, Eq) - --- | --- アノテーション設定 --- -config :: ArgData -config = modes [confA] - &= summary sumMsg - &= program "phoityne-vscode" - - where - confA = ModeA { - - } &= name "ModeA" - &= details mdAMsg - &= auto - - sumMsg = unlines [ - "phoityne-vscode-" ++ showVersion version - ] - - mdAMsg = [ - "" - , "Phoityne is a ghci debug viewer for Visual Studio Code. " - , "" - ] - - --- | --- enum値引数 --- -data Method = Get | Post | Put | Delete - deriving (Data, Typeable, Show, Read, Eq) - - diff --git a/app/Phoityne/Constant.hs b/app/Phoityne/Constant.hs deleted file mode 100644 --- a/app/Phoityne/Constant.hs +++ /dev/null @@ -1,74 +0,0 @@ - -module Phoityne.Constant where - --- | --- --- -_INI_SEC_LOG :: String -_INI_SEC_LOG = "LOG" - -_INI_LOG_FILE :: String -_INI_LOG_FILE = "file" - -_INI_LOG_LEVEL :: String -_INI_LOG_LEVEL = "level" - -_INI_SEC_PHOITYNE :: String -_INI_SEC_PHOITYNE = "PHOITYNE" - - --- | --- --- -_LOG_NAME :: String -_LOG_NAME = "phoityne" - -_LOG_FORMAT :: String -_LOG_FORMAT = "$time [$tid] $prio $loggername - $msg" - -_LOG_FORMAT_DATE :: String -_LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S" - - --- | --- --- -type ModuleName = String - -_HS_FILE_EXT :: String -_HS_FILE_EXT = ".hs" - -_PHOITYNE_GHCI_PROMPT :: String -_PHOITYNE_GHCI_PROMPT = "Phoityne>>= " - -_GHCI_PROMPT :: String -_GHCI_PROMPT = "Prelude> " - -_GHCI_MAIN_PROMPT :: String -_GHCI_MAIN_PROMPT = "*Main> " - -_PROJECT_ROOT_MODULE_NAME :: String -_PROJECT_ROOT_MODULE_NAME = "Project Root" - -_INDENT_SPACE :: String -_INDENT_SPACE = " " - -_COMMENT_TAG :: String -_COMMENT_TAG = "-- " - -_UNDO_BUFFER_MAX_SIZE :: Int -_UNDO_BUFFER_MAX_SIZE = 100 - -_AVAILABLE_FILE_EXT :: [String] -_AVAILABLE_FILE_EXT = [ ".hs" - , ".ini" - , ".yaml" - , ".cabal" - ] - --- | --- --- -_NO_BREAK_POINT_LOCATION :: String -_NO_BREAK_POINT_LOCATION = "No breakpoints found at that location." - diff --git a/app/Phoityne/GHCi.hs b/app/Phoityne/GHCi.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/GHCi.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Phoityne.GHCi ( + module Phoityne.GHCi.IO.Process +, module Phoityne.GHCi.IO.Command +) where + +import Phoityne.GHCi.IO.Process +import Phoityne.GHCi.IO.Command + diff --git a/app/Phoityne/GHCi/IO/Command.hs b/app/Phoityne/GHCi/IO/Command.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/GHCi/IO/Command.hs @@ -0,0 +1,593 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Phoityne.GHCi.IO.Command ( + SourcePosition(..) + , StackFrame(..) + , BindingData(..) + , start + , quit + , set + , loadFile + , loadModule + , setBreak + , setFuncBreak + , delete + , traceMain + , trace + , step + , stepLocal + , history + , back + , forward + , bindings + , force + , info + , showType + , showKind + , execBool + , exec + ) where + +import Phoityne.GHCi.IO.Process +import Text.Parsec +import Data.Functor.Identity +import Data.Char +import qualified Data.List as L +import qualified System.Exit as S +import qualified Data.String.Utils as U + + +-- | +-- +_HS_FILE_EXT :: String +_HS_FILE_EXT = ".hs" + +-- | +-- +_GHCI_PROMPT :: String +_GHCI_PROMPT = "Prelude> " + + +-- | +-- +type OutputHandler = String -> IO () + +-- | +-- +type GHCiCommand = String + +-- | +-- +type GHCiOption = String + +-- | +-- +type ModuleName = String + +-- | +-- +type LineNo = Int + +-- | +-- +type BreakId = Int + +-- | +-- +data SourcePosition = SourcePosition { + filePathSourcePosition :: FilePath + , startLineNoSourcePosition :: Int + , startColNoSourcePosition :: Int + , endLineNoSourcePosition :: Int + , endColNoSourcePosition :: Int + } deriving (Show, Read, Eq, Ord) + +-- | +-- +data StackFrame = StackFrame { + idStackFrame :: Int + , functionStackFrame :: String + , positionStackFrame :: SourcePosition + } deriving (Show, Read, Eq, Ord) + + +-- | +-- +data BindingData = BindingData { + nameBindingData :: String + , typeBindingData :: String + , valueBindingData :: String + } deriving (Show, Read, Eq, Ord) + + +-- | +-- +start :: OutputHandler + -> GHCiCommand + -> [GHCiOption] + -> FilePath + -> String + -> IO (Either ErrorData GHCiProcess) +start outHdl cmd opts cwd pmt = do + outHdl $ L.intercalate " " $ (cmd : opts) ++ ["in " ++ cwd, "\n"] + runProcess cmd opts cwd pmt >>= withProcess + where + withProcess (Left err) = return $ Left err + withProcess (Right ghci) = readCharWhile ghci (not.endOfStartMsg) >>= setupGHCi ghci + + setupGHCi _ (Left err) = return $ Left err + setupGHCi ghci@(GHCiProcess _ _ _ _ pmt) (Right msg) = do + outHdl msg + set ghci outHdl ("prompt \"" ++ pmt ++ "\"") >>= \case + Left err -> return $ Left err + Right _ -> set ghci outHdl "-fprint-evld-with-show" >>= \case + Left err -> return $ Left err + Right _ -> return $ Right ghci + + endOfStartMsg msg + | U.endswith _GHCI_PROMPT msg = True + | endOfModLoadPrompt (last (lines msg)) = True + | otherwise = False + + endOfModLoadPrompt str = case parse endOfModLoadPromptParser "endOfModLoadPrompt" str of + Right _ -> True + Left _ -> False + + endOfModLoadPromptParser = do + char '*' >> manyTill anyChar (char '>') >> space >> eof + return True + +-- | +-- +quit :: GHCiProcess -> OutputHandler -> IO (Either ErrorData S.ExitCode) +quit ghci outHdl = do + let cmd = ":quit" + outHdl $ cmd ++ "\n" + + writeLine ghci cmd >>= \case + Left err -> return $ Left err + Right _ -> readTillEOF ghci >>= \case + Left err -> return $ Left err + Right msg -> do + outHdl msg + exitProcess ghci + + +-- | +-- +set :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData ()) +set ghci outHdl cmdArg = do + let cmd = ":set " ++ cmdArg + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right _ -> return $ Right () + +-- | +-- +loadFile :: GHCiProcess + -> OutputHandler + -> FilePath + -> IO (Either ErrorData [ModuleName]) +loadFile ghci outHdl cmdArg = do + let cmd = ":load " ++ cmdArg + outHdl $ cmd ++ "\n" + writeLine ghci cmd >>= \case + Left err -> return $ Left err + Right _ -> readLineWhileIO ghci endOfLoadFile >>= withLoadResult + + where + endOfLoadFile acc = do + let curStr = takeLastMsg acc + outHdl $ curStr ++ "\n" + if| U.startswith "Ok," curStr -> return False + | U.startswith "Failed," curStr -> return False + | otherwise -> return True + + takeLastMsg [] = "" + takeLastMsg xs = last xs + + withLoadResult (Left err ) = return $ Left err + withLoadResult (Right msges) = readTillPrompt ghci >>= \case + Left err -> return $ Left err + Right msg -> do + outHdl msg + withLoadResultMsg (takeLastMsg msges) + + -- | + -- Ok, modules loaded: Lib, Main, LibSpec. -> [Lib, Main, LibSpec] + -- Failed, modules loaded: none. + -- + withLoadResultMsg msg + | U.startswith "Ok," msg = + return $ Right + $ U.split ", " + $ U.replace "Ok, modules loaded: " "" + $ init + $ U.strip + $ msg + | otherwise = return $ Left $ "file load error. '" ++ cmdArg ++ "'" + + +-- | +-- +loadModule :: GHCiProcess -> OutputHandler -> [ModuleName] -> IO (Either ErrorData ()) +loadModule ghci outHdl mods = do + let cmd = ":module +" ++ U.join " " mods + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right _ -> return $ Right () + +-- | +-- +setBreak :: GHCiProcess + -> OutputHandler + -> ModuleName + -> LineNo + -> IO (Either ErrorData BreakId) +setBreak ghci outHdl modName lineNo = do + let cmd = ":break " ++ modName ++ " " ++ show lineNo + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> getBreakId msg + + where + getBreakId msg = case parse getBreakIdParser "getBreakId" msg of + Right no -> return $ Right no + Left err -> return $ Left $ "unexpected break set result. " ++ show err ++ msg + + getBreakIdParser = do + _ <- manyTill anyChar (string "Breakpoint ") + no <- manyTill digit (string " activated at") + return $ read no + +-- | +-- +setFuncBreak :: GHCiProcess + -> OutputHandler + -> String + -> IO (Either ErrorData (BreakId, SourcePosition)) +setFuncBreak ghci outHdl name = do + let cmd = ":break " ++ name + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> getBreakId msg + + where + getBreakId msg = case parse getBreakIdParser "getBreakId" msg of + Right no -> return $ Right no + Left err -> return $ Left $ "unexpected break set result. " ++ show err ++ msg + + getBreakIdParser = do + _ <- manyTill anyChar (string "Breakpoint ") + no <- manyTill digit (string " activated at ") + pos <- parsePosition + return (read no, pos) + +-- | +-- +delete :: GHCiProcess -> OutputHandler -> BreakId -> IO (Either ErrorData ()) +delete ghci outHdl bid = do + let cmd = ":delete " ++ show bid + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right _ -> return $ Right () + +-- | +-- +traceMain :: GHCiProcess -> OutputHandler -> IO (Either ErrorData SourcePosition) +traceMain ghci outHdl = do + let cmd = ":trace main" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractSourcePosition msg + +-- | +-- +trace :: GHCiProcess -> OutputHandler -> IO (Either ErrorData SourcePosition) +trace ghci outHdl = do + let cmd = ":trace" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractSourcePosition msg + +-- | +-- +step :: GHCiProcess -> OutputHandler -> IO (Either ErrorData SourcePosition) +step ghci outHdl = do + let cmd = ":step" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractSourcePosition msg + +-- | +-- +stepLocal :: GHCiProcess -> OutputHandler -> IO (Either ErrorData SourcePosition) +stepLocal ghci outHdl = do + let cmd = ":steplocal" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractSourcePosition msg + +-- | +-- +history :: GHCiProcess -> OutputHandler -> IO (Either ErrorData [StackFrame]) +history ghci outHdl = do + let cmd = ":history" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractStackFrame msg + +-- | +-- 引数の移動量はghc8から対応 +-- +back :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData SourcePosition) +back ghci outHdl _ = do + -- let cmd = ":back " ++ show val + exec ghci outHdl ":back" >>= \case + Left err -> return $ Left err + Right msg -> return $ extractTracePosition msg + +-- | +-- 引数の移動量はghc8から対応 +-- +forward :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData SourcePosition) +forward ghci outHdl _ = do + -- let cmd = ":forward " ++ show val + exec ghci outHdl ":forward" >>= \case + Left err -> return $ Left err + Right msg -> return $ extractTracePosition msg + +-- | +-- +bindings :: GHCiProcess -> OutputHandler -> IO (Either ErrorData [BindingData]) +bindings ghci outHdl = do + let cmd = ":show bindings" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractBindingBindingDatas msg + + +-- | +-- intaractve error is returned as Left Error +-- +force :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +force ghci outHdl target = do + let cmd = ":force " ++ target + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) + +-- | +-- intaractve error is returned as Left Error +-- +info :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +info ghci outHdl target = do + let cmd = ":info " ++ target + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) + +-- | +-- intaractve error is returned as Left Error +-- +showType :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +showType ghci outHdl target = do + let cmd = ":type " ++ target + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) + +-- | +-- intaractve error is returned as Left Error +-- +showKind :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +showKind ghci outHdl target = do + let cmd = ":kind " ++ target + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) + +-- | +-- +execBool :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData Bool) +execBool ghci outHdl cmd = exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ getConditionResult msg + + where + getConditionResult :: String -> Either ErrorData Bool + getConditionResult res + | U.startswith "True" res = Right True + | U.startswith "False" res = Right False + | otherwise = Left $ "invalid condition result. " ++ res + + +-- | +-- Private Utility +-- + +-- | +-- run command and return result string. +-- +exec :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +exec ghci outHdl cmd = do + outHdl $ cmd ++ "\n" + + writeLine ghci cmd >>= \case + Left err -> return $ Left err + Right _ -> readTillPrompt ghci >>= \case + Left err -> return $ Left err + Right msg -> do + outHdl msg + return $ Right msg + +-- | +-- +extractSourcePosition :: String -> (Either ErrorData SourcePosition) +extractSourcePosition src = case parse sourcePositionParser "extractSourcePosition" src of + Right pos -> Right pos + Left err -> Left $ show err ++ " [INPUT]" ++ src + + where + sourcePositionParser = try parse7 <|> try parse8 + + parse7 = do + _ <- manyTill anyChar (try (string "Stopped at ")) + parsePosition + + parse8 = do + _ <- manyTill anyChar (try (string "Stopped in ")) + _ <- manyTill anyChar (try (string ", ")) + parsePosition + +-- | +-- 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: +-- +parsePosition :: forall u. ParsecT String u Identity SourcePosition +parsePosition = do + path <- manyTill anyChar (string (_HS_FILE_EXT ++ ":")) + (sl, sn, el, en) <- try parseA <|> try parseB <|> try parseC + return $ SourcePosition (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)) + + -- | + -- to lowercase Windows drive letter + drive2lower :: FilePath -> FilePath + drive2lower (x : ':' : xs) = toLower x : ':' : xs + drive2lower xs = xs + +-- | +-- トレース情報のパーサ +-- +-- parser of +-- Phoityne>>= :history +-- -6 : spec (D:\haskell\unit-testing\test\LibSpec.hs:20:9-25) +-- -7 : spec (D:\haskell\unit-testing\test\LibSpec.hs:(34,7)-(35,26)) +-- +-- +extractStackFrame :: String -> (Either ErrorData [StackFrame]) +extractStackFrame src = go [] $ reverse $ filter (U.startswith "-") $ lines src + where + go acc [] = Right acc + go acc (x:xs) = case parse stackFrameParser "extractStackFrame" (init x) of + Left err -> Left $ show err ++ " " ++ x + Right dat -> go (dat:acc) xs + + stackFrameParser = do + char '-' + traceId <- manyTill digit (many1 space >> char ':' >> space) + funcName <- manyTill anyChar (space >> char '(') + pos <- parsePosition + + return $ StackFrame (read traceId) (removeColorCode funcName) pos + + removeColorCode str = case parse removeColorCodeParser "removeColorCode" str of + Right res -> res + Left _ -> str + + removeColorCodeParser = do + let _esc_code = chr 27 + char _esc_code >> char '[' >> anyChar >> char 'm' + funcName <- manyTill anyChar (char _esc_code) + return funcName + +-- | +-- トレース位置のパーサ +-- +-- parser of +-- Phoityne>>= :back 10 +-- Logged breakpoint at D:\haskell\unit-testing8\test\LibSpec.hs:(30,7)-(31,25) +-- Stopped at D:\haskell\unit-testing8\test\LibSpec.hs:31:9-25 +-- +extractTracePosition :: String -> (Either ErrorData SourcePosition) +extractTracePosition src = case parse extractTracePositionParser "extractTracePosition" src of + Right pos -> Right pos + Left err -> Left $ show err ++ " [INPUT]" ++ src + + where + extractTracePositionParser = try stopPos <|> try loggedPos + + stopPos = do + _ <- manyTill anyChar (try (string "Stopped at ")) + parsePosition + + loggedPos = do + _ <- manyTill anyChar (try (string "Logged breakpoint at ")) + parsePosition + +-- | +-- バインディング変数のパーサ +-- +-- parser of +-- Phoityne>>= :show bindings +-- _result :: +-- hspec-expectations-0.7.2:Test.Hspec.Expectations.Expectation = _ +-- it :: [String] = [] +-- Phoityne>>= +-- +extractBindingBindingDatas :: String -> (Either ErrorData [BindingData]) +extractBindingBindingDatas src = case parse bindingBindingDatasParser "extractBindingBindingDatas" (normalizeConsoleOut src) of + Right vals -> Right vals + Left err -> Left $ show err ++ " [INPUT]" ++ src + + where + bindingBindingDatasParser = manyTill bindingBindingDataParser eof + + bindingBindingDataParser = do + varName <- manyTill anyChar (string " :: ") + typeName <- manyTill anyChar (try (string " = ")) + valStr <- try (manyTill anyChar space) <|> try (manyTill anyChar eof) + return $ BindingData (U.strip varName) (U.strip typeName) (U.strip valStr) + + +-- | +-- +normalizeConsoleOut :: String -> String +normalizeConsoleOut = U.join " " . filter (not . U.startswith "***") . map U.strip . init . lines + + +-- | +-- interactive errorのパーサ +-- Phoityne>>= :info IO xx +-- +-- :1:1: error: Not in scope: ‘xx’ +-- Phoityne>>= +-- +extractErrorResult :: String -> (Either ErrorData String) +extractErrorResult str = case parse errorResultParser "extractErrorResult" str of + Right errMsg -> Left errMsg + Left _ -> Right $ str + where + errorResultParser = do + _ <- manyTill anyChar (string "") + _ <- manyTill anyChar (char ' ') + manyTill anyChar eof diff --git a/app/Phoityne/GHCi/IO/Process.hs b/app/Phoityne/GHCi/IO/Process.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/GHCi/IO/Process.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Phoityne.GHCi.IO.Process ( + ErrorData + , GHCiProcess (..) + , runProcess + , exitProcess + , writeLine + , readTillPrompt + , readTillEOF + , readCharWhile + , readCharWhileIO + , readLineWhile + , readLineWhileIO + ) where + +import GHC.IO.Encoding +import Distribution.System +import qualified System.Process as S +import qualified System.IO as S +import qualified System.Exit as S +import qualified Control.Exception as E +import qualified Data.String.Utils as U + +-- | +-- command error message. +-- +type ErrorData = String + +-- | +-- GHCi process data. +-- +data GHCiProcess = GHCiProcess + { + inGHCiProcess :: S.Handle + , outGHCiProcess :: S.Handle + , errGHCiProcess :: S.Handle + , procGHCiProcess :: S.ProcessHandle + , promptGHCiProcess :: String + } + +-- | +-- run ghci. +-- +runProcess :: String + -> [String] + -> FilePath + -> String + -> IO (Either ErrorData GHCiProcess) +runProcess cmd opts cwd pmt = flip E.catches handlers $ do + + (fromPhoityneHandle, toGHCiHandle) <- S.createPipe + (fromGHCiHandle, toPhoityneHandle) <- S.createPipe + + osEnc <- getReadHandleEncoding + + S.hSetBuffering toPhoityneHandle S.NoBuffering + S.hSetEncoding toPhoityneHandle osEnc + S.hSetNewlineMode toPhoityneHandle $ S.NewlineMode S.CRLF S.LF + + S.hSetBuffering fromPhoityneHandle S.NoBuffering + S.hSetEncoding fromPhoityneHandle S.utf8 + S.hSetNewlineMode fromPhoityneHandle $ S.NewlineMode S.LF S.LF + + S.hSetBuffering toGHCiHandle S.NoBuffering + S.hSetEncoding toGHCiHandle S.utf8 + S.hSetNewlineMode toGHCiHandle $ S.NewlineMode S.LF S.LF + + S.hSetBuffering fromGHCiHandle S.NoBuffering + S.hSetEncoding fromGHCiHandle osEnc + S.hSetNewlineMode fromGHCiHandle $ S.NewlineMode S.CRLF S.LF + + ghciProc <- S.runProcess cmd opts (Just cwd) Nothing (Just fromPhoityneHandle) (Just toPhoityneHandle) (Just toPhoityneHandle) + + return . Right $ GHCiProcess toGHCiHandle fromGHCiHandle fromGHCiHandle ghciProc pmt + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + + -- | + -- + -- + getReadHandleEncoding :: IO TextEncoding + getReadHandleEncoding = if + | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" + | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" + + +-- | +-- exit ghci. +-- +exitProcess :: GHCiProcess -> IO (Either ErrorData S.ExitCode) +exitProcess (GHCiProcess _ _ _ proc _) = flip E.catches handlers $ do + code <- S.waitForProcess proc + return . Right $ code + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + +-- | +-- write to ghci. +-- +writeLine :: GHCiProcess -> String -> IO (Either ErrorData ()) +writeLine (GHCiProcess ghciIn _ _ _ _) writeData = flip E.catches handlers $ S.hIsOpen ghciIn >>= \case + True -> do + S.hPutStrLn ghciIn writeData + return $ Right () + False -> return $ Left "handle not open." + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + +-- | +-- read char till prompt. +-- +readTillPrompt :: GHCiProcess -> IO (Either ErrorData String) +readTillPrompt proc@(GHCiProcess _ _ _ _ pmt) = readCharWhile proc (not . U.endswith pmt) + +-- | +-- read char till EOF. +-- +readTillEOF :: GHCiProcess -> IO (Either ErrorData String) +readTillEOF proc = readCharWhile proc (const True) + + +-- | +-- read char from ghci. +-- +readCharWhile :: GHCiProcess -> (String -> Bool) -> IO (Either ErrorData String) +readCharWhile (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case + True -> go [] + False -> return . Left $ "handle not open." + where + go acc = S.hIsEOF ghciOut >>= \case + True -> return . Right $ acc + False -> do + c <- S.hGetChar ghciOut + let acc' = acc ++ [c] + if condProc acc' then go acc' + else return . Right $ acc' + + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + +-- | +-- read char from ghci. +-- +readCharWhileIO :: GHCiProcess -> (String -> IO Bool) -> IO (Either ErrorData String) +readCharWhileIO (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case + True -> go [] + False -> return . Left $ "handle not open." + where + go acc = S.hIsEOF ghciOut >>= \case + True -> return . Right $ acc + False -> do + c <- S.hGetChar ghciOut + let acc' = acc ++ [c] + condProc acc' >>= \case + True -> go acc' + False -> return . Right $ acc' + + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + +-- | +-- read line from ghci. +-- +readLineWhile :: GHCiProcess -> ([String] -> Bool) -> IO (Either ErrorData [String]) +readLineWhile (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case + True -> go [] + False -> return . Left $ "handle not open." + where + go acc = S.hIsEOF ghciOut >>= \case + True -> return . Right $ acc + False -> do + l <- S.hGetLine ghciOut + let acc' = acc ++ [l] + if condProc acc' then go acc' + else return . Right $ acc' + + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + + +-- | +-- read line from ghci. +-- +readLineWhileIO :: GHCiProcess -> ([String] -> IO Bool) -> IO (Either ErrorData [String]) +readLineWhileIO (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case + True -> go [] + False -> return . Left $ "handle not open." + where + go acc = S.hIsEOF ghciOut >>= \case + True -> return . Right $ acc + False -> do + l <- S.hGetLine ghciOut + let acc' = acc ++ [l] + condProc acc' >>= \case + True -> go acc' + False -> return . Right $ acc' + + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e diff --git a/app/Phoityne/IO/CUI/GHCiControl.hs b/app/Phoityne/IO/CUI/GHCiControl.hs deleted file mode 100644 --- a/app/Phoityne/IO/CUI/GHCiControl.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Phoityne.IO.CUI.GHCiControl where - --- モジュール -import Phoityne.Constant -import Phoityne.IO.Utility - --- システム -import System.Process -import System.IO -import System.Exit -import System.Log.Logger -import qualified Control.Exception as E -import qualified Data.List as L - --- | --- --- -data ExternalCommandData = ExternalCommandData - { - inExternalCommandData :: Maybe Handle - , outExternalCommandData :: Maybe Handle - , errExternalCommandData :: Maybe Handle - , procExternalCommandData :: Maybe ProcessHandle - } - - --- | --- --- -defaultExternalCommandData :: ExternalCommandData -defaultExternalCommandData = ExternalCommandData Nothing Nothing Nothing Nothing - - --- | --- --- -run :: String -> [String] -> Maybe FilePath -> IO ExternalCommandData -run cmd opts curDir = flip E.catches handlers $ do - - debugM _LOG_NAME "run external command." - - (fromHaskellHandle, toExternalHandle) <- createPipe - (fromExternalHandle, toHaskellHandle) <- createPipe - - osEnc <- getReadHandleEncoding - - hSetBuffering toHaskellHandle NoBuffering - hSetEncoding toHaskellHandle osEnc - - hSetBuffering fromHaskellHandle NoBuffering - hSetEncoding fromHaskellHandle utf8 - - hSetBuffering toExternalHandle NoBuffering - hSetEncoding toExternalHandle utf8 - - hSetBuffering fromExternalHandle NoBuffering - hSetEncoding fromExternalHandle osEnc - - - debugM _LOG_NAME $ "external command : " ++ cmd ++ " " ++ (L.intercalate " " opts) - ghciProc <- runProcess cmd opts curDir Nothing (Just fromHaskellHandle) (Just toHaskellHandle) (Just toHaskellHandle) - - return $ ExternalCommandData (Just toExternalHandle) (Just fromExternalHandle) (Just fromExternalHandle) (Just ghciProc) - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - criticalM _LOG_NAME ("run:" ++ show e) - return $ ExternalCommandData Nothing Nothing Nothing Nothing - --- | --- --- -waitExit :: ExternalCommandData -> IO ExitCode -waitExit (ExternalCommandData _ _ _ (Just ghciProc)) = flip E.catches handlers $ do - waitForProcess ghciProc - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - criticalM _LOG_NAME ("waitExit:" ++ show e) - return $ ExitFailure 2 -waitExit _ = do - criticalM _LOG_NAME "waitExit" - return $ ExitFailure 2 - - --- | --- --- -writeLine :: ExternalCommandData -> String -> IO () -writeLine (ExternalCommandData (Just ghciIn) _ _ _) cmd = flip E.catches handlers $ hIsOpen ghciIn >>= \case - False -> criticalM _LOG_NAME "[writeLine] handle not open." - True -> debugM _LOG_NAME ("[writeLine]" ++ cmd) >> hPutStrLn ghciIn cmd - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("writeLine:" ++ show e) - -writeLine _ _ = criticalM _LOG_NAME "[writeLine] handle is nothing." - - --- | --- --- -readWhile :: ExternalCommandData -> (String -> Bool) -> IO String -readWhile (ExternalCommandData _ (Just ghciOut) _ _) proc = flip E.catches handlers $ go [] - where - go acc = hIsEOF ghciOut >>= \case - True -> return acc - False -> do - c <- hGetChar ghciOut - let acc' = acc ++ [c] - if proc acc' then go acc' - else return acc' - - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("readWhile:" ++ show e) >> return "" - -readWhile _ _ = criticalM _LOG_NAME "readWhile" >> return "" - - --- | --- --- -readLineWhileIO :: ExternalCommandData -> ([String] -> IO Bool) -> IO [String] -readLineWhileIO (ExternalCommandData _ (Just ghciOut) _ _) proc = flip E.catches handlers $ go [] - where - go acc = hIsEOF ghciOut >>= \case - True -> return acc - False -> do - l <- hGetLine ghciOut - let acc' = acc ++ [l] - proc acc' >>= \case - True -> go acc' - False -> return acc' - - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("readLineWhileIO:" ++ show e) >> return [] - -readLineWhileIO _ _ = criticalM _LOG_NAME "readLineWhileIO" >> return [] - diff --git a/app/Phoityne/IO/Control.hs b/app/Phoityne/IO/Control.hs deleted file mode 100644 --- a/app/Phoityne/IO/Control.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Phoityne.IO.Control where - --- モジュール -import Phoityne.Constant -import qualified Phoityne.Argument as A -import qualified Phoityne.IO.GUI.Control as GUI -import qualified Phoityne.IO.CUI.GHCiControl as GHCI - --- システム -import System.Exit -import Control.Concurrent -import Data.String.Utils -import qualified Data.ConfigFile as C - - --- | --- -data SysEnv = - SysEnv { - promptSysEnv :: String - } deriving (Show, Read, Eq, Ord) - - --- | --- ロジックメイン --- -run :: A.ArgData -- コマンドライン引数 - -> C.ConfigParser -- INI設定 - -> IO Int -- exit code -run _ _ = do - - - mvarENV <- newMVar $ SysEnv _PHOITYNE_GHCI_PROMPT - - mvarCUI <- newMVar GHCI.defaultExternalCommandData - - - let cmdData = createCmdData mvarENV mvarCUI - - GUI.run cmdData - - return 1 - - where - createCmdData mvarENV mvarCUI = - GUI.DebugCommandData { - GUI.startDebugCommandData = debugStart mvarCUI - , GUI.stopDebugCommandData = stopDebug mvarCUI - , GUI.readDebugCommandData = readResult mvarENV mvarCUI - , GUI.readLinesDebugCommandData = readLines mvarCUI - , GUI.promptDebugCommandData = setPrompt mvarENV mvarCUI - , GUI.breakDebugCommandData = setBreak mvarCUI - , GUI.bindingsDebugCommandData = execCmd mvarCUI ":show bindings" - , GUI.runDebugCommandData = runDebug mvarCUI - , GUI.continueDebugCommandData = continueCmd mvarCUI - , GUI.stepDebugCommandData = execCmd mvarCUI ":step" - , GUI.stepOverDebugCommandData = execCmd mvarCUI ":steplocal" - , GUI.printEvldDebugCommandData = execCmd mvarCUI ":set -fprint-evld-with-show" - , GUI.deleteBreakDebugCommandData = \n -> execCmd mvarCUI $ ":delete " ++ show n - , GUI.traceHistDebugCommandData = execCmd mvarCUI ":history" - , GUI.traceBackDebugCommandData = execCmd mvarCUI ":back" - , GUI.traceForwardDebugCommandData = execCmd mvarCUI ":forward" - , GUI.forceDebugCommandData = \arg -> execCmd mvarCUI $ ":force " ++ arg - , GUI.execCommandData = execCmd mvarCUI - , GUI.quitDebugCommandData = execCmd mvarCUI ":quit" - , GUI.buildStartDebugCommandData = buildStart mvarCUI - , GUI.cleanStartDebugCommandData = cleanStart mvarCUI - , GUI.loadFileDebugCommandData = \f-> execCmd mvarCUI $ ":l " ++ f - , GUI.readWhileDebugCommandData = readWhile mvarCUI - , GUI.infoDebugCommandData = \arg -> execCmd mvarCUI $ ":info " ++ arg - , GUI.typeDebugCommandData = \arg -> execCmd mvarCUI $ ":type " ++ arg - , GUI.moduleDebugCommandData = \arg -> execCmd mvarCUI $ ":module " ++ arg - , GUI.envSetPromptDebugCommandData = envSetPrompt mvarENV - , GUI.envGetPromptDebugCommandData = envGetPrompt mvarENV - } - --- | --- --- -envSetPrompt :: MVar SysEnv -> String -> IO () -envSetPrompt mvarENV prmt = do - sysEnv <- takeMVar mvarENV - putMVar mvarENV sysEnv{promptSysEnv = prmt} - --- | --- --- -envGetPrompt :: MVar SysEnv -> IO String -envGetPrompt mvarENV = readMVar mvarENV >>= return . promptSysEnv - - --- | --- --- -setPrompt :: MVar SysEnv -> MVar GHCI.ExternalCommandData -> IO String -setPrompt mvarENV mvarCUI = do - prmpt <- envGetPrompt mvarENV - execCmd mvarCUI $ ":set prompt \"" ++ prmpt ++ "\"" - - --- | --- --- -cleanStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () -cleanStart mvarCUI cwd = do - exeData <- GHCI.run "stack" ["clean"] $ Just cwd - takeMVar mvarCUI >> putMVar mvarCUI exeData - --- | --- --- -debugStart :: MVar GHCI.ExternalCommandData -> String -> [String] -> FilePath -> IO () -debugStart mvarCUI cmd opts cwd = do - exeData <- GHCI.run cmd opts $ Just cwd - takeMVar mvarCUI >> putMVar mvarCUI exeData - - --- | --- --- -buildStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () -buildStart mvarCUI cwd = do - exeData <- GHCI.run "stack" ["build", "--test", "--no-run-tests"] $ Just cwd - takeMVar mvarCUI >> putMVar mvarCUI exeData - - --- | --- --- -setBreak :: MVar GHCI.ExternalCommandData - -> String -- module name - -> Int -- linen no - -> IO String -setBreak mvarCUI modName lineNo = do - let cmd = ":break " ++ modName ++ " " ++ show lineNo - execCmd mvarCUI cmd - - --- | --- --- -runDebug :: MVar GHCI.ExternalCommandData -> Bool -> IO String -runDebug mvarCUI isTrace = do - let cmd = if isTrace then ":trace main" else "main" - execCmd mvarCUI cmd - - --- | --- --- -readResult :: MVar SysEnv -> MVar GHCI.ExternalCommandData -> IO String -readResult mvarENV mvarCUI = do - prmpt <- envGetPrompt mvarENV - readWhile mvarCUI $ not . endswith prmpt - - --- | --- --- -readWhile :: MVar GHCI.ExternalCommandData -> (String -> Bool) -> IO String -readWhile mvarCUI proc = do - exeData <- readMVar mvarCUI - GHCI.readWhile exeData proc - - --- | --- --- -readLines :: MVar GHCI.ExternalCommandData -> ([String] -> IO Bool) -> IO [String] -readLines mvarCUI proc = do - exeData <- readMVar mvarCUI - GHCI.readLineWhileIO exeData proc - - --- | --- --- -stopDebug :: MVar GHCI.ExternalCommandData -> IO ExitCode -stopDebug mvarCUI = do - exeData <- readMVar mvarCUI - GHCI.waitExit exeData - - --- | --- --- -continueCmd :: MVar GHCI.ExternalCommandData -> Bool -> IO String -continueCmd mvarCUI isTrace = do - let cmd = if isTrace then ":trace" else ":continue" - execCmd mvarCUI cmd - - --- | --- --- -execCmd :: MVar GHCI.ExternalCommandData -> String -> IO String -execCmd mvarCUI cmd = do - exeData <- readMVar mvarCUI - GHCI.writeLine exeData cmd - return cmd diff --git a/app/Phoityne/IO/GUI/Control.hs b/app/Phoityne/IO/GUI/Control.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/Control.hs +++ /dev/null @@ -1,1839 +0,0 @@ -{-# 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 --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" - ] - - - --- | --- --- -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 [] False False - 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 modName val) = J.Variable varName modName 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 el ec) = do - ctx <- readMVar mvarCtx - let cwd = workspaceDebugContext ctx - csf = J.StackFrame 0 "[BP]" (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec - - 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 el ec) -> return $ - J.StackFrame (read traceId) funcName (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec : 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 . endsWithPrompt - - infoM _LOG_NAME str - putStrStdout mvarCtx str - - withStarted $ endsWithPrompt 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 - - endsWithPrompt str = - if endswith _GHCI_PROMPT str then True - else isEndsWithPrompt $ last $ lines str - - - - --- | --- --- -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 - - --- | --- -isEndsWithPrompt :: String -> Bool -isEndsWithPrompt str = case parse parser "isEndsWithPrompt" str of - Right res -> res - Left _ -> False - where - parser = do - char '*' - manyTill anyChar $ char '>' - space - eof - return True - - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/BreakpointJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/BreakpointJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/BreakpointJSON.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Phoityne.IO.GUI.VSCode.TH.BreakpointJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.SourceJSON - --- | --- Information about a Breakpoint created in setBreakpoints or setFunctionBreakpoints. --- -data Breakpoint = - Breakpoint { - idBreakpoint :: Maybe Int -- An optional unique identifier for the breakpoint. - , verifiedBreakpoint :: Bool -- If true breakpoint could be set (but not necessarily at the desired location). - , messageBreakpoint :: String -- An optional message about the state of the breakpoint. This is shown to the user and can be used to explain why a breakpoint could not be verified. - , sourceBreakpoint :: Source -- The source where the breakpoint is located. - , lineBreakpoint :: Int -- The actual line of the breakpoint. - , columnBreakpoint :: Int -- The actual column of the breakpoint. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Breakpoint") } ''Breakpoint) - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ContinueArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ContinueArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ContinueArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ContinueArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "disconnect" request. --- -data ContinueArguments = - ContinueArguments { - threadIdContinueArguments :: Int -- continue execution for this thread. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ContinueArguments") } ''ContinueArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ContinueRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ContinueRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ContinueRequestJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ContinueRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ContinueArgumentsJSON - --- | --- Continue request; value of command field is "continue". --- The request starts the debuggee to run again. --- -data ContinueRequest = - ContinueRequest { - seqContinueRequest :: Int -- Sequence number - , typeContinueRequest :: String -- One of "request", "response", or "event" - , commandContinueRequest :: String -- The command to execute - , argumentsContinueRequest :: ContinueArguments -- Arguments for "continue" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ContinueRequest") } ''ContinueRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ContinueResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ContinueRequestJSON - --- | --- Response to "continue" request. This is just an acknowledgement, so no body field is required. --- -data ContinueResponse = - ContinueResponse { - seqContinueResponse :: Int -- Sequence number - , typeContinueResponse :: String -- One of "request", "response", or "event" - , request_seqContinueResponse :: Int -- Sequence number of the corresponding request - , successContinueResponse :: Bool -- Outcome of the request - , commandContinueResponse :: String -- The command requested - , messageContinueResponse :: String -- Contains error message if success == false. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ContinueResponse") } ''ContinueResponse) - --- | --- -defaultContinueResponse :: Int -> ContinueRequest -> ContinueResponse -defaultContinueResponse seq (ContinueRequest reqSeq _ _ _) = - ContinueResponse seq "response" reqSeq True "continue" "" - - --- | --- -parceErrorContinueResponse :: Int -> String -> ContinueResponse -parceErrorContinueResponse seq msg = - ContinueResponse seq "response" (-1) False "continue" msg - --- | --- -errorContinueResponse :: Int -> ContinueRequest -> String -> ContinueResponse -errorContinueResponse seq (ContinueRequest reqSeq _ _ _) msg = - ContinueResponse seq "response" reqSeq False "continue" msg diff --git a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.DisconnectArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "disconnect" request. --- -data DisconnectArguments = - DisconnectArguments { - restartDisconnectArguments :: Maybe Bool - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "DisconnectArguments") } ''DisconnectArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectRequestJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.DisconnectRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.DisconnectArgumentsJSON - --- | --- Disconnect request; value of command field is "disconnect". --- -data DisconnectRequest = - DisconnectRequest { - seqDisconnectRequest :: Int -- Sequence number - , typeDisconnectRequest :: String -- One of "request", "response", or "event" - , commandDisconnectRequest :: String -- The command to execute - , argumentsDisconnectRequest :: Maybe DisconnectArguments -- Arguments for "disconnect" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "DisconnectRequest") } ''DisconnectRequest) - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.DisconnectResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.DisconnectRequestJSON - --- | --- Response to "disconnect" request. This is just an acknowledgement, so no body field is required. --- -data DisconnectResponse = - DisconnectResponse { - seqDisconnectResponse :: Int -- Sequence number - , typeDisconnectResponse :: String -- One of "request", "response", or "event" - , request_seqDisconnectResponse :: Int -- Sequence number of the corresponding request - , successDisconnectResponse :: Bool -- Outcome of the request - , commandDisconnectResponse :: String -- The command requested - , messageDisconnectResponse :: String -- Contains error message if success == false. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "DisconnectResponse") } ''DisconnectResponse) - --- | --- -defaultDisconnectResponse :: Int -> DisconnectRequest -> DisconnectResponse -defaultDisconnectResponse seq (DisconnectRequest reqSeq _ _ _) = - DisconnectResponse seq "response" reqSeq True "disconnect" "" - --- | --- -parceErrorDisconnectResponse :: Int -> String -> DisconnectResponse -parceErrorDisconnectResponse seq msg = - DisconnectResponse seq "response" (-1) False "disconnect" msg - --- | --- -errorDisconnectResponse :: Int -> DisconnectRequest -> String -> DisconnectResponse -errorDisconnectResponse seq (DisconnectRequest reqSeq _ _ _) msg = - DisconnectResponse seq "response" reqSeq False "disconnect" msg diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseBodyJSON.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ErrorResponseBodyJSON where - -import Data.Aeson -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.MessageJSON - --- | --- On error that is whenever 'success' is false, the body can provide more details. --- -data ErrorResponseBody = - ErrorResponseBody { - errorErrorResponseBody :: Message -- An optional, structured error message. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ErrorResponseBody") } ''ErrorResponseBody) - --- | --- -defaultErrorResponseBody :: ErrorResponseBody -defaultErrorResponseBody = ErrorResponseBody defaultMessage - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseJSON.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Phoityne.IO.GUI.VSCode.TH.ErrorResponseJSON where - -import Data.Aeson -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ErrorResponseBodyJSON - --- | --- On error that is whenever 'success' is false, the body can provide more details. --- -data ErrorResponse = - ErrorResponse { - seqErrorResponse :: Int -- Sequence number - , typeErrorResponse :: String -- One of "request", "response", or "event" - , request_seqErrorResponse :: Int -- Sequence number of the corresponding request - , successErrorResponse :: Bool -- Outcome of the request - , commandErrorResponse :: String -- The command requested - , messageErrorResponse :: String -- Contains error message if success == false. - , bodyErrorResponse :: ErrorResponseBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ErrorResponse") } ''ErrorResponse) - --- | --- -defaultErrorResponse :: Int -> Int -> String -> ErrorResponse -defaultErrorResponse seq reqSeq cmd = - ErrorResponse seq "response" reqSeq False cmd "" defaultErrorResponseBody diff --git a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateArgumentsJSON.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.EvaluateArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "evaluate" request. --- -data EvaluateArguments = - EvaluateArguments { - expressionEvaluateArguments :: String -- The expression to evaluate. - , frameIdEvaluateArguments :: Maybe Int -- Evaluate the expression in the scope of this stack frame. If not specified, the expression is evaluated in the global scope. - , contextEvaluateArguments :: String -- The context in which the evaluate request is run. Possible values are 'watch' if evaluate is run in a watch, 'repl' if run from the REPL console, or 'hover' if run from a data hover. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "EvaluateArguments") } ''EvaluateArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateBodyJSON.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.EvaluateBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Response to "evaluate" request. --- -data EvaluateBody = - EvaluateBody { - resultEvaluateBody :: String -- The result of the evaluate. - , variablesReferenceEvaluateBody :: Int -- If variablesReference is > 0, the evaluate result is structured and its children can be retrieved by passing variablesReference to the VariablesRequest - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "EvaluateBody") } ''EvaluateBody) - --- | --- -defaultEvaluateBody :: EvaluateBody -defaultEvaluateBody = EvaluateBody "" 0 - - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateRequestJSON.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.EvaluateRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.EvaluateArgumentsJSON - --- | --- Evaluate request; value of command field is "evaluate". --- Evaluates the given expression in the context of the top most stack frame. --- The expression has access to any variables and arguments that are in scope. --- -data EvaluateRequest = - EvaluateRequest { - seqEvaluateRequest :: Int -- Sequence number - , typeEvaluateRequest :: String -- One of "request", "response", or "event" - , commandEvaluateRequest :: String -- The command to execute - , argumentsEvaluateRequest :: EvaluateArguments -- Arguments for "evaluate" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "EvaluateRequest") } ''EvaluateRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.EvaluateResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.EvaluateBodyJSON -import Phoityne.IO.GUI.VSCode.TH.EvaluateRequestJSON - --- | --- Response to "evaluate" request. --- -data EvaluateResponse = - EvaluateResponse { - seqEvaluateResponse :: Int -- Sequence number - , typeEvaluateResponse :: String -- One of "request", "response", or "event" - , request_seqEvaluateResponse :: Int -- Sequence number of the corresponding request - , successEvaluateResponse :: Bool -- Outcome of the request - , commandEvaluateResponse :: String -- The command requested - , messageEvaluateResponse :: String -- Contains error message if success == false. - , bodyEvaluateResponse :: EvaluateBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "EvaluateResponse") } ''EvaluateResponse) - - --- | --- -defaultEvaluateResponse :: Int -> EvaluateRequest -> EvaluateResponse -defaultEvaluateResponse seq (EvaluateRequest reqSeq _ _ _) = - EvaluateResponse seq "response" reqSeq True "evaluate" "" defaultEvaluateBody - --- | --- -errorEvaluateResponse :: Int -> EvaluateRequest -> String -> EvaluateResponse -errorEvaluateResponse seq (EvaluateRequest reqSeq _ _ _) msg = - EvaluateResponse seq "response" reqSeq False "evaluate" msg defaultEvaluateBody - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ExceptionBreakpointsFilterJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ExceptionBreakpointsFilterJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ExceptionBreakpointsFilterJSON.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ExceptionBreakpointsFilterJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- An ExceptionBreakpointsFilter is shown in the UI as an option for configuring how exceptions are dealt with. --- -data ExceptionBreakpointsFilter = - ExceptionBreakpointsFilter { - filterExceptionBreakpointsFilter :: String -- The internal ID of the filter. This value is passed to the setExceptionBreakpoints request. - , labelExceptionBreakpointsFilter :: String -- The name of the filter. This will be shown in the UI. - , defaultExceptionBreakpointsFilter :: Bool -- Initial value of the filter. If not specified a value 'false' is assumed. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ExceptionBreakpointsFilter") } ''ExceptionBreakpointsFilter) - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ExitedEventBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ExitedEventBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ExitedEventBodyJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ExitedEventBodyJSON where - -import Data.Aeson -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Event message for "exited" event type. --- The event indicates that the debuggee has exited. --- -data ExitedEventBody = - ExitedEventBody { - exitCodeExitedEventBody :: Int -- The exit code returned from the debuggee. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ExitedEventBody") } ''ExitedEventBody) - -defaultExitedEventBody code = ExitedEventBody code - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ExitedEventJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ExitedEventJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ExitedEventJSON.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ExitedEventJSON where - -import Data.Aeson -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ExitedEventBodyJSON - --- | --- Event message for "exited" event type. --- The event indicates that the debuggee has exited. --- -data ExitedEvent = - ExitedEvent { - seqExitedEvent :: Int -- Sequence number - , typeExitedEvent :: String -- One of "request", "response", or "event" - , eventExitedEvent :: String -- Type of event - , bodyExitedEvent :: ExitedEventBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ExitedEvent") } ''ExitedEvent) - -defaultExitedEvent seq code = ExitedEvent seq "event" "exited" $ defaultExitedEventBody code - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializeRequestArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializeRequestArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/InitializeRequestArgumentsJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.InitializeRequestArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Initialize request; value of command field is "initialize". --- -data InitializeRequestArguments = - InitializeRequestArguments { - adapterIDInitializeRequestArguments :: String -- The ID of the debugger adapter. Used to select or verify debugger adapter. - , linesStartAt1InitializeRequestArguments :: Bool -- If true all line numbers are 1-based (default). - , columnsStartAt1InitializeRequestArguments :: Bool -- If true all column numbers are 1-based (default). - , pathFormatInitializeRequestArguments :: String -- Determines in what format paths are specified. Possible values are 'path' or 'uri'. The default is 'path', which is the native format. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeRequestArguments") } ''InitializeRequestArguments) - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializeRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializeRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/InitializeRequestJSON.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Phoityne.IO.GUI.VSCode.TH.InitializeRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.InitializeRequestArgumentsJSON - --- | --- Client-initiated request --- -data InitializeRequest = - InitializeRequest { - seqInitializeRequest :: Int -- Sequence number - , typeInitializeRequest :: String -- One of "request", "response", or "event" - , commandInitializeRequest :: String -- The command to execute - , argumentsInitializeRequest :: InitializeRequestArguments -- Object containing arguments for the command - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeRequest") } ''InitializeRequest) - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.InitializeResponseCapabilitesJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ExceptionBreakpointsFilterJSON - --- | --- Information about the capabilities of a debug adapter. --- -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. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilites") } ''InitializeResponseCapabilites) - --- | --- -defaultInitializeResponseCapabilites :: InitializeResponseCapabilites -defaultInitializeResponseCapabilites = InitializeResponseCapabilites False False False False [] False False - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.InitializeResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.InitializeResponseCapabilitesJSON -import Phoityne.IO.GUI.VSCode.TH.InitializeRequestJSON - --- | --- Server-initiated response to client request --- -data InitializeResponse = - InitializeResponse { - seqInitializeResponse :: Int -- Sequence number - , typeInitializeResponse :: String -- One of "request", "response", or "event" - , request_seqInitializeResponse :: Int -- Sequence number of the corresponding request - , successInitializeResponse :: Bool -- Outcome of the request - , commandInitializeResponse :: String -- The command requested - , messageInitializeResponse :: String -- Contains error message if success == false. - , bodyInitializeResponse :: InitializeResponseCapabilites -- The capabilities of this debug adapter - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponse") } ''InitializeResponse) - - --- | --- -parseErrorInitializeResponse :: Int -> String -> InitializeResponse -parseErrorInitializeResponse seq msg = - InitializeResponse seq "response" seq False "initialize" msg defaultInitializeResponseCapabilites - --- | --- -errorInitializeResponse :: Int -> InitializeRequest -> String -> InitializeResponse -errorInitializeResponse seq (InitializeRequest reqSeq _ _ _) msg = - InitializeResponse seq "response" reqSeq False "initialize" msg defaultInitializeResponseCapabilites - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializedEventJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializedEventJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/InitializedEventJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.InitializedEventJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Server-initiated response to client request --- -data InitializedEvent = - InitializedEvent { - seqInitializedEvent :: Int -- Sequence number - , typeInitializedEvent :: String -- One of "request", "response", or "event" - , eventInitializedEvent :: String -- Type of event - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializedEvent") } ''InitializedEvent) - -defaultInitializedEvent :: Int -> InitializedEvent -defaultInitializedEvent resSeq = InitializedEvent resSeq "event" "initialized" diff --git a/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.LaunchRequestArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "launch" request. --- -data LaunchRequestArguments = - LaunchRequestArguments { - noDebugLaunchRequestArguments :: Maybe Bool -- If noDebug is true the launch request should launch the program without enabling debugging. - , nameLaunchRequestArguments :: String -- Phoityne specific argument. required. - , typeLaunchRequestArguments :: String -- Phoityne specific argument. required. - , requestLaunchRequestArguments :: String -- Phoityne specific argument. required. must be "request" - , startupLaunchRequestArguments :: String -- Phoityne specific argument. required. - , workspaceLaunchRequestArguments :: String -- Phoityne specific argument. required. - , logFileLaunchRequestArguments :: String -- Phoityne specific argument. required. - , logLevelLaunchRequestArguments :: String -- Phoityne specific argument. required. - , ghciPromptLaunchRequestArguments :: String -- Phoityne specific argument. required. - , ghciCmdLaunchRequestArguments :: String -- Phoityne specific argument. required. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "LaunchRequestArguments") } ''LaunchRequestArguments) - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.LaunchRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.LaunchRequestArgumentsJSON - --- | --- Launch request; value of command field is "launch". --- -data LaunchRequest = - LaunchRequest { - seqLaunchRequest :: Int -- Sequence number - , typeLaunchRequest :: String -- One of "request", "response", or "event" - , commandLaunchRequest :: String -- The command to execute - , argumentsLaunchRequest :: LaunchRequestArguments -- Arguments for "launch" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "LaunchRequest") } ''LaunchRequest) - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.LaunchResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.LaunchRequestJSON - --- | --- Server-initiated response to client request --- -data LaunchResponse = - LaunchResponse { - seqLaunchResponse :: Int -- Sequence number - , typeLaunchResponse :: String -- One of "request", "response", or "event" - , request_seqLaunchResponse :: Int -- Sequence number of the corresponding request - , successLaunchResponse :: Bool -- Outcome of the request - , commandLaunchResponse :: String -- The command requested - , messageLaunchResponse :: String -- Contains error message if success == false. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "LaunchResponse") } ''LaunchResponse) - - --- | --- -defaultLaunchResponse :: Int -> LaunchRequest -> LaunchResponse -defaultLaunchResponse seq (LaunchRequest reqSeq _ _ _) = - LaunchResponse seq "response" reqSeq True "launch" "" - --- | --- -parceErrorLaunchResponse :: Int -> String -> LaunchResponse -parceErrorLaunchResponse seq msg = - LaunchResponse seq "response" seq False "launch" msg - --- | --- -errorLaunchResponse :: Int -> LaunchRequest -> String -> LaunchResponse -errorLaunchResponse seq (LaunchRequest reqSeq _ _ _) msg = - LaunchResponse seq "response" reqSeq False "launch" msg - - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/MessageJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/MessageJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/MessageJSON.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.MessageJSON where - -import Data.Aeson -import Data.Aeson.TH -import qualified Data.Map as MAP - -import Phoityne.Utility - --- | --- A structured message object. Used to return errors from requests. --- -data Message = - Message { - idMessage :: Int -- Unique identifier for the message. - , formatMessage :: String -- A format string for the message. Embedded variables have the form '{name}'. If variable name starts with an underscore character, the variable does not contain user data (PII) and can be safely used for telemetry purposes. - , variablesMessage :: MAP.Map String String -- An object used as a dictionary for looking up the variables in the format string. - , sendTelemetryMessage :: Bool -- if true send to telemetry - , showUserMessage :: Bool -- if true show user - , urlMessage :: Maybe String -- An optional url where additional information about this message can be found. - , urlLabelMessage :: Maybe String -- An optional label that is presented to the user as the UI for opening the url. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Message") } ''Message) - -defaultMessage :: Message -defaultMessage = Message 0 "" (MAP.fromList []) False False Nothing Nothing - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/NextArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/NextArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/NextArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.NextArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "next" request. --- -data NextArguments = - NextArguments { - threadIdNextArguments :: Int -- Continue execution for this thread. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "NextArguments") } ''NextArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/NextRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/NextRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/NextRequestJSON.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.NextRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.NextArgumentsJSON - --- | --- Next request; value of command field is "next". --- The request starts the debuggee to run again for one step. --- penDebug will respond with a StoppedEvent (event type 'step') after running the step. --- -data NextRequest = - NextRequest { - seqNextRequest :: Int -- Sequence number - , typeNextRequest :: String -- One of "request", "response", or "event" - , commandNextRequest :: String -- The command to execute - , argumentsNextRequest :: NextArguments -- Arguments for "disconnect" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "NextRequest") } ''NextRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.NextResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.NextRequestJSON - --- | --- Response to "next" request. This is just an acknowledgement, so no body field is required. --- -data NextResponse = - NextResponse { - seqNextResponse :: Int -- Sequence number - , typeNextResponse :: String -- One of "request", "response", or "event" - , request_seqNextResponse :: Int -- Sequence number of the corresponding request - , successNextResponse :: Bool -- Outcome of the request - , commandNextResponse :: String -- The command requested - , messageNextResponse :: String -- Contains error message if success == false. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "NextResponse") } ''NextResponse) - --- | --- -defaultNextResponse :: Int -> NextRequest -> NextResponse -defaultNextResponse seq (NextRequest reqSeq _ _ _) = - NextResponse seq "response" reqSeq True "next" "" - - --- | --- -errorNextResponse :: Int -> NextRequest -> String -> NextResponse -errorNextResponse seq (NextRequest reqSeq _ _ _) msg = - NextResponse seq "response" reqSeq False "next" msg - - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/OutputEventBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/OutputEventBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/OutputEventBodyJSON.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.OutputEventBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Event message for "output" event type. The event indicates that the target has produced output. --- -data OutputEventBody = - OutputEventBody { - categoryOutputEventBody :: String -- The category of output (such as: 'console', 'stdout', 'stderr', 'telemetry'). If not specified, 'console' is assumed. - , outputOutputEventBody :: String -- The output to report. - , dataOutputEventBody :: Maybe String -- Optional data to report. For the 'telemetry' category the data will be sent to telemetry, for the other categories the data is shown in JSON format. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "OutputEventBody") } ''OutputEventBody) - -defaultOutputEventBody :: OutputEventBody -defaultOutputEventBody = OutputEventBody "console" "" Nothing - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/OutputEventJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/OutputEventJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/OutputEventJSON.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Phoityne.IO.GUI.VSCode.TH.OutputEventJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.OutputEventBodyJSON - --- | --- Event message for "output" event type. The event indicates that the target has produced output. --- -data OutputEvent = - OutputEvent { - seqOutputEvent :: Int -- Sequence number - , typeOutputEvent :: String -- One of "request", "response", or "event" - , eventOutputEvent :: String -- Type of event - , bodyOutputEvent :: OutputEventBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "OutputEvent") } ''OutputEvent) - -defaultOutputEvent :: Int -> OutputEvent -defaultOutputEvent resSeq = OutputEvent resSeq "event" "output" defaultOutputEventBody - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/PauseArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/PauseArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/PauseArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.PauseArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "pause" request. --- -data PauseArguments = - PauseArguments { - threadIdPauseArguments :: Int -- Continue execution for this thread. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "PauseArguments") } ''PauseArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/PauseRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/PauseRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/PauseRequestJSON.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.PauseRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.PauseArgumentsJSON - --- | --- Pause request; value of command field is "pause". --- The request suspenses the debuggee. --- penDebug will respond with a StoppedEvent (event type 'pause') after a successful 'pause' command. --- -data PauseRequest = - PauseRequest { - seqPauseRequest :: Int -- Sequence number - , typePauseRequest :: String -- One of "request", "response", or "event" - , commandPauseRequest :: String -- The command to execute - , argumentsPauseRequest :: PauseArguments -- Arguments for "pause" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "PauseRequest") } ''PauseRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/PauseResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/PauseResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/PauseResponseJSON.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.PauseResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.PauseRequestJSON - --- | --- Response to "pause" request. This is just an acknowledgement, so no body field is required. --- -data PauseResponse = - PauseResponse { - seqPauseResponse :: Int -- Sequence number - , typePauseResponse :: String -- One of "request", "response", or "event" - , request_seqPauseResponse :: Int -- Sequence number of the corresponding request - , successPauseResponse :: Bool -- Outcome of the request - , commandPauseResponse :: String -- The command requested - , messagePauseResponse :: String -- Contains error message if success == false. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "PauseResponse") } ''PauseResponse) - --- | --- -defaultPauseResponse :: Int -> PauseRequest -> PauseResponse -defaultPauseResponse seq (PauseRequest reqSeq _ _ _) = - PauseResponse seq "response" reqSeq True "pause" "" - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/RequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/RequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/RequestJSON.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Phoityne.IO.GUI.VSCode.TH.RequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Client-initiated request --- -data Request = - Request { - commandRequest :: String -- The command to execute - -- , argumentsRequest :: [String] -- Object containing arguments for the command - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Request") } ''Request) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ScopeJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ScopeJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ScopeJSON.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ScopeJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- A Scope is a named container for variables. --- -data Scope = - Scope { - nameScope :: String -- name of the scope (as such 'Arguments', 'Locals') - , variablesReferenceScope :: Int -- The variables of this scope can be retrieved by passing the value of variablesReference to the VariablesRequest. - , expensiveScope :: Bool -- If true, the number of variables in this scope is large or expensive to retrieve. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Scope") } ''Scope) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ScopesArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ScopesArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ScopesArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ScopesArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "scopes" request. --- -data ScopesArguments = - ScopesArguments { - frameIdScopesArguments :: Int -- Retrieve the scopes for this stackframe. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesArguments") } ''ScopesArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ScopesBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ScopesBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ScopesBodyJSON.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ScopesBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ScopeJSON - --- | --- Response to "scopes" request. --- -data ScopesBody = - ScopesBody { - scopesScopesBody :: [Scope] -- The scopes of the stackframe. If the array has length zero, there are no scopes available. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesBody") } ''ScopesBody) - -defaultScopesBody :: ScopesBody -defaultScopesBody = ScopesBody [Scope "GHCi scope" 1 False] - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ScopesRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ScopesRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ScopesRequestJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ScopesRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ScopesArgumentsJSON - --- | --- Scopes request; value of command field is "scopes". --- The request returns the variable scopes for a given stackframe ID. --- -data ScopesRequest = - ScopesRequest { - seqScopesRequest :: Int -- Sequence number - , typeScopesRequest :: String -- One of "request", "response", or "event" - , commandScopesRequest :: String -- The command to execute - , argumentsScopesRequest :: ScopesArguments -- Arguments for "scopes" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesRequest") } ''ScopesRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ScopesResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ScopesBodyJSON -import Phoityne.IO.GUI.VSCode.TH.ScopesRequestJSON - --- | --- Response to "scopes" request. --- -data ScopesResponse = - ScopesResponse { - seqScopesResponse :: Int -- Sequence number - , typeScopesResponse :: String -- One of "request", "response", or "event" - , request_seqScopesResponse :: Int -- Sequence number of the corresponding request - , successScopesResponse :: Bool -- Outcome of the request - , commandScopesResponse :: String -- The command requested - , messageScopesResponse :: String -- Contains error message if success == false. - , bodyScopesResponse :: ScopesBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesResponse") } ''ScopesResponse) - - --- | --- -defaultScopesResponse :: Int -> ScopesRequest -> ScopesResponse -defaultScopesResponse seq (ScopesRequest reqSeq _ _ _) = - ScopesResponse seq "response" reqSeq True "scopes" "" defaultScopesBody - - --- | --- -errorScopesResponse :: Int -> ScopesRequest -> String -> ScopesResponse -errorScopesResponse seq (ScopesRequest reqSeq _ _ _) msg = - ScopesResponse seq "response" reqSeq False "scopes" msg defaultScopesBody - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.SourceJSON -import Phoityne.IO.GUI.VSCode.TH.SourceBreakpointJSON - --- | --- Arguments for "setBreakpoints" request. --- -data SetBreakpointsRequestArguments = - SetBreakpointsRequestArguments { - sourceSetBreakpointsRequestArguments :: Source -- The source location of the breakpoints; either source.path or source.reference must be specified. - , breakpointsSetBreakpointsRequestArguments :: [SourceBreakpoint] -- The code locations of the breakpoints. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsRequestArguments") } ''SetBreakpointsRequestArguments) - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestJSON.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestArgumentsJSON - --- | --- SetBreakpoints request; value of command field is "setBreakpoints". --- Sets multiple breakpoints for a single source and clears all previous breakpoints in that source. --- To clear all breakpoint for a source, specify an empty array. --- When a breakpoint is hit, a StoppedEvent (event type 'breakpoint') is generated. --- -data SetBreakpointsRequest = - SetBreakpointsRequest { - seqSetBreakpointsRequest :: Int -- Sequence number - , typeSetBreakpointsRequest :: String -- One of "request", "response", or "event" - , commandSetBreakpointsRequest :: String -- The command to execute - , argumentsSetBreakpointsRequest :: SetBreakpointsRequestArguments -- Arguments for "setBreakpoints" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsRequest") } ''SetBreakpointsRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseBodyJSON.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.BreakpointJSON - --- | --- Response to "setBreakpoints" request. --- Returned is information about each breakpoint created by this request. --- This includes the actual code location and whether the breakpoint could be verified. --- The breakpoints returned are in the same order as the elements of the 'breakpoints' --- (or the deprecated 'lines') in the SetBreakpointsArguments. --- -data SetBreakpointsResponseBody = - SetBreakpointsResponseBody { - breakpoints :: [Breakpoint] -- Information about the breakpoints. The array elements are in the same order as the elements of the 'breakpoints' (or the deprecated 'lines') in the SetBreakpointsArguments. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsResponseBody") } ''SetBreakpointsResponseBody) - --- | --- -defaultSetBreakpointsResponseBody :: SetBreakpointsResponseBody -defaultSetBreakpointsResponseBody = SetBreakpointsResponseBody [] - - - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestJSON -import Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseBodyJSON - --- | --- Response to "setBreakpoints" request. --- Returned is information about each breakpoint created by this request. --- This includes the actual code location and whether the breakpoint could be verified. --- The breakpoints returned are in the same order as the elements of the 'breakpoints' --- (or the deprecated 'lines') in the SetBreakpointsArguments. --- -data SetBreakpointsResponse = - SetBreakpointsResponse { - seqSetBreakpointsResponse :: Int -- Sequence number - , typeSetBreakpointsResponse :: String -- One of "request", "response", or "event" - , request_seqSetBreakpointsResponse :: Int -- Sequence number of the corresponding request - , successSetBreakpointsResponse :: Bool -- Outcome of the request - , commandSetBreakpointsResponse :: String -- The command requested - , messageSetBreakpointsResponse :: String -- Contains error message if success == false. - , bodySetBreakpointsResponse :: SetBreakpointsResponseBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsResponse") } ''SetBreakpointsResponse) - - --- | --- -defaultSetBreakpointsResponse :: Int -> SetBreakpointsRequest -> SetBreakpointsResponse -defaultSetBreakpointsResponse seq (SetBreakpointsRequest reqSeq _ _ _) = - SetBreakpointsResponse seq "response" reqSeq True "setBreakpoints" "" defaultSetBreakpointsResponseBody - - --- | --- -errorSetBreakpointsResponse :: Int -> SetBreakpointsRequest -> String -> SetBreakpointsResponse -errorSetBreakpointsResponse seq (SetBreakpointsRequest reqSeq _ _ _) msg = - SetBreakpointsResponse seq "response" reqSeq False "setBreakpoints" msg defaultSetBreakpointsResponseBody - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SourceArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SourceArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SourceArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SourceArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "source" request. --- -data SourceArguments = - SourceArguments { - sourceReferenceSourceArguments :: Int -- The reference to the source. This is the value received in Source.reference. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceArguments") } ''SourceArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SourceBreakpointJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SourceBreakpointJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SourceBreakpointJSON.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Phoityne.IO.GUI.VSCode.TH.SourceBreakpointJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Properties of a breakpoint passed to the setBreakpoints request. --- -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. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceBreakpoint") } ''SourceBreakpoint) - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SourceJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SourceJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SourceJSON.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SourceJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- A Source is a descriptor for source code. It is returned from the debug adapter as part of a StackFrame and it is used by clients when specifying breakpoints. --- -data Source = - Source { - nameSource :: Maybe String -- The short name of the source. Every source returned from the debug adapter has a name. When specifying a source to the debug adapter this name is optional. - , pathSource :: String -- The long (absolute) path of the source. It is not guaranteed that the source exists at this location. - , sourceReferenceSource :: Maybe Int -- If sourceReference > 0 the contents of the source can be retrieved through the SourceRequest. A sourceReference is only valid for a session, so it must not be used to persist a source. - , origineSource :: Maybe String -- The (optional) origin of this source: possible values "internal module", "inlined content from source map", etc. - -- , adapterDataSource :: Any -- Optional data that a debug adapter might want to loop through the client. The client should leave the data intact and persist it across sessions. The client should not interpret the data. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Source") } ''Source) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SourceRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SourceRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SourceRequestJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SourceRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.SourceArgumentsJSON - --- | --- Source request; value of command field is "source". --- The request retrieves the source code for a given source reference. --- -data SourceRequest = - SourceRequest { - seqSourceRequest :: Int -- Sequence number - , typeSourceRequest :: String -- One of "request", "response", or "event" - , commandSourceRequest :: String -- The command to execute - , argumentsSourceRequest :: SourceArguments -- Arguments for "source" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceRequest") } ''SourceRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SourceResponseBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SourceResponseBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SourceResponseBodyJSON.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SourceResponseBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - - --- | --- Response to "source" request. --- -data SourceResponseBody = - SourceResponseBody { - contentSourceResponseBody :: String -- Content of the source reference - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceResponseBody") } ''SourceResponseBody) - - --- | --- -defaultSourceResponseBody :: SourceResponseBody -defaultSourceResponseBody = SourceResponseBody "" - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SourceResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SourceResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/SourceResponseJSON.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.SourceResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.SourceResponseBodyJSON -import Phoityne.IO.GUI.VSCode.TH.SourceRequestJSON - --- | --- Response to "source" request. --- -data SourceResponse = - SourceResponse { - seqSourceResponse :: Int -- Sequence number - , typeSourceResponse :: String -- One of "request", "response", or "event" - , request_seqSourceResponse :: Int -- Sequence number of the corresponding request - , successSourceResponse :: Bool -- Outcome of the request - , commandSourceResponse :: String -- The command requested - , messageSourceResponse :: String -- Contains error message if success == false. - , bodySourceResponse :: SourceResponseBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceResponse") } ''SourceResponse) - - - --- | --- -defaultSourceResponse :: Int -> SourceRequest -> SourceResponse -defaultSourceResponse seq (SourceRequest reqSeq _ _ _) = - SourceResponse seq "response" reqSeq True "source" "" defaultSourceResponseBody - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StackFrameJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StackFrameJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StackFrameJSON.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StackFrameJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.SourceJSON - --- | --- A Stackframe contains the source location. --- -data StackFrame = - StackFrame { - idStackFrame :: Int -- An identifier for the stack frame. This id can be used to retrieve the scopes of the frame with the 'scopesRequest'. - , nameStackFrame :: String -- The name of the stack frame, typically a method name. - , sourceStackFrame :: Source -- The optional source of the frame. - , lineStackFrame :: Int -- The line within the file of the frame. If source is null or doesn't exist, line is 0 and must be ignored. - , columnStackFrame :: Int -- The column within the line. If source is null or doesn't exist, column is 0 and must be ignored. - , endLineStackFrame :: Int -- An optional end line of the range covered by the stack frame. - , endColumnStackFrame :: Int -- An optional end column of the range covered by the stack frame. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackFrame") } ''StackFrame) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceArgumentsJSON.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StackTraceArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "stackTrace" request. --- -data StackTraceArguments = - StackTraceArguments { - threadIdStackTraceArguments :: Int -- Retrieve the stacktrace for this thread. - , startFrameStackTraceArguments :: Maybe Int -- The index of the first frame to return; if omitted frames start at 0. - , levelsStackTraceArguments :: Int -- The maximum number of frames to return. If levels is not specified or 0, all frames are returned. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackTraceArguments") } ''StackTraceArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceBodyJSON.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StackTraceBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.StackFrameJSON - --- | --- Body for "stackTrace" request. --- -data StackTraceBody = - StackTraceBody { - stackFramesStackTraceBody :: [StackFrame] -- The frames of the stackframe. If the array has length zero, there are no stackframes available. This means that there is no location information available. - , totalFramesStackTraceBody :: Int -- The total number of frames available. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackTraceBody") } ''StackTraceBody) - - --- | --- -defaultStackTraceBody :: StackTraceBody -defaultStackTraceBody = StackTraceBody [] 0 - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceRequestJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StackTraceRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.StackTraceArgumentsJSON - --- | --- StackTrace request; value of command field is "stackTrace". --- The request returns a stacktrace from the current execution state. --- -data StackTraceRequest = - StackTraceRequest { - seqStackTraceRequest :: Int -- Sequence number - , typeStackTraceRequest :: String -- One of "request", "response", or "event" - , commandStackTraceRequest :: String -- The command to execute - , argumentsStackTraceRequest :: StackTraceArguments -- Arguments for "stackTrace" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackTraceRequest") } ''StackTraceRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StackTraceResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.StackTraceBodyJSON -import Phoityne.IO.GUI.VSCode.TH.StackTraceRequestJSON - --- | --- Response to "stackTrace" request. --- -data StackTraceResponse = - StackTraceResponse { - seqStackTraceResponse :: Int -- Sequence number - , typeStackTraceResponse :: String -- One of "request", "response", or "event" - , request_seqStackTraceResponse :: Int -- Sequence number of the corresponding request - , successStackTraceResponse :: Bool -- Outcome of the request - , commandStackTraceResponse :: String -- The command requested - , messageStackTraceResponse :: String -- Contains error message if success == false. - , bodyStackTraceResponse :: StackTraceBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackTraceResponse") } ''StackTraceResponse) - --- | --- -defaultStackTraceResponse :: Int -> StackTraceRequest -> StackTraceResponse -defaultStackTraceResponse seq (StackTraceRequest reqSeq _ _ _) = - StackTraceResponse seq "response" reqSeq True "stackTrace" "" defaultStackTraceBody - - --- | --- -errorStackTraceResponse :: Int -> StackTraceRequest -> String -> StackTraceResponse -errorStackTraceResponse seq (StackTraceRequest reqSeq _ _ _) msg = - StackTraceResponse seq "response" reqSeq False "stackTrace" msg defaultStackTraceBody - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepInArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepInArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StepInArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StepInArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "stepIn" request. --- -data StepInArguments = - StepInArguments { - threadIdStepInArguments :: Int -- Continue execution for this thread. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepInArguments") } ''StepInArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepInRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepInRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StepInRequestJSON.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StepInRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.StepInArgumentsJSON - --- | --- StepIn request; value of command field is "stepIn". --- The request starts the debuggee to run again for one step. --- The debug adapter will respond with a StoppedEvent (event type 'step') after running the step. --- -data StepInRequest = - StepInRequest { - seqStepInRequest :: Int -- Sequence number - , typeStepInRequest :: String -- One of "request", "response", or "event" - , commandStepInRequest :: String -- The command to execute - , argumentsStepInRequest :: StepInArguments -- Arguments for "stepIn" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepInRequest") } ''StepInRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StepInResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.StepInRequestJSON - --- | --- Response to "stepIn" request. This is just an acknowledgement, so no body field is required. --- -data StepInResponse = - StepInResponse { - seqStepInResponse :: Int -- Sequence number - , typeStepInResponse :: String -- One of "request", "response", or "event" - , request_seqStepInResponse :: Int -- Sequence number of the corresponding request - , successStepInResponse :: Bool -- Outcome of the request - , commandStepInResponse :: String -- The command requested - , messageStepInResponse :: String -- Contains error message if success == false. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepInResponse") } ''StepInResponse) - --- | --- -defaultStepInResponse :: Int -> StepInRequest -> StepInResponse -defaultStepInResponse seq (StepInRequest reqSeq _ _ _) = - StepInResponse seq "response" reqSeq True "stepIn" "" - - --- | --- -errorStepInResponse :: Int -> StepInRequest -> String -> StepInResponse -errorStepInResponse seq (StepInRequest reqSeq _ _ _) msg = - StepInResponse seq "response" reqSeq False "stepIn" msg - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepOutArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepOutArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StepOutArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StepOutArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "stepOut" request. --- -data StepOutArguments = - StepOutArguments { - threadIdStepOutArguments :: Int -- Continue execution for this thread. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepOutArguments") } ''StepOutArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepOutRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepOutRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StepOutRequestJSON.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StepOutRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.StepOutArgumentsJSON - --- | --- StepOutIn request; value of command field is "stepOut". --- The request starts the debuggee to run again for one step. --- penDebug will respond with a StoppedEvent (event type 'step') after running the step. --- -data StepOutRequest = - StepOutRequest { - seqStepOutRequest :: Int -- Sequence number - , typeStepOutRequest :: String -- One of "request", "response", or "event" - , commandStepOutRequest :: String -- The command to execute - , argumentsStepOutRequest :: StepOutArguments -- Arguments for "stepOut" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepOutRequest") } ''StepOutRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StepOutResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.StepOutRequestJSON - --- | --- Response to "stepOut" request. This is just an acknowledgement, so no body field is required. --- -data StepOutResponse = - StepOutResponse { - seqStepOutResponse :: Int -- Sequence number - , typeStepOutResponse :: String -- One of "request", "response", or "event" - , request_seqStepOutResponse :: Int -- Sequence number of the corresponding request - , successStepOutResponse :: Bool -- Outcome of the request - , commandStepOutResponse :: String -- The command requested - , messageStepOutResponse :: String -- Contains error message if success == false. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepOutResponse") } ''StepOutResponse) - - --- | --- -defaultStepOutResponse :: Int -> StepOutRequest -> StepOutResponse -defaultStepOutResponse seq (StepOutRequest reqSeq _ _ _) = - StepOutResponse seq "response" reqSeq True "stepOut" "" - - --- | --- -errorStepOutResponse :: Int -> StepOutRequest -> String -> StepOutResponse -errorStepOutResponse seq (StepOutRequest reqSeq _ _ _) msg = - StepOutResponse seq "response" reqSeq False "stepOut" msg - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventBodyJSON.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StoppedEventBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Event message for "stopped" event type. --- The event indicates that the execution of the debuggee has stopped due to some condition. --- This can be caused by a break point previously set, a stepping action has completed, by executing a debugger statement etc. --- -data StoppedEventBody = - StoppedEventBody { - reasonStoppedEventBody :: String -- The reason for the event (such as: 'step', 'breakpoint', 'exception', 'pause'). This string is shown in the UI. - , threadIdStoppedEventBody :: Int -- The thread which was stopped. - , textStoppedEventBody :: String -- Additional information. E.g. if reason is 'exception', text contains the exception name. This string is shown in the UI. - - -- If allThreadsStopped is true, a debug adapter can announce that all threads have stopped. - -- The client should use this information to enable that all threads can be expanded to access their stacktraces. - -- If the attribute is missing or false, only the thread with the given threadId can be expanded. - , allThreadsStoppedStoppedEventBody :: Bool - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StoppedEventBody") } ''StoppedEventBody) - -defaultStoppedEventBody :: StoppedEventBody -defaultStoppedEventBody = StoppedEventBody "breakpoint" 0 "" False - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventJSON.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.StoppedEventJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.StoppedEventBodyJSON - --- | --- Event message for "stopped" event type. --- The event indicates that the execution of the debuggee has stopped due to some condition. --- This can be caused by a break point previously set, a stepping action has completed, by executing a debugger statement etc. --- -data StoppedEvent = - StoppedEvent { - seqStoppedEvent :: Int -- Sequence number - , typeStoppedEvent :: String -- One of "request", "response", or "event" - , eventStoppedEvent :: String -- Type of event - , bodyStoppedEvent :: StoppedEventBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StoppedEvent") } ''StoppedEvent) - -defaultStoppedEvent :: Int -> StoppedEvent -defaultStoppedEvent seq = StoppedEvent seq "event" "stopped" defaultStoppedEventBody - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/TerminatedEventBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/TerminatedEventBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/TerminatedEventBodyJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.TerminatedEventBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Event message for "terminated" event types. --- The event indicates that debugging of the debuggee has terminated. --- -data TerminatedEventBody = - TerminatedEventBody { - restartTerminatedEventBody :: Bool -- A debug adapter may set 'restart' to true to request that the front end restarts the session. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "TerminatedEventBody") } ''TerminatedEventBody) - -defaultTerminatedEventBody :: TerminatedEventBody -defaultTerminatedEventBody = TerminatedEventBody False - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/TerminatedEventJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/TerminatedEventJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/TerminatedEventJSON.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.TerminatedEventJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.TerminatedEventBodyJSON - --- | --- Event message for "terminated" event types. --- The event indicates that debugging of the debuggee has terminated. --- -data TerminatedEvent = - TerminatedEvent { - seqTerminatedEvent :: Int -- Sequence number - , typeTerminatedEvent :: String -- One of "request", "response", or "event" - , eventTerminatedEvent :: String -- Type of event - , bodyTerminatedEvent :: TerminatedEventBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "TerminatedEvent") } ''TerminatedEvent) - -defaultTerminatedEvent :: Int -> TerminatedEvent -defaultTerminatedEvent seq = TerminatedEvent seq "event" "terminated" defaultTerminatedEventBody - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ThreadJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ThreadJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ThreadJSON.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ThreadJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- A Thread is a name/value pair. --- If the value is structured (has children), a handle is provided to retrieve the children with the ThreadsRequest. --- -data Thread = - Thread { - idThread :: Int -- Unique identifier for the thread. - , nameThread :: String -- A name of the thread. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Thread") } ''Thread) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ThreadsRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ThreadsRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ThreadsRequestJSON.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ThreadsRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Thread request; value of command field is "threads". --- The request retrieves a list of all threads. --- -data ThreadsRequest = - ThreadsRequest { - seqThreadsRequest :: Int -- Sequence number - , typeThreadsRequest :: String -- One of "request", "response", or "event" - , commandThreadsRequest :: String -- The command to execute - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ThreadsRequest") } ''ThreadsRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseBodyJSON.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ThreadsResponseBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ThreadJSON - --- | --- Response to "threads" request. --- -data ThreadsResponseBody = - ThreadsResponseBody { - threadsThreadsResponseBody :: [Thread] -- All threads. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ThreadsResponseBody") } ''ThreadsResponseBody) - - --- | --- -defaultThreadsResponseBody :: ThreadsResponseBody -defaultThreadsResponseBody = ThreadsResponseBody [Thread 0 "ghci main thread"] - - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.ThreadsResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.ThreadsResponseBodyJSON -import Phoityne.IO.GUI.VSCode.TH.ThreadsRequestJSON - --- | --- Response to "threads" request. --- -data ThreadsResponse = - ThreadsResponse { - seqThreadsResponse :: Int -- Sequence number - , typeThreadsResponse :: String -- One of "request", "response", or "event" - , request_seqThreadsResponse :: Int -- Sequence number of the corresponding request - , successThreadsResponse :: Bool -- Outcome of the request - , commandThreadsResponse :: String -- The command requested - , messageThreadsResponse :: String -- Contains error message if success == false. - , bodyThreadsResponse :: ThreadsResponseBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ThreadsResponse") } ''ThreadsResponse) - - - --- | --- -defaultThreadsResponse :: Int -> ThreadsRequest -> ThreadsResponse -defaultThreadsResponse seq (ThreadsRequest reqSeq _ _) = - ThreadsResponse seq "response" reqSeq True "threads" "" defaultThreadsResponseBody - - --- | --- -errorThreadsResponse :: Int -> ThreadsRequest -> String -> ThreadsResponse -errorThreadsResponse seq (ThreadsRequest reqSeq _ _) msg = - ThreadsResponse seq "response" reqSeq False "threads" msg defaultThreadsResponseBody - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/VariableJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/VariableJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/VariableJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.VariableJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- A Variable is a name/value pair. --- If the value is structured (has children), a handle is provided to retrieve the children with the VariablesRequest. --- -data Variable = - Variable { - nameVariable :: String -- The variable's name - , typeVariable :: String -- he variable's type. - , valueVariable :: String -- The variable's value. For structured objects this can be a multi line text, e.g. for a function the body of a function. - , variablesReferenceVariable :: Int -- If variablesReference is > 0, the variable is structured and its children can be retrieved by passing variablesReference to the VariablesRequest. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Variable") } ''Variable) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/VariablesArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/VariablesArgumentsJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/VariablesArgumentsJSON.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.VariablesArgumentsJSON where - -import Data.Aeson.TH - -import Phoityne.Utility - --- | --- Arguments for "variables" request. --- -data VariablesArguments = - VariablesArguments { - variablesReferenceVariablesArguments :: Int -- The Variable reference. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablesArguments") } ''VariablesArguments) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/VariablesBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/VariablesBodyJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/VariablesBodyJSON.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.VariablesBodyJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.VariableJSON - --- | --- Response to "variables" request. --- -data VariablesBody = - VariablesBody { - variablesVariablesBody :: [Variable] -- All children for the given variable reference. - } deriving (Show, Read, Eq) - - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablesBody") } ''VariablesBody) - --- | --- -defaultVariablesBody :: VariablesBody -defaultVariablesBody = VariablesBody [] - diff --git a/app/Phoityne/IO/GUI/VSCode/TH/VariablesRequestJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/VariablesRequestJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/VariablesRequestJSON.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.VariablesRequestJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.VariablesArgumentsJSON - --- | --- Variables request; value of command field is "variables". --- Retrieves all children for the given variable reference. --- -data VariablesRequest = - VariablesRequest { - seqVariablesRequest :: Int -- Sequence number - , typeVariablesRequest :: String -- One of "request", "response", or "event" - , commandVariablesRequest :: String -- The command to execute - , argumentsVariablesRequest :: VariablesArguments -- Arguments for "variables" request. - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablesRequest") } ''VariablesRequest) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs deleted file mode 100644 --- a/app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Phoityne.IO.GUI.VSCode.TH.VariablesResponseJSON where - -import Data.Aeson.TH - -import Phoityne.Utility -import Phoityne.IO.GUI.VSCode.TH.VariablesBodyJSON -import Phoityne.IO.GUI.VSCode.TH.VariablesRequestJSON - --- | --- Response to "variables" request. --- -data VariablesResponse = - VariablesResponse { - seqVariablesResponse :: Int -- Sequence number - , typeVariablesResponse :: String -- One of "request", "response", or "event" - , request_seqVariablesResponse :: Int -- Sequence number of the corresponding request - , successVariablesResponse :: Bool -- Outcome of the request - , commandVariablesResponse :: String -- The command requested - , messageVariablesResponse :: String -- Contains error message if success == false. - , bodyVariablesResponse :: VariablesBody - } deriving (Show, Read, Eq) - -$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablesResponse") } ''VariablesResponse) - - - --- | --- -defaultVariablesResponse :: Int -> VariablesRequest -> VariablesResponse -defaultVariablesResponse seq (VariablesRequest reqSeq _ _ _) = - VariablesResponse seq "response" reqSeq True "variables" "" defaultVariablesBody - --- | --- -errorVariablesResponse :: Int -> VariablesRequest -> String -> VariablesResponse -errorVariablesResponse seq (VariablesRequest reqSeq _ _ _) msg = - VariablesResponse seq "response" reqSeq False "variables" msg defaultVariablesBody - - diff --git a/app/Phoityne/IO/Main.hs b/app/Phoityne/IO/Main.hs deleted file mode 100644 --- a/app/Phoityne/IO/Main.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiWayIf #-} - -module Phoityne.IO.Main (run) where - --- モジュール -import qualified Phoityne.Argument as A -import qualified Phoityne.IO.Control as CTRL - --- システム -import Data.Either.Utils -import qualified Control.Exception as E -import qualified Data.ConfigFile as C -import qualified System.Console.CmdArgs as CMD -import qualified System.Log.Logger as L - - --- | --- アプリケーションメイン --- -run :: IO Int -run = flip E.catches handlers $ do - - -- コマンドライン引数設定 - args <- getArgs - - -- INI設定ファイルのRead - iniSet <- loadIniFile args - - -- ロジック実行 - flip E.finally finalProc $ do - CTRL.run args iniSet - - where - handlers = [ E.Handler helpExcept - , E.Handler ioExcept - , E.Handler someExcept - ] - finalProc = L.removeAllHandlers - helpExcept (_ :: A.HelpExitException) = return 0 - ioExcept (e :: E.IOException) = print e >> return 1 - someExcept (e :: E.SomeException) = print e >> return 1 - - --- | --- 引数データの取得 --- -getArgs :: IO A.ArgData -getArgs = E.catches (CMD.cmdArgs A.config) handlers - where - handlers = [E.Handler someExcept] - someExcept (e :: E.SomeException) = if - | "ExitSuccess" == show e -> E.throw A.HelpExitException - | otherwise -> E.throwIO e - - --- | --- INI設定ファイルデータの取得 --- -loadIniFile :: A.ArgData -- コマンドライン引数 - -> IO C.ConfigParser -- INI設定 -loadIniFile _ = do - let cp = forceEither $ C.readstring C.emptyCP defaultIniSetting - return cp{ C.accessfunc = C.interpolatingAccess 5 } - - --- | --- デフォルトINI設定 --- -defaultIniSetting :: String -defaultIniSetting = unlines [ - "[DEFAULT]" - , "work_dir = ./" - , "" - , "[LOG]" - , "file = %(work_dir)sphoityne.log" - , "level = WARNING" - , "" - , "[PHOITYNE]" - ] - diff --git a/app/Phoityne/IO/Utility.hs b/app/Phoityne/IO/Utility.hs deleted file mode 100644 --- a/app/Phoityne/IO/Utility.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} - -module Phoityne.IO.Utility where - --- システム -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LBS -import GHC.IO.Encoding -import Distribution.System -import Control.Monad.Trans.Resource -import qualified Data.Conduit.Binary as C -import qualified Data.Conduit as C -import qualified Data.Conduit.List as C - --- | --- --- -getReadHandleEncoding :: IO TextEncoding -getReadHandleEncoding = if - | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" - | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" - --- | --- --- -loadFile :: FilePath -> IO B.ByteString -loadFile path = do - bs <- runResourceT - $ C.sourceFile path - C.$$ C.consume - return $ B.concat bs - --- | --- --- -saveFile :: FilePath -> B.ByteString -> IO () -saveFile path cont = saveFileLBS path $ LBS.fromStrict cont - --- | --- --- -saveFileLBS :: FilePath -> LBS.ByteString -> IO () -saveFileLBS path cont = runResourceT - $ C.sourceLbs cont - C.$$ C.sinkFile path - - - diff --git a/app/Phoityne/Utility.hs b/app/Phoityne/Utility.hs deleted file mode 100644 --- a/app/Phoityne/Utility.hs +++ /dev/null @@ -1,74 +0,0 @@ - -module Phoityne.Utility where - --- システム -import Data.Either.Utils -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.List as L -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import qualified Data.ConfigFile as CFG -import qualified Data.Tree as TR - - --- | --- UTF8文字列をByteStringへの変換 --- -str2bs :: String -> BS.ByteString -str2bs = TE.encodeUtf8 . T.pack - --- | --- ByteStringをUTF8文字列への変換 --- -bs2str :: BS.ByteString -> String -bs2str = T.unpack. TE.decodeUtf8 - --- | --- UTF8文字列をLazyByteStringへの変換 --- -str2lbs :: String -> LBS.ByteString -str2lbs = TLE.encodeUtf8 . TL.pack - --- | --- LazyByteStringをUTF8文字列への変換 --- -lbs2str :: LBS.ByteString -> String -lbs2str = TL.unpack. TLE.decodeUtf8 - --- | --- INI設定の指定したセクションに含まれる --- すべて設定項目を返す。 --- -getIniItems :: CFG.ConfigParser - -> CFG.SectionSpec - -> [(CFG.OptionSpec, String)] -getIniItems cp sec = foldr go [] opts - where - opts = forceEither $ CFG.options cp sec - go opt acc = let value = forceEither $ CFG.get cp sec opt in - (opt, value) : acc - - --- | --- --- -addChildTree :: TR.Tree a -> TR.Tree a -> TR.Tree a -addChildTree parent child = parent { TR.subForest = child : curForest} - where curForest = TR.subForest parent - - --- | --- --- -pushWithLimit :: (Eq a, Ord a) => [a] -> a -> Int -> [a] -pushWithLimit [] item _ = [item] -pushWithLimit buf item maxSize = if length buf > maxSize then item : L.init buf else item : buf - --- | --- -rdrop :: Eq a => Int -> [a] -> [a] -rdrop cnt = reverse . drop cnt . reverse - diff --git a/app/Phoityne/VSCode/Argument.hs b/app/Phoityne/VSCode/Argument.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/Argument.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-cse #-} + +module Phoityne.VSCode.Argument ( + HelpExitException(..) +, ArgData(..) +, config +) where + +-- システム +import System.Console.CmdArgs +import qualified Control.Exception as E + +import Paths_phoityne_vscode (version) +import Data.Version (showVersion) + +-- | +-- ヘルプ表示時の例外 +-- +data HelpExitException = HelpExitException + deriving (Show, Typeable) + +instance E.Exception HelpExitException + +-- | +-- コマンドライン引数データ設定 +-- モードを使用する場合のサンプル +-- +data ArgData = ModeA deriving (Data, Typeable, Show, Read, Eq) + +-- | +-- アノテーション設定 +-- +config :: ArgData +config = modes [confA] + &= summary sumMsg + &= program "phoityne-vscode" + + where + confA = ModeA { + + } &= name "ModeA" + &= details mdAMsg + &= auto + + sumMsg = unlines [ + "phoityne-vscode-" ++ showVersion version + ] + + mdAMsg = [ + "" + , "Phoityne is a ghci debug viewer for Visual Studio Code. " + , "" + ] + + +-- | +-- enum値引数 +-- +data Method = Get | Post | Put | Delete + deriving (Data, Typeable, Show, Read, Eq) + + diff --git a/app/Phoityne/VSCode/Constant.hs b/app/Phoityne/VSCode/Constant.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/Constant.hs @@ -0,0 +1,74 @@ + +module Phoityne.VSCode.Constant where + +-- | +-- +-- +_INI_SEC_LOG :: String +_INI_SEC_LOG = "LOG" + +_INI_LOG_FILE :: String +_INI_LOG_FILE = "file" + +_INI_LOG_LEVEL :: String +_INI_LOG_LEVEL = "level" + +_INI_SEC_PHOITYNE :: String +_INI_SEC_PHOITYNE = "PHOITYNE" + + +-- | +-- +-- +_LOG_NAME :: String +_LOG_NAME = "phoityne" + +_LOG_FORMAT :: String +_LOG_FORMAT = "$time [$tid] $prio $loggername - $msg" + +_LOG_FORMAT_DATE :: String +_LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S" + + +-- | +-- +-- +type ModuleName = String + +_HS_FILE_EXT :: String +_HS_FILE_EXT = ".hs" + +_PHOITYNE_GHCI_PROMPT :: String +_PHOITYNE_GHCI_PROMPT = "Phoityne>>= " + +_GHCI_PROMPT :: String +_GHCI_PROMPT = "Prelude> " + +_GHCI_MAIN_PROMPT :: String +_GHCI_MAIN_PROMPT = "*Main> " + +_PROJECT_ROOT_MODULE_NAME :: String +_PROJECT_ROOT_MODULE_NAME = "Project Root" + +_INDENT_SPACE :: String +_INDENT_SPACE = " " + +_COMMENT_TAG :: String +_COMMENT_TAG = "-- " + +_UNDO_BUFFER_MAX_SIZE :: Int +_UNDO_BUFFER_MAX_SIZE = 100 + +_AVAILABLE_FILE_EXT :: [String] +_AVAILABLE_FILE_EXT = [ ".hs" + , ".ini" + , ".yaml" + , ".cabal" + ] + +-- | +-- +-- +_NO_BREAK_POINT_LOCATION :: String +_NO_BREAK_POINT_LOCATION = "No breakpoints found at that location." + diff --git a/app/Phoityne/VSCode/IO/Control.hs b/app/Phoityne/VSCode/IO/Control.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/IO/Control.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Phoityne.VSCode.IO.Control where + +-- モジュール +import Phoityne.VSCode.Utility +import qualified Phoityne.VSCode.Argument as A +import qualified Phoityne.VSCode.IO.Core as GUI +import qualified Data.ByteString.Lazy as BSL + +-- システム +import System.IO +import Control.Concurrent +import qualified Data.ConfigFile as C +import Text.Parsec + +-- | +-- ロジックメイン +-- +run :: A.ArgData -- コマンドライン引数 + -> C.ConfigParser -- INI設定 + -> IO Int -- exit code +run _ _ = do + + hSetBuffering stdin NoBuffering + hSetEncoding stdin utf8 + + hSetBuffering stdout NoBuffering + hSetEncoding stdout utf8 + + mvarDat <- newMVar GUI.defaultDebugContextData {GUI.responseHandlerDebugContextData = sendResponse} + + wait mvarDat + + return 1 + +-- | +-- +-- +wait :: MVar GUI.DebugContextData -> IO () +wait mvarDat = 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 + GUI.handleRequest mvarDat newBuf cnt + wait mvarDat + + where + readContentLength :: String -> Either ParseError Int + readContentLength = parse parser "readContentLength" + + parser = do + string "Content-Length: " + len <- manyTill digit (string _TWO_CRLF) + return . read $ len + +-- | +-- +sendResponse :: BSL.ByteString -> IO () +sendResponse 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 + +-- | +-- +-- +_TWO_CRLF :: String +_TWO_CRLF = "\r\n\r\n" + diff --git a/app/Phoityne/VSCode/IO/Core.hs b/app/Phoityne/VSCode/IO/Core.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/IO/Core.hs @@ -0,0 +1,1632 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Phoityne.VSCode.IO.Core ( + handleRequest +, DebugContextData(..) +, defaultDebugContextData +, 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.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 "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 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 + +-- | +-- +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 False True True True [] False False False False False False + 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 + + -- ファイル変更ウォッチの開始 + watch mvarCtx + + sendConsoleEvent mvarCtx $ L.intercalate "\n" infoMsg + sendStdoutEvent mvarCtx $ J.ghciPromptLaunchRequestArguments args + + -- ランチ完了後のメッセージ出力 + infoMsg = [ + "" + , " Now, ghci initialized." + , " Press F5 to start debugging." + , " Or modify source code. it will be loaded to ghci automatically." + , " " + ] + +-- | +-- +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 + + resSeq <- getIncreasedResponseSequence 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 <- 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 + + resSeq <- getIncreasedResponseSequence 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 <- 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 frameId ctx) = J.argumentsEvaluateRequest req + -- moveFrame mvarCtx $ if isJust frameId then fromJust frameId else 0 + + 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 -> case isFunction typeStr of + True -> evaluateResponse (getOnlyType typeStr) (getOnlyType typeStr) + False -> G.force ghciProc outHdl exp >>= \case + Right valStr -> evaluateResponse ((getOnlyValue valStr) ++ " :: " ++ (getOnlyType typeStr)) (getOnlyType typeStr) + Left _ -> evaluateResponse (getOnlyType typeStr) (getOnlyType typeStr) + + withProcess _ exp (Just ghciProc) = G.exec ghciProc outHdl exp >>= \case + Left err -> do + errorM _LOG_NAME $ show err + sendErrorEvent mvarCtx $ show err + + Right cmdStr -> do + -- promptを消す + let result = U.join " " . map U.strip . init . lines $ cmdStr + evaluateResponse result "" + sendStdoutEvent mvarCtx $ "\n" ++ G.promptGHCiProcess ghciProc + + 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 + + +-- |===================================================================== +-- +-- 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 diff --git a/app/Phoityne/VSCode/IO/Main.hs b/app/Phoityne/VSCode/IO/Main.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/IO/Main.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} + +module Phoityne.VSCode.IO.Main (run) where + +-- モジュール +import qualified Phoityne.VSCode.Argument as A +import qualified Phoityne.VSCode.IO.Control as CTRL + +-- システム +import Data.Either.Utils +import qualified Control.Exception as E +import qualified Data.ConfigFile as C +import qualified System.Console.CmdArgs as CMD +import qualified System.Log.Logger as L + + +-- | +-- アプリケーションメイン +-- +run :: IO Int +run = flip E.catches handlers $ do + + -- コマンドライン引数設定 + args <- getArgs + + -- INI設定ファイルのRead + iniSet <- loadIniFile args + + -- ロジック実行 + flip E.finally finalProc $ do + CTRL.run args iniSet + + where + handlers = [ E.Handler helpExcept + , E.Handler ioExcept + , E.Handler someExcept + ] + finalProc = L.removeAllHandlers + helpExcept (_ :: A.HelpExitException) = return 0 + ioExcept (e :: E.IOException) = print e >> return 1 + someExcept (e :: E.SomeException) = print e >> return 1 + + +-- | +-- 引数データの取得 +-- +getArgs :: IO A.ArgData +getArgs = E.catches (CMD.cmdArgs A.config) handlers + where + handlers = [E.Handler someExcept] + someExcept (e :: E.SomeException) = if + | "ExitSuccess" == show e -> E.throw A.HelpExitException + | otherwise -> E.throwIO e + + +-- | +-- INI設定ファイルデータの取得 +-- +loadIniFile :: A.ArgData -- コマンドライン引数 + -> IO C.ConfigParser -- INI設定 +loadIniFile _ = do + let cp = forceEither $ C.readstring C.emptyCP defaultIniSetting + return cp{ C.accessfunc = C.interpolatingAccess 5 } + + +-- | +-- デフォルトINI設定 +-- +defaultIniSetting :: String +defaultIniSetting = unlines [ + "[DEFAULT]" + , "work_dir = ./" + , "" + , "[LOG]" + , "file = %(work_dir)sphoityne.log" + , "level = WARNING" + , "" + , "[PHOITYNE]" + ] + diff --git a/app/Phoityne/VSCode/IO/Utility.hs b/app/Phoityne/VSCode/IO/Utility.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/IO/Utility.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE MultiWayIf #-} + +module Phoityne.VSCode.IO.Utility where + +-- システム +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LBS +import GHC.IO.Encoding +import Distribution.System +import Control.Monad.Trans.Resource +import qualified Data.Conduit.Binary as C +import qualified Data.Conduit as C +import qualified Data.Conduit.List as C + +-- | +-- +-- +getReadHandleEncoding :: IO TextEncoding +getReadHandleEncoding = if + | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" + | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" + +-- | +-- +-- +loadFile :: FilePath -> IO B.ByteString +loadFile path = do + bs <- runResourceT + $ C.sourceFile path + C.$$ C.consume + return $ B.concat bs + +-- | +-- +-- +saveFile :: FilePath -> B.ByteString -> IO () +saveFile path cont = saveFileLBS path $ LBS.fromStrict cont + +-- | +-- +-- +saveFileLBS :: FilePath -> LBS.ByteString -> IO () +saveFileLBS path cont = runResourceT + $ C.sourceLbs cont + C.$$ C.sinkFile path + + + diff --git a/app/Phoityne/VSCode/TH/BreakpointJSON.hs b/app/Phoityne/VSCode/TH/BreakpointJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/BreakpointJSON.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Phoityne.VSCode.TH.BreakpointJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SourceJSON + +-- | +-- Information about a Breakpoint created in setBreakpoints or setFunctionBreakpoints. +-- +data Breakpoint = + Breakpoint { + idBreakpoint :: Maybe Int -- An optional unique identifier for the breakpoint. + , verifiedBreakpoint :: Bool -- If true breakpoint could be set (but not necessarily at the desired location). + , messageBreakpoint :: String -- An optional message about the state of the breakpoint. This is shown to the user and can be used to explain why a breakpoint could not be verified. + , sourceBreakpoint :: Source -- The source where the breakpoint is located. + , lineBreakpoint :: Int -- The actual line of the breakpoint. + , columnBreakpoint :: Int -- The actual column of the breakpoint. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Breakpoint") } ''Breakpoint) + + diff --git a/app/Phoityne/VSCode/TH/ContinueArgumentsJSON.hs b/app/Phoityne/VSCode/TH/ContinueArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ContinueArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ContinueArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "disconnect" request. +-- +data ContinueArguments = + ContinueArguments { + threadIdContinueArguments :: Int -- continue execution for this thread. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ContinueArguments") } ''ContinueArguments) diff --git a/app/Phoityne/VSCode/TH/ContinueRequestJSON.hs b/app/Phoityne/VSCode/TH/ContinueRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ContinueRequestJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ContinueRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ContinueArgumentsJSON + +-- | +-- Continue request; value of command field is "continue". +-- The request starts the debuggee to run again. +-- +data ContinueRequest = + ContinueRequest { + seqContinueRequest :: Int -- Sequence number + , typeContinueRequest :: String -- One of "request", "response", or "event" + , commandContinueRequest :: String -- The command to execute + , argumentsContinueRequest :: ContinueArguments -- Arguments for "continue" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ContinueRequest") } ''ContinueRequest) diff --git a/app/Phoityne/VSCode/TH/ContinueResponseJSON.hs b/app/Phoityne/VSCode/TH/ContinueResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ContinueResponseJSON.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ContinueResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ContinueRequestJSON + +-- | +-- Response to "continue" request. This is just an acknowledgement, so no body field is required. +-- +data ContinueResponse = + ContinueResponse { + seqContinueResponse :: Int -- Sequence number + , typeContinueResponse :: String -- One of "request", "response", or "event" + , request_seqContinueResponse :: Int -- Sequence number of the corresponding request + , successContinueResponse :: Bool -- Outcome of the request + , commandContinueResponse :: String -- The command requested + , messageContinueResponse :: String -- Contains error message if success == false. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ContinueResponse") } ''ContinueResponse) + +-- | +-- +defaultContinueResponse :: Int -> ContinueRequest -> ContinueResponse +defaultContinueResponse seq (ContinueRequest reqSeq _ _ _) = + ContinueResponse seq "response" reqSeq True "continue" "" + + +-- | +-- +parceErrorContinueResponse :: Int -> String -> ContinueResponse +parceErrorContinueResponse seq msg = + ContinueResponse seq "response" (-1) False "continue" msg + +-- | +-- +errorContinueResponse :: Int -> ContinueRequest -> String -> ContinueResponse +errorContinueResponse seq (ContinueRequest reqSeq _ _ _) msg = + ContinueResponse seq "response" reqSeq False "continue" msg diff --git a/app/Phoityne/VSCode/TH/DisconnectArgumentsJSON.hs b/app/Phoityne/VSCode/TH/DisconnectArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/DisconnectArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.DisconnectArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "disconnect" request. +-- +data DisconnectArguments = + DisconnectArguments { + restartDisconnectArguments :: Maybe Bool + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "DisconnectArguments") } ''DisconnectArguments) diff --git a/app/Phoityne/VSCode/TH/DisconnectRequestJSON.hs b/app/Phoityne/VSCode/TH/DisconnectRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/DisconnectRequestJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.DisconnectRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.DisconnectArgumentsJSON + +-- | +-- Disconnect request; value of command field is "disconnect". +-- +data DisconnectRequest = + DisconnectRequest { + seqDisconnectRequest :: Int -- Sequence number + , typeDisconnectRequest :: String -- One of "request", "response", or "event" + , commandDisconnectRequest :: String -- The command to execute + , argumentsDisconnectRequest :: Maybe DisconnectArguments -- Arguments for "disconnect" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "DisconnectRequest") } ''DisconnectRequest) + diff --git a/app/Phoityne/VSCode/TH/DisconnectResponseJSON.hs b/app/Phoityne/VSCode/TH/DisconnectResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/DisconnectResponseJSON.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.DisconnectResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.DisconnectRequestJSON + +-- | +-- Response to "disconnect" request. This is just an acknowledgement, so no body field is required. +-- +data DisconnectResponse = + DisconnectResponse { + seqDisconnectResponse :: Int -- Sequence number + , typeDisconnectResponse :: String -- One of "request", "response", or "event" + , request_seqDisconnectResponse :: Int -- Sequence number of the corresponding request + , successDisconnectResponse :: Bool -- Outcome of the request + , commandDisconnectResponse :: String -- The command requested + , messageDisconnectResponse :: String -- Contains error message if success == false. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "DisconnectResponse") } ''DisconnectResponse) + +-- | +-- +defaultDisconnectResponse :: Int -> DisconnectRequest -> DisconnectResponse +defaultDisconnectResponse seq (DisconnectRequest reqSeq _ _ _) = + DisconnectResponse seq "response" reqSeq True "disconnect" "" + +-- | +-- +parceErrorDisconnectResponse :: Int -> String -> DisconnectResponse +parceErrorDisconnectResponse seq msg = + DisconnectResponse seq "response" (-1) False "disconnect" msg + +-- | +-- +errorDisconnectResponse :: Int -> DisconnectRequest -> String -> DisconnectResponse +errorDisconnectResponse seq (DisconnectRequest reqSeq _ _ _) msg = + DisconnectResponse seq "response" reqSeq False "disconnect" msg diff --git a/app/Phoityne/VSCode/TH/ErrorResponseBodyJSON.hs b/app/Phoityne/VSCode/TH/ErrorResponseBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ErrorResponseBodyJSON.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ErrorResponseBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.MessageJSON + +-- | +-- On error that is whenever 'success' is false, the body can provide more details. +-- +data ErrorResponseBody = + ErrorResponseBody { + errorErrorResponseBody :: Message -- An optional, structured error message. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ErrorResponseBody") } ''ErrorResponseBody) + +-- | +-- +defaultErrorResponseBody :: ErrorResponseBody +defaultErrorResponseBody = ErrorResponseBody defaultMessage + + diff --git a/app/Phoityne/VSCode/TH/ErrorResponseJSON.hs b/app/Phoityne/VSCode/TH/ErrorResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ErrorResponseJSON.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Phoityne.VSCode.TH.ErrorResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ErrorResponseBodyJSON + +-- | +-- On error that is whenever 'success' is false, the body can provide more details. +-- +data ErrorResponse = + ErrorResponse { + seqErrorResponse :: Int -- Sequence number + , typeErrorResponse :: String -- One of "request", "response", or "event" + , request_seqErrorResponse :: Int -- Sequence number of the corresponding request + , successErrorResponse :: Bool -- Outcome of the request + , commandErrorResponse :: String -- The command requested + , messageErrorResponse :: String -- Contains error message if success == false. + , bodyErrorResponse :: ErrorResponseBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ErrorResponse") } ''ErrorResponse) + +-- | +-- +defaultErrorResponse :: Int -> Int -> String -> ErrorResponse +defaultErrorResponse seq reqSeq cmd = + ErrorResponse seq "response" reqSeq False cmd "" defaultErrorResponseBody diff --git a/app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs b/app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/EvaluateArgumentsJSON.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.EvaluateArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "evaluate" request. +-- +data EvaluateArguments = + EvaluateArguments { + expressionEvaluateArguments :: String -- The expression to evaluate. + , frameIdEvaluateArguments :: Maybe Int -- Evaluate the expression in the scope of this stack frame. If not specified, the expression is evaluated in the global scope. + , contextEvaluateArguments :: String -- The context in which the evaluate request is run. Possible values are 'watch' if evaluate is run in a watch, 'repl' if run from the REPL console, or 'hover' if run from a data hover. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "EvaluateArguments") } ''EvaluateArguments) diff --git a/app/Phoityne/VSCode/TH/EvaluateBodyJSON.hs b/app/Phoityne/VSCode/TH/EvaluateBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/EvaluateBodyJSON.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.EvaluateBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Response to "evaluate" request. +-- +data EvaluateBody = + EvaluateBody { + resultEvaluateBody :: String -- The result of the evaluate. + , typeEvaluateBody :: String -- The optional type of the evaluate result. + , variablesReferenceEvaluateBody :: Int -- If variablesReference is > 0, the evaluate result is structured and its children can be retrieved by passing variablesReference to the VariablesRequest + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "EvaluateBody") } ''EvaluateBody) + +-- | +-- +defaultEvaluateBody :: EvaluateBody +defaultEvaluateBody = EvaluateBody "" "" 0 + + + diff --git a/app/Phoityne/VSCode/TH/EvaluateRequestJSON.hs b/app/Phoityne/VSCode/TH/EvaluateRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/EvaluateRequestJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.EvaluateRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.EvaluateArgumentsJSON + +-- | +-- Evaluate request; value of command field is "evaluate". +-- Evaluates the given expression in the context of the top most stack frame. +-- The expression has access to any variables and arguments that are in scope. +-- +data EvaluateRequest = + EvaluateRequest { + seqEvaluateRequest :: Int -- Sequence number + , typeEvaluateRequest :: String -- One of "request", "response", or "event" + , commandEvaluateRequest :: String -- The command to execute + , argumentsEvaluateRequest :: EvaluateArguments -- Arguments for "evaluate" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "EvaluateRequest") } ''EvaluateRequest) diff --git a/app/Phoityne/VSCode/TH/EvaluateResponseJSON.hs b/app/Phoityne/VSCode/TH/EvaluateResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/EvaluateResponseJSON.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.EvaluateResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.EvaluateBodyJSON +import Phoityne.VSCode.TH.EvaluateRequestJSON + +-- | +-- Response to "evaluate" request. +-- +data EvaluateResponse = + EvaluateResponse { + seqEvaluateResponse :: Int -- Sequence number + , typeEvaluateResponse :: String -- One of "request", "response", or "event" + , request_seqEvaluateResponse :: Int -- Sequence number of the corresponding request + , successEvaluateResponse :: Bool -- Outcome of the request + , commandEvaluateResponse :: String -- The command requested + , messageEvaluateResponse :: String -- Contains error message if success == false. + , bodyEvaluateResponse :: EvaluateBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "EvaluateResponse") } ''EvaluateResponse) + + +-- | +-- +defaultEvaluateResponse :: Int -> EvaluateRequest -> EvaluateResponse +defaultEvaluateResponse seq (EvaluateRequest reqSeq _ _ _) = + EvaluateResponse seq "response" reqSeq True "evaluate" "" defaultEvaluateBody + +-- | +-- +errorEvaluateResponse :: Int -> EvaluateRequest -> String -> EvaluateResponse +errorEvaluateResponse seq (EvaluateRequest reqSeq _ _ _) msg = + EvaluateResponse seq "response" reqSeq False "evaluate" msg defaultEvaluateBody + diff --git a/app/Phoityne/VSCode/TH/ExceptionBreakpointsFilterJSON.hs b/app/Phoityne/VSCode/TH/ExceptionBreakpointsFilterJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ExceptionBreakpointsFilterJSON.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ExceptionBreakpointsFilterJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- An ExceptionBreakpointsFilter is shown in the UI as an option for configuring how exceptions are dealt with. +-- +data ExceptionBreakpointsFilter = + ExceptionBreakpointsFilter { + filterExceptionBreakpointsFilter :: String -- The internal ID of the filter. This value is passed to the setExceptionBreakpoints request. + , labelExceptionBreakpointsFilter :: String -- The name of the filter. This will be shown in the UI. + , defaultExceptionBreakpointsFilter :: Bool -- Initial value of the filter. If not specified a value 'false' is assumed. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ExceptionBreakpointsFilter") } ''ExceptionBreakpointsFilter) + diff --git a/app/Phoityne/VSCode/TH/ExitedEventBodyJSON.hs b/app/Phoityne/VSCode/TH/ExitedEventBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ExitedEventBodyJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ExitedEventBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Event message for "exited" event type. +-- The event indicates that the debuggee has exited. +-- +data ExitedEventBody = + ExitedEventBody { + exitCodeExitedEventBody :: Int -- The exit code returned from the debuggee. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ExitedEventBody") } ''ExitedEventBody) + +defaultExitedEventBody :: Int -> ExitedEventBody +defaultExitedEventBody code = ExitedEventBody code + diff --git a/app/Phoityne/VSCode/TH/ExitedEventJSON.hs b/app/Phoityne/VSCode/TH/ExitedEventJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ExitedEventJSON.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ExitedEventJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ExitedEventBodyJSON + +-- | +-- Event message for "exited" event type. +-- The event indicates that the debuggee has exited. +-- +data ExitedEvent = + ExitedEvent { + seqExitedEvent :: Int -- Sequence number + , typeExitedEvent :: String -- One of "request", "response", or "event" + , eventExitedEvent :: String -- Type of event + , bodyExitedEvent :: ExitedEventBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ExitedEvent") } ''ExitedEvent) + +defaultExitedEvent :: Int -> Int -> ExitedEvent +defaultExitedEvent seq code = ExitedEvent seq "event" "exited" $ defaultExitedEventBody code + diff --git a/app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs b/app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/FunctionBreakpointJSON.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Phoityne.VSCode.TH.FunctionBreakpointJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Properties of a breakpoint passed to the setFunctionBreakpoints request. +-- +data FunctionBreakpoint = + FunctionBreakpoint { + nameFunctionBreakpoint :: String -- The name of the function. + , conditionFunctionBreakpoint :: Maybe String -- An optional expression for conditional breakpoints. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "FunctionBreakpoint") } ''FunctionBreakpoint) + + diff --git a/app/Phoityne/VSCode/TH/InitializeRequestArgumentsJSON.hs b/app/Phoityne/VSCode/TH/InitializeRequestArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/InitializeRequestArgumentsJSON.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.InitializeRequestArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Initialize request; value of command field is "initialize". +-- +data InitializeRequestArguments = + InitializeRequestArguments { + adapterIDInitializeRequestArguments :: String -- The ID of the debugger adapter. Used to select or verify debugger adapter. + , linesStartAt1InitializeRequestArguments :: Bool -- If true all line numbers are 1-based (default). + , columnsStartAt1InitializeRequestArguments :: Bool -- If true all column numbers are 1-based (default). + , pathFormatInitializeRequestArguments :: String -- Determines in what format paths are specified. Possible values are 'path' or 'uri'. The default is 'path', which is the native format. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeRequestArguments") } ''InitializeRequestArguments) + +defaultInitializeRequestArguments :: InitializeRequestArguments +defaultInitializeRequestArguments = InitializeRequestArguments "" False False "" diff --git a/app/Phoityne/VSCode/TH/InitializeRequestJSON.hs b/app/Phoityne/VSCode/TH/InitializeRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/InitializeRequestJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Phoityne.VSCode.TH.InitializeRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.InitializeRequestArgumentsJSON + +-- | +-- Client-initiated request +-- +data InitializeRequest = + InitializeRequest { + seqInitializeRequest :: Int -- Sequence number + , typeInitializeRequest :: String -- One of "request", "response", or "event" + , commandInitializeRequest :: String -- The command to execute + , argumentsInitializeRequest :: InitializeRequestArguments -- Object containing arguments for the command + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeRequest") } ''InitializeRequest) + +defaultInitializeRequest :: InitializeRequest +defaultInitializeRequest = InitializeRequest 0 "" "" defaultInitializeRequestArguments diff --git a/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/InitializeResponseCapabilitesJSON.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ExceptionBreakpointsFilterJSON + +-- | +-- Information about the capabilities of a debug adapter. +-- +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. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilites") } ''InitializeResponseCapabilites) + +-- | +-- +defaultInitializeResponseCapabilites :: InitializeResponseCapabilites +defaultInitializeResponseCapabilites = InitializeResponseCapabilites False False False False [] False False False False False False + diff --git a/app/Phoityne/VSCode/TH/InitializeResponseJSON.hs b/app/Phoityne/VSCode/TH/InitializeResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/InitializeResponseJSON.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.InitializeResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON +import Phoityne.VSCode.TH.InitializeRequestJSON + +-- | +-- Server-initiated response to client request +-- +data InitializeResponse = + InitializeResponse { + seqInitializeResponse :: Int -- Sequence number + , typeInitializeResponse :: String -- One of "request", "response", or "event" + , request_seqInitializeResponse :: Int -- Sequence number of the corresponding request + , successInitializeResponse :: Bool -- Outcome of the request + , commandInitializeResponse :: String -- The command requested + , messageInitializeResponse :: String -- Contains error message if success == false. + , bodyInitializeResponse :: InitializeResponseCapabilites -- The capabilities of this debug adapter + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponse") } ''InitializeResponse) + + +-- | +-- +parseErrorInitializeResponse :: Int -> String -> InitializeResponse +parseErrorInitializeResponse seq msg = + InitializeResponse seq "response" seq False "initialize" msg defaultInitializeResponseCapabilites + +-- | +-- +errorInitializeResponse :: Int -> InitializeRequest -> String -> InitializeResponse +errorInitializeResponse seq (InitializeRequest reqSeq _ _ _) msg = + InitializeResponse seq "response" reqSeq False "initialize" msg defaultInitializeResponseCapabilites + diff --git a/app/Phoityne/VSCode/TH/InitializedEventJSON.hs b/app/Phoityne/VSCode/TH/InitializedEventJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/InitializedEventJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.InitializedEventJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Server-initiated response to client request +-- +data InitializedEvent = + InitializedEvent { + seqInitializedEvent :: Int -- Sequence number + , typeInitializedEvent :: String -- One of "request", "response", or "event" + , eventInitializedEvent :: String -- Type of event + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializedEvent") } ''InitializedEvent) + +defaultInitializedEvent :: Int -> InitializedEvent +defaultInitializedEvent resSeq = InitializedEvent resSeq "event" "initialized" diff --git a/app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs b/app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.LaunchRequestArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "launch" request. +-- +data LaunchRequestArguments = + LaunchRequestArguments { + noDebugLaunchRequestArguments :: Maybe Bool -- If noDebug is true the launch request should launch the program without enabling debugging. + , nameLaunchRequestArguments :: String -- Phoityne specific argument. required. + , typeLaunchRequestArguments :: String -- Phoityne specific argument. required. + , requestLaunchRequestArguments :: String -- Phoityne specific argument. required. must be "request" + , startupLaunchRequestArguments :: String -- Phoityne specific argument. required. + , workspaceLaunchRequestArguments :: String -- Phoityne specific argument. required. + , logFileLaunchRequestArguments :: String -- Phoityne specific argument. required. + , logLevelLaunchRequestArguments :: String -- Phoityne specific argument. required. + , ghciPromptLaunchRequestArguments :: String -- Phoityne specific argument. required. + , ghciCmdLaunchRequestArguments :: String -- Phoityne specific argument. required. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "LaunchRequestArguments") } ''LaunchRequestArguments) + diff --git a/app/Phoityne/VSCode/TH/LaunchRequestJSON.hs b/app/Phoityne/VSCode/TH/LaunchRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/LaunchRequestJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.LaunchRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.LaunchRequestArgumentsJSON + +-- | +-- Launch request; value of command field is "launch". +-- +data LaunchRequest = + LaunchRequest { + seqLaunchRequest :: Int -- Sequence number + , typeLaunchRequest :: String -- One of "request", "response", or "event" + , commandLaunchRequest :: String -- The command to execute + , argumentsLaunchRequest :: LaunchRequestArguments -- Arguments for "launch" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "LaunchRequest") } ''LaunchRequest) + diff --git a/app/Phoityne/VSCode/TH/LaunchResponseJSON.hs b/app/Phoityne/VSCode/TH/LaunchResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/LaunchResponseJSON.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.LaunchResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.LaunchRequestJSON + +-- | +-- Server-initiated response to client request +-- +data LaunchResponse = + LaunchResponse { + seqLaunchResponse :: Int -- Sequence number + , typeLaunchResponse :: String -- One of "request", "response", or "event" + , request_seqLaunchResponse :: Int -- Sequence number of the corresponding request + , successLaunchResponse :: Bool -- Outcome of the request + , commandLaunchResponse :: String -- The command requested + , messageLaunchResponse :: String -- Contains error message if success == false. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "LaunchResponse") } ''LaunchResponse) + + +-- | +-- +defaultLaunchResponse :: Int -> LaunchRequest -> LaunchResponse +defaultLaunchResponse seq (LaunchRequest reqSeq _ _ _) = + LaunchResponse seq "response" reqSeq True "launch" "" + +-- | +-- +parceErrorLaunchResponse :: Int -> String -> LaunchResponse +parceErrorLaunchResponse seq msg = + LaunchResponse seq "response" seq False "launch" msg + +-- | +-- +errorLaunchResponse :: Int -> LaunchRequest -> String -> LaunchResponse +errorLaunchResponse seq (LaunchRequest reqSeq _ _ _) msg = + LaunchResponse seq "response" reqSeq False "launch" msg + + + diff --git a/app/Phoityne/VSCode/TH/MessageJSON.hs b/app/Phoityne/VSCode/TH/MessageJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/MessageJSON.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.MessageJSON where + +import Data.Aeson.TH +import qualified Data.Map as MAP + +import Phoityne.VSCode.Utility + +-- | +-- A structured message object. Used to return errors from requests. +-- +data Message = + Message { + idMessage :: Int -- Unique identifier for the message. + , formatMessage :: String -- A format string for the message. Embedded variables have the form '{name}'. If variable name starts with an underscore character, the variable does not contain user data (PII) and can be safely used for telemetry purposes. + , variablesMessage :: MAP.Map String String -- An object used as a dictionary for looking up the variables in the format string. + , sendTelemetryMessage :: Bool -- if true send to telemetry + , showUserMessage :: Bool -- if true show user + , urlMessage :: Maybe String -- An optional url where additional information about this message can be found. + , urlLabelMessage :: Maybe String -- An optional label that is presented to the user as the UI for opening the url. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Message") } ''Message) + +defaultMessage :: Message +defaultMessage = Message 0 "" (MAP.fromList []) False False Nothing Nothing + diff --git a/app/Phoityne/VSCode/TH/NextArgumentsJSON.hs b/app/Phoityne/VSCode/TH/NextArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/NextArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.NextArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "next" request. +-- +data NextArguments = + NextArguments { + threadIdNextArguments :: Int -- Continue execution for this thread. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "NextArguments") } ''NextArguments) diff --git a/app/Phoityne/VSCode/TH/NextRequestJSON.hs b/app/Phoityne/VSCode/TH/NextRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/NextRequestJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.NextRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.NextArgumentsJSON + +-- | +-- Next request; value of command field is "next". +-- The request starts the debuggee to run again for one step. +-- penDebug will respond with a StoppedEvent (event type 'step') after running the step. +-- +data NextRequest = + NextRequest { + seqNextRequest :: Int -- Sequence number + , typeNextRequest :: String -- One of "request", "response", or "event" + , commandNextRequest :: String -- The command to execute + , argumentsNextRequest :: NextArguments -- Arguments for "disconnect" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "NextRequest") } ''NextRequest) diff --git a/app/Phoityne/VSCode/TH/NextResponseJSON.hs b/app/Phoityne/VSCode/TH/NextResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/NextResponseJSON.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.NextResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.NextRequestJSON + +-- | +-- Response to "next" request. This is just an acknowledgement, so no body field is required. +-- +data NextResponse = + NextResponse { + seqNextResponse :: Int -- Sequence number + , typeNextResponse :: String -- One of "request", "response", or "event" + , request_seqNextResponse :: Int -- Sequence number of the corresponding request + , successNextResponse :: Bool -- Outcome of the request + , commandNextResponse :: String -- The command requested + , messageNextResponse :: String -- Contains error message if success == false. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "NextResponse") } ''NextResponse) + +-- | +-- +defaultNextResponse :: Int -> NextRequest -> NextResponse +defaultNextResponse seq (NextRequest reqSeq _ _ _) = + NextResponse seq "response" reqSeq True "next" "" + + +-- | +-- +errorNextResponse :: Int -> NextRequest -> String -> NextResponse +errorNextResponse seq (NextRequest reqSeq _ _ _) msg = + NextResponse seq "response" reqSeq False "next" msg + + + diff --git a/app/Phoityne/VSCode/TH/OutputEventBodyJSON.hs b/app/Phoityne/VSCode/TH/OutputEventBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/OutputEventBodyJSON.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.OutputEventBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Event message for "output" event type. The event indicates that the target has produced output. +-- +data OutputEventBody = + OutputEventBody { + categoryOutputEventBody :: String -- The category of output (such as: 'console', 'stdout', 'stderr', 'telemetry'). If not specified, 'console' is assumed. + , outputOutputEventBody :: String -- The output to report. + , dataOutputEventBody :: Maybe String -- Optional data to report. For the 'telemetry' category the data will be sent to telemetry, for the other categories the data is shown in JSON format. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "OutputEventBody") } ''OutputEventBody) + +defaultOutputEventBody :: OutputEventBody +defaultOutputEventBody = OutputEventBody "console" "" Nothing + + diff --git a/app/Phoityne/VSCode/TH/OutputEventJSON.hs b/app/Phoityne/VSCode/TH/OutputEventJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/OutputEventJSON.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Phoityne.VSCode.TH.OutputEventJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.OutputEventBodyJSON + +-- | +-- Event message for "output" event type. The event indicates that the target has produced output. +-- +data OutputEvent = + OutputEvent { + seqOutputEvent :: Int -- Sequence number + , typeOutputEvent :: String -- One of "request", "response", or "event" + , eventOutputEvent :: String -- Type of event + , bodyOutputEvent :: OutputEventBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "OutputEvent") } ''OutputEvent) + +defaultOutputEvent :: Int -> OutputEvent +defaultOutputEvent resSeq = OutputEvent resSeq "event" "output" defaultOutputEventBody + diff --git a/app/Phoityne/VSCode/TH/PauseArgumentsJSON.hs b/app/Phoityne/VSCode/TH/PauseArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/PauseArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.PauseArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "pause" request. +-- +data PauseArguments = + PauseArguments { + threadIdPauseArguments :: Int -- Continue execution for this thread. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "PauseArguments") } ''PauseArguments) diff --git a/app/Phoityne/VSCode/TH/PauseRequestJSON.hs b/app/Phoityne/VSCode/TH/PauseRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/PauseRequestJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.PauseRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.PauseArgumentsJSON + +-- | +-- Pause request; value of command field is "pause". +-- The request suspenses the debuggee. +-- penDebug will respond with a StoppedEvent (event type 'pause') after a successful 'pause' command. +-- +data PauseRequest = + PauseRequest { + seqPauseRequest :: Int -- Sequence number + , typePauseRequest :: String -- One of "request", "response", or "event" + , commandPauseRequest :: String -- The command to execute + , argumentsPauseRequest :: PauseArguments -- Arguments for "pause" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "PauseRequest") } ''PauseRequest) diff --git a/app/Phoityne/VSCode/TH/PauseResponseJSON.hs b/app/Phoityne/VSCode/TH/PauseResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/PauseResponseJSON.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.PauseResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.PauseRequestJSON + +-- | +-- Response to "pause" request. This is just an acknowledgement, so no body field is required. +-- +data PauseResponse = + PauseResponse { + seqPauseResponse :: Int -- Sequence number + , typePauseResponse :: String -- One of "request", "response", or "event" + , request_seqPauseResponse :: Int -- Sequence number of the corresponding request + , successPauseResponse :: Bool -- Outcome of the request + , commandPauseResponse :: String -- The command requested + , messagePauseResponse :: String -- Contains error message if success == false. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "PauseResponse") } ''PauseResponse) + +-- | +-- +defaultPauseResponse :: Int -> PauseRequest -> PauseResponse +defaultPauseResponse seq (PauseRequest reqSeq _ _ _) = + PauseResponse seq "response" reqSeq True "pause" "" + + diff --git a/app/Phoityne/VSCode/TH/RequestJSON.hs b/app/Phoityne/VSCode/TH/RequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/RequestJSON.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Phoityne.VSCode.TH.RequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Client-initiated request +-- +data Request = + Request { + commandRequest :: String -- The command to execute + -- , argumentsRequest :: [String] -- Object containing arguments for the command + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Request") } ''Request) diff --git a/app/Phoityne/VSCode/TH/ScopeJSON.hs b/app/Phoityne/VSCode/TH/ScopeJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ScopeJSON.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ScopeJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- A Scope is a named container for variables. +-- +data Scope = + Scope { + nameScope :: String -- name of the scope (as such 'Arguments', 'Locals') + , variablesReferenceScope :: Int -- The variables of this scope can be retrieved by passing the value of variablesReference to the VariablesRequest. + , expensiveScope :: Bool -- If true, the number of variables in this scope is large or expensive to retrieve. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Scope") } ''Scope) diff --git a/app/Phoityne/VSCode/TH/ScopesArgumentsJSON.hs b/app/Phoityne/VSCode/TH/ScopesArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ScopesArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ScopesArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "scopes" request. +-- +data ScopesArguments = + ScopesArguments { + frameIdScopesArguments :: Int -- Retrieve the scopes for this stackframe. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesArguments") } ''ScopesArguments) diff --git a/app/Phoityne/VSCode/TH/ScopesBodyJSON.hs b/app/Phoityne/VSCode/TH/ScopesBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ScopesBodyJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ScopesBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ScopeJSON + +-- | +-- Response to "scopes" request. +-- +data ScopesBody = + ScopesBody { + scopesScopesBody :: [Scope] -- The scopes of the stackframe. If the array has length zero, there are no scopes available. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesBody") } ''ScopesBody) + +defaultScopesBody :: ScopesBody +defaultScopesBody = ScopesBody [Scope "GHCi scope" 1 False] + diff --git a/app/Phoityne/VSCode/TH/ScopesRequestJSON.hs b/app/Phoityne/VSCode/TH/ScopesRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ScopesRequestJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ScopesRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ScopesArgumentsJSON + +-- | +-- Scopes request; value of command field is "scopes". +-- The request returns the variable scopes for a given stackframe ID. +-- +data ScopesRequest = + ScopesRequest { + seqScopesRequest :: Int -- Sequence number + , typeScopesRequest :: String -- One of "request", "response", or "event" + , commandScopesRequest :: String -- The command to execute + , argumentsScopesRequest :: ScopesArguments -- Arguments for "scopes" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesRequest") } ''ScopesRequest) diff --git a/app/Phoityne/VSCode/TH/ScopesResponseJSON.hs b/app/Phoityne/VSCode/TH/ScopesResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ScopesResponseJSON.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ScopesResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ScopesBodyJSON +import Phoityne.VSCode.TH.ScopesRequestJSON + +-- | +-- Response to "scopes" request. +-- +data ScopesResponse = + ScopesResponse { + seqScopesResponse :: Int -- Sequence number + , typeScopesResponse :: String -- One of "request", "response", or "event" + , request_seqScopesResponse :: Int -- Sequence number of the corresponding request + , successScopesResponse :: Bool -- Outcome of the request + , commandScopesResponse :: String -- The command requested + , messageScopesResponse :: String -- Contains error message if success == false. + , bodyScopesResponse :: ScopesBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ScopesResponse") } ''ScopesResponse) + + +-- | +-- +defaultScopesResponse :: Int -> ScopesRequest -> ScopesResponse +defaultScopesResponse seq (ScopesRequest reqSeq _ _ _) = + ScopesResponse seq "response" reqSeq True "scopes" "" defaultScopesBody + + +-- | +-- +errorScopesResponse :: Int -> ScopesRequest -> String -> ScopesResponse +errorScopesResponse seq (ScopesRequest reqSeq _ _ _) msg = + ScopesResponse seq "response" reqSeq False "scopes" msg defaultScopesBody + diff --git a/app/Phoityne/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs b/app/Phoityne/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SourceJSON +import Phoityne.VSCode.TH.SourceBreakpointJSON + +-- | +-- Arguments for "setBreakpoints" request. +-- +data SetBreakpointsRequestArguments = + SetBreakpointsRequestArguments { + sourceSetBreakpointsRequestArguments :: Source -- The source location of the breakpoints; either source.path or source.reference must be specified. + , breakpointsSetBreakpointsRequestArguments :: [SourceBreakpoint] -- The code locations of the breakpoints. + --, sourceModifiedSetBreakpointsRequestArguments :: Bool -- A value of true indicates that the underlying source has been modified which results in new breakpoint locations. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsRequestArguments") } ''SetBreakpointsRequestArguments) + diff --git a/app/Phoityne/VSCode/TH/SetBreakpointsRequestJSON.hs b/app/Phoityne/VSCode/TH/SetBreakpointsRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetBreakpointsRequestJSON.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetBreakpointsRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON + +-- | +-- SetBreakpoints request; value of command field is "setBreakpoints". +-- Sets multiple breakpoints for a single source and clears all previous breakpoints in that source. +-- To clear all breakpoint for a source, specify an empty array. +-- When a breakpoint is hit, a StoppedEvent (event type 'breakpoint') is generated. +-- +data SetBreakpointsRequest = + SetBreakpointsRequest { + seqSetBreakpointsRequest :: Int -- Sequence number + , typeSetBreakpointsRequest :: String -- One of "request", "response", or "event" + , commandSetBreakpointsRequest :: String -- The command to execute + , argumentsSetBreakpointsRequest :: SetBreakpointsRequestArguments -- Arguments for "setBreakpoints" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsRequest") } ''SetBreakpointsRequest) diff --git a/app/Phoityne/VSCode/TH/SetBreakpointsResponseBodyJSON.hs b/app/Phoityne/VSCode/TH/SetBreakpointsResponseBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetBreakpointsResponseBodyJSON.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.BreakpointJSON + +-- | +-- Response to "setBreakpoints" request. +-- Returned is information about each breakpoint created by this request. +-- This includes the actual code location and whether the breakpoint could be verified. +-- The breakpoints returned are in the same order as the elements of the 'breakpoints' +-- (or the deprecated 'lines') in the SetBreakpointsArguments. +-- +data SetBreakpointsResponseBody = + SetBreakpointsResponseBody { + breakpoints :: [Breakpoint] -- Information about the breakpoints. The array elements are in the same order as the elements of the 'breakpoints' (or the deprecated 'lines') in the SetBreakpointsArguments. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsResponseBody") } ''SetBreakpointsResponseBody) + +-- | +-- +defaultSetBreakpointsResponseBody :: SetBreakpointsResponseBody +defaultSetBreakpointsResponseBody = SetBreakpointsResponseBody [] + + + + diff --git a/app/Phoityne/VSCode/TH/SetBreakpointsResponseJSON.hs b/app/Phoityne/VSCode/TH/SetBreakpointsResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetBreakpointsResponseJSON.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetBreakpointsResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SetBreakpointsRequestJSON +import Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON + +-- | +-- Response to "setBreakpoints" request. +-- Returned is information about each breakpoint created by this request. +-- This includes the actual code location and whether the breakpoint could be verified. +-- The breakpoints returned are in the same order as the elements of the 'breakpoints' +-- (or the deprecated 'lines') in the SetBreakpointsArguments. +-- +data SetBreakpointsResponse = + SetBreakpointsResponse { + seqSetBreakpointsResponse :: Int -- Sequence number + , typeSetBreakpointsResponse :: String -- One of "request", "response", or "event" + , request_seqSetBreakpointsResponse :: Int -- Sequence number of the corresponding request + , successSetBreakpointsResponse :: Bool -- Outcome of the request + , commandSetBreakpointsResponse :: String -- The command requested + , messageSetBreakpointsResponse :: String -- Contains error message if success == false. + , bodySetBreakpointsResponse :: SetBreakpointsResponseBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetBreakpointsResponse") } ''SetBreakpointsResponse) + + +-- | +-- +defaultSetBreakpointsResponse :: Int -> SetBreakpointsRequest -> SetBreakpointsResponse +defaultSetBreakpointsResponse seq (SetBreakpointsRequest reqSeq _ _ _) = + SetBreakpointsResponse seq "response" reqSeq True "setBreakpoints" "" defaultSetBreakpointsResponseBody + + +-- | +-- +errorSetBreakpointsResponse :: Int -> SetBreakpointsRequest -> String -> SetBreakpointsResponse +errorSetBreakpointsResponse seq (SetBreakpointsRequest reqSeq _ _ _) msg = + SetBreakpointsResponse seq "response" reqSeq False "setBreakpoints" msg defaultSetBreakpointsResponseBody + diff --git a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestArgumentsJSON.hs b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestArgumentsJSON.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.FunctionBreakpointJSON + +-- | +-- Arguments for "setFunctionBreakpoints" request. +-- +data SetFunctionBreakpointsRequestArguments = + SetFunctionBreakpointsRequestArguments { + breakpointsSetFunctionBreakpointsRequestArguments :: [FunctionBreakpoint] -- The function names of the breakpoints. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetFunctionBreakpointsRequestArguments") } ''SetFunctionBreakpointsRequestArguments) + diff --git a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsRequestJSON.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON + +-- | +-- SetFunctionBreakpoints request; value of command field is "setFunctionBreakpoints". +-- Sets multiple function breakpoints and clears all previous function breakpoints. +-- To clear all function breakpoint, specify an empty array. +-- When a function breakpoint is hit, a StoppedEvent (event type 'function breakpoint') is generated. +-- +data SetFunctionBreakpointsRequest = + SetFunctionBreakpointsRequest { + seqSetFunctionBreakpointsRequest :: Int -- Sequence number + , typeSetFunctionBreakpointsRequest :: String -- One of "request", "response", or "event" + , commandSetFunctionBreakpointsRequest :: String -- The command to execute + , argumentsSetFunctionBreakpointsRequest :: SetFunctionBreakpointsRequestArguments -- Arguments for "setFunctionBreakpoints" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetFunctionBreakpointsRequest") } ''SetFunctionBreakpointsRequest) diff --git a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseBodyJSON.hs b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseBodyJSON.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.BreakpointJSON + +-- | +-- +-- +data SetFunctionBreakpointsResponseBody = + SetFunctionBreakpointsResponseBody { + breakpoints :: [Breakpoint] -- Information about the breakpoints. The array elements are in the same order as the elements of the 'breakpoints' (or the deprecated 'lines') in the SetFunctionBreakpointsArguments. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetFunctionBreakpointsResponseBody") } ''SetFunctionBreakpointsResponseBody) + +-- | +-- +defaultSetFunctionBreakpointsResponseBody :: SetFunctionBreakpointsResponseBody +defaultSetFunctionBreakpointsResponseBody = SetFunctionBreakpointsResponseBody [] + + + + diff --git a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetFunctionBreakpointsResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON +import Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON + +-- | +-- Response to "setFunctionBreakpoints" request. +-- +data SetFunctionBreakpointsResponse = + SetFunctionBreakpointsResponse { + seqSetFunctionBreakpointsResponse :: Int -- Sequence number + , typeSetFunctionBreakpointsResponse :: String -- One of "request", "response", or "event" + , request_seqSetFunctionBreakpointsResponse :: Int -- Sequence number of the corresponding request + , successSetFunctionBreakpointsResponse :: Bool -- Outcome of the request + , commandSetFunctionBreakpointsResponse :: String -- The command requested + , messageSetFunctionBreakpointsResponse :: String -- Contains error message if success == false. + , bodySetFunctionBreakpointsResponse :: SetFunctionBreakpointsResponseBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetFunctionBreakpointsResponse") } ''SetFunctionBreakpointsResponse) + + +-- | +-- +defaultSetFunctionBreakpointsResponse :: Int -> SetFunctionBreakpointsRequest -> SetFunctionBreakpointsResponse +defaultSetFunctionBreakpointsResponse seq (SetFunctionBreakpointsRequest reqSeq _ _ _) = + SetFunctionBreakpointsResponse seq "response" reqSeq True "setBreakpoints" "" defaultSetFunctionBreakpointsResponseBody + + +-- | +-- +errorSetFunctionBreakpointsResponse :: Int -> SetFunctionBreakpointsRequest -> String -> SetFunctionBreakpointsResponse +errorSetFunctionBreakpointsResponse seq (SetFunctionBreakpointsRequest reqSeq _ _ _) msg = + SetFunctionBreakpointsResponse seq "response" reqSeq False "setBreakpoints" msg defaultSetFunctionBreakpointsResponseBody + diff --git a/app/Phoityne/VSCode/TH/SourceArgumentsJSON.hs b/app/Phoityne/VSCode/TH/SourceArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SourceArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SourceArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "source" request. +-- +data SourceArguments = + SourceArguments { + sourceReferenceSourceArguments :: Int -- The reference to the source. This is the value received in Source.reference. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceArguments") } ''SourceArguments) diff --git a/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs b/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SourceBreakpointJSON.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Phoityne.VSCode.TH.SourceBreakpointJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Properties of a breakpoint passed to the setBreakpoints request. +-- +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. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceBreakpoint") } ''SourceBreakpoint) + + diff --git a/app/Phoityne/VSCode/TH/SourceJSON.hs b/app/Phoityne/VSCode/TH/SourceJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SourceJSON.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SourceJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- A Source is a descriptor for source code. It is returned from the debug adapter as part of a StackFrame and it is used by clients when specifying breakpoints. +-- +data Source = + Source { + nameSource :: Maybe String -- The short name of the source. Every source returned from the debug adapter has a name. When specifying a source to the debug adapter this name is optional. + , pathSource :: String -- The long (absolute) path of the source. It is not guaranteed that the source exists at this location. + , sourceReferenceSource :: Maybe Int -- If sourceReference > 0 the contents of the source can be retrieved through the SourceRequest. A sourceReference is only valid for a session, so it must not be used to persist a source. + , origineSource :: Maybe String -- The (optional) origin of this source: possible values "internal module", "inlined content from source map", etc. + -- , adapterDataSource :: Any -- Optional data that a debug adapter might want to loop through the client. The client should leave the data intact and persist it across sessions. The client should not interpret the data. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Source") } ''Source) diff --git a/app/Phoityne/VSCode/TH/SourceRequestJSON.hs b/app/Phoityne/VSCode/TH/SourceRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SourceRequestJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SourceRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SourceArgumentsJSON + +-- | +-- Source request; value of command field is "source". +-- The request retrieves the source code for a given source reference. +-- +data SourceRequest = + SourceRequest { + seqSourceRequest :: Int -- Sequence number + , typeSourceRequest :: String -- One of "request", "response", or "event" + , commandSourceRequest :: String -- The command to execute + , argumentsSourceRequest :: SourceArguments -- Arguments for "source" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceRequest") } ''SourceRequest) diff --git a/app/Phoityne/VSCode/TH/SourceResponseBodyJSON.hs b/app/Phoityne/VSCode/TH/SourceResponseBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SourceResponseBodyJSON.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SourceResponseBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + + +-- | +-- Response to "source" request. +-- +data SourceResponseBody = + SourceResponseBody { + contentSourceResponseBody :: String -- Content of the source reference + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceResponseBody") } ''SourceResponseBody) + + +-- | +-- +defaultSourceResponseBody :: SourceResponseBody +defaultSourceResponseBody = SourceResponseBody "" + + diff --git a/app/Phoityne/VSCode/TH/SourceResponseJSON.hs b/app/Phoityne/VSCode/TH/SourceResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SourceResponseJSON.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SourceResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SourceResponseBodyJSON +import Phoityne.VSCode.TH.SourceRequestJSON + +-- | +-- Response to "source" request. +-- +data SourceResponse = + SourceResponse { + seqSourceResponse :: Int -- Sequence number + , typeSourceResponse :: String -- One of "request", "response", or "event" + , request_seqSourceResponse :: Int -- Sequence number of the corresponding request + , successSourceResponse :: Bool -- Outcome of the request + , commandSourceResponse :: String -- The command requested + , messageSourceResponse :: String -- Contains error message if success == false. + , bodySourceResponse :: SourceResponseBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SourceResponse") } ''SourceResponse) + + + +-- | +-- +defaultSourceResponse :: Int -> SourceRequest -> SourceResponse +defaultSourceResponse seq (SourceRequest reqSeq _ _ _) = + SourceResponse seq "response" reqSeq True "source" "" defaultSourceResponseBody + + diff --git a/app/Phoityne/VSCode/TH/StackFrameJSON.hs b/app/Phoityne/VSCode/TH/StackFrameJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StackFrameJSON.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StackFrameJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SourceJSON + +-- | +-- A Stackframe contains the source location. +-- +data StackFrame = + StackFrame { + idStackFrame :: Int -- An identifier for the stack frame. This id can be used to retrieve the scopes of the frame with the 'scopesRequest'. + , nameStackFrame :: String -- The name of the stack frame, typically a method name. + , sourceStackFrame :: Source -- The optional source of the frame. + , lineStackFrame :: Int -- The line within the file of the frame. If source is null or doesn't exist, line is 0 and must be ignored. + , columnStackFrame :: Int -- The column within the line. If source is null or doesn't exist, column is 0 and must be ignored. + , endLineStackFrame :: Int -- An optional end line of the range covered by the stack frame. + , endColumnStackFrame :: Int -- An optional end column of the range covered by the stack frame. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackFrame") } ''StackFrame) diff --git a/app/Phoityne/VSCode/TH/StackTraceArgumentsJSON.hs b/app/Phoityne/VSCode/TH/StackTraceArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StackTraceArgumentsJSON.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StackTraceArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "stackTrace" request. +-- +data StackTraceArguments = + StackTraceArguments { + threadIdStackTraceArguments :: Int -- Retrieve the stacktrace for this thread. + , startFrameStackTraceArguments :: Maybe Int -- The index of the first frame to return; if omitted frames start at 0. + , levelsStackTraceArguments :: Int -- The maximum number of frames to return. If levels is not specified or 0, all frames are returned. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackTraceArguments") } ''StackTraceArguments) diff --git a/app/Phoityne/VSCode/TH/StackTraceBodyJSON.hs b/app/Phoityne/VSCode/TH/StackTraceBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StackTraceBodyJSON.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StackTraceBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.StackFrameJSON + +-- | +-- Body for "stackTrace" request. +-- +data StackTraceBody = + StackTraceBody { + stackFramesStackTraceBody :: [StackFrame] -- The frames of the stackframe. If the array has length zero, there are no stackframes available. This means that there is no location information available. + , totalFramesStackTraceBody :: Int -- The total number of frames available. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackTraceBody") } ''StackTraceBody) + + +-- | +-- +defaultStackTraceBody :: StackTraceBody +defaultStackTraceBody = StackTraceBody [] 0 + + diff --git a/app/Phoityne/VSCode/TH/StackTraceRequestJSON.hs b/app/Phoityne/VSCode/TH/StackTraceRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StackTraceRequestJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StackTraceRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.StackTraceArgumentsJSON + +-- | +-- StackTrace request; value of command field is "stackTrace". +-- The request returns a stacktrace from the current execution state. +-- +data StackTraceRequest = + StackTraceRequest { + seqStackTraceRequest :: Int -- Sequence number + , typeStackTraceRequest :: String -- One of "request", "response", or "event" + , commandStackTraceRequest :: String -- The command to execute + , argumentsStackTraceRequest :: StackTraceArguments -- Arguments for "stackTrace" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackTraceRequest") } ''StackTraceRequest) diff --git a/app/Phoityne/VSCode/TH/StackTraceResponseJSON.hs b/app/Phoityne/VSCode/TH/StackTraceResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StackTraceResponseJSON.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StackTraceResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.StackTraceBodyJSON +import Phoityne.VSCode.TH.StackTraceRequestJSON + +-- | +-- Response to "stackTrace" request. +-- +data StackTraceResponse = + StackTraceResponse { + seqStackTraceResponse :: Int -- Sequence number + , typeStackTraceResponse :: String -- One of "request", "response", or "event" + , request_seqStackTraceResponse :: Int -- Sequence number of the corresponding request + , successStackTraceResponse :: Bool -- Outcome of the request + , commandStackTraceResponse :: String -- The command requested + , messageStackTraceResponse :: String -- Contains error message if success == false. + , bodyStackTraceResponse :: StackTraceBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StackTraceResponse") } ''StackTraceResponse) + +-- | +-- +defaultStackTraceResponse :: Int -> StackTraceRequest -> StackTraceResponse +defaultStackTraceResponse seq (StackTraceRequest reqSeq _ _ _) = + StackTraceResponse seq "response" reqSeq True "stackTrace" "" defaultStackTraceBody + + +-- | +-- +errorStackTraceResponse :: Int -> StackTraceRequest -> String -> StackTraceResponse +errorStackTraceResponse seq (StackTraceRequest reqSeq _ _ _) msg = + StackTraceResponse seq "response" reqSeq False "stackTrace" msg defaultStackTraceBody + diff --git a/app/Phoityne/VSCode/TH/StepInArgumentsJSON.hs b/app/Phoityne/VSCode/TH/StepInArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StepInArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StepInArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "stepIn" request. +-- +data StepInArguments = + StepInArguments { + threadIdStepInArguments :: Int -- Continue execution for this thread. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepInArguments") } ''StepInArguments) diff --git a/app/Phoityne/VSCode/TH/StepInRequestJSON.hs b/app/Phoityne/VSCode/TH/StepInRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StepInRequestJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StepInRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.StepInArgumentsJSON + +-- | +-- StepIn request; value of command field is "stepIn". +-- The request starts the debuggee to run again for one step. +-- The debug adapter will respond with a StoppedEvent (event type 'step') after running the step. +-- +data StepInRequest = + StepInRequest { + seqStepInRequest :: Int -- Sequence number + , typeStepInRequest :: String -- One of "request", "response", or "event" + , commandStepInRequest :: String -- The command to execute + , argumentsStepInRequest :: StepInArguments -- Arguments for "stepIn" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepInRequest") } ''StepInRequest) diff --git a/app/Phoityne/VSCode/TH/StepInResponseJSON.hs b/app/Phoityne/VSCode/TH/StepInResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StepInResponseJSON.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StepInResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.StepInRequestJSON + +-- | +-- Response to "stepIn" request. This is just an acknowledgement, so no body field is required. +-- +data StepInResponse = + StepInResponse { + seqStepInResponse :: Int -- Sequence number + , typeStepInResponse :: String -- One of "request", "response", or "event" + , request_seqStepInResponse :: Int -- Sequence number of the corresponding request + , successStepInResponse :: Bool -- Outcome of the request + , commandStepInResponse :: String -- The command requested + , messageStepInResponse :: String -- Contains error message if success == false. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepInResponse") } ''StepInResponse) + +-- | +-- +defaultStepInResponse :: Int -> StepInRequest -> StepInResponse +defaultStepInResponse seq (StepInRequest reqSeq _ _ _) = + StepInResponse seq "response" reqSeq True "stepIn" "" + + +-- | +-- +errorStepInResponse :: Int -> StepInRequest -> String -> StepInResponse +errorStepInResponse seq (StepInRequest reqSeq _ _ _) msg = + StepInResponse seq "response" reqSeq False "stepIn" msg + diff --git a/app/Phoityne/VSCode/TH/StepOutArgumentsJSON.hs b/app/Phoityne/VSCode/TH/StepOutArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StepOutArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StepOutArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "stepOut" request. +-- +data StepOutArguments = + StepOutArguments { + threadIdStepOutArguments :: Int -- Continue execution for this thread. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepOutArguments") } ''StepOutArguments) diff --git a/app/Phoityne/VSCode/TH/StepOutRequestJSON.hs b/app/Phoityne/VSCode/TH/StepOutRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StepOutRequestJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StepOutRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.StepOutArgumentsJSON + +-- | +-- StepOutIn request; value of command field is "stepOut". +-- The request starts the debuggee to run again for one step. +-- penDebug will respond with a StoppedEvent (event type 'step') after running the step. +-- +data StepOutRequest = + StepOutRequest { + seqStepOutRequest :: Int -- Sequence number + , typeStepOutRequest :: String -- One of "request", "response", or "event" + , commandStepOutRequest :: String -- The command to execute + , argumentsStepOutRequest :: StepOutArguments -- Arguments for "stepOut" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepOutRequest") } ''StepOutRequest) diff --git a/app/Phoityne/VSCode/TH/StepOutResponseJSON.hs b/app/Phoityne/VSCode/TH/StepOutResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StepOutResponseJSON.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StepOutResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.StepOutRequestJSON + +-- | +-- Response to "stepOut" request. This is just an acknowledgement, so no body field is required. +-- +data StepOutResponse = + StepOutResponse { + seqStepOutResponse :: Int -- Sequence number + , typeStepOutResponse :: String -- One of "request", "response", or "event" + , request_seqStepOutResponse :: Int -- Sequence number of the corresponding request + , successStepOutResponse :: Bool -- Outcome of the request + , commandStepOutResponse :: String -- The command requested + , messageStepOutResponse :: String -- Contains error message if success == false. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StepOutResponse") } ''StepOutResponse) + + +-- | +-- +defaultStepOutResponse :: Int -> StepOutRequest -> StepOutResponse +defaultStepOutResponse seq (StepOutRequest reqSeq _ _ _) = + StepOutResponse seq "response" reqSeq True "stepOut" "" + + +-- | +-- +errorStepOutResponse :: Int -> StepOutRequest -> String -> StepOutResponse +errorStepOutResponse seq (StepOutRequest reqSeq _ _ _) msg = + StepOutResponse seq "response" reqSeq False "stepOut" msg + + diff --git a/app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs b/app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StoppedEventBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Event message for "stopped" event type. +-- The event indicates that the execution of the debuggee has stopped due to some condition. +-- This can be caused by a break point previously set, a stepping action has completed, by executing a debugger statement etc. +-- +data StoppedEventBody = + StoppedEventBody { + reasonStoppedEventBody :: String -- The reason for the event (such as: 'step', 'breakpoint', 'exception', 'pause'). This string is shown in the UI. + , threadIdStoppedEventBody :: Int -- The thread which was stopped. + , textStoppedEventBody :: String -- Additional information. E.g. if reason is 'exception', text contains the exception name. This string is shown in the UI. + + -- If allThreadsStopped is true, a debug adapter can announce that all threads have stopped. + -- The client should use this information to enable that all threads can be expanded to access their stacktraces. + -- If the attribute is missing or false, only the thread with the given threadId can be expanded. + , allThreadsStoppedStoppedEventBody :: Bool + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StoppedEventBody") } ''StoppedEventBody) + +defaultStoppedEventBody :: StoppedEventBody +defaultStoppedEventBody = StoppedEventBody "breakpoint" 0 "" False + diff --git a/app/Phoityne/VSCode/TH/StoppedEventJSON.hs b/app/Phoityne/VSCode/TH/StoppedEventJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/StoppedEventJSON.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.StoppedEventJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.StoppedEventBodyJSON + +-- | +-- Event message for "stopped" event type. +-- The event indicates that the execution of the debuggee has stopped due to some condition. +-- This can be caused by a break point previously set, a stepping action has completed, by executing a debugger statement etc. +-- +data StoppedEvent = + StoppedEvent { + seqStoppedEvent :: Int -- Sequence number + , typeStoppedEvent :: String -- One of "request", "response", or "event" + , eventStoppedEvent :: String -- Type of event + , bodyStoppedEvent :: StoppedEventBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "StoppedEvent") } ''StoppedEvent) + +defaultStoppedEvent :: Int -> StoppedEvent +defaultStoppedEvent seq = StoppedEvent seq "event" "stopped" defaultStoppedEventBody + diff --git a/app/Phoityne/VSCode/TH/TerminatedEventBodyJSON.hs b/app/Phoityne/VSCode/TH/TerminatedEventBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/TerminatedEventBodyJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.TerminatedEventBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Event message for "terminated" event types. +-- The event indicates that debugging of the debuggee has terminated. +-- +data TerminatedEventBody = + TerminatedEventBody { + restartTerminatedEventBody :: Bool -- A debug adapter may set 'restart' to true to request that the front end restarts the session. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "TerminatedEventBody") } ''TerminatedEventBody) + +defaultTerminatedEventBody :: TerminatedEventBody +defaultTerminatedEventBody = TerminatedEventBody False + diff --git a/app/Phoityne/VSCode/TH/TerminatedEventJSON.hs b/app/Phoityne/VSCode/TH/TerminatedEventJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/TerminatedEventJSON.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.TerminatedEventJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.TerminatedEventBodyJSON + +-- | +-- Event message for "terminated" event types. +-- The event indicates that debugging of the debuggee has terminated. +-- +data TerminatedEvent = + TerminatedEvent { + seqTerminatedEvent :: Int -- Sequence number + , typeTerminatedEvent :: String -- One of "request", "response", or "event" + , eventTerminatedEvent :: String -- Type of event + , bodyTerminatedEvent :: TerminatedEventBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "TerminatedEvent") } ''TerminatedEvent) + +defaultTerminatedEvent :: Int -> TerminatedEvent +defaultTerminatedEvent seq = TerminatedEvent seq "event" "terminated" defaultTerminatedEventBody + diff --git a/app/Phoityne/VSCode/TH/ThreadJSON.hs b/app/Phoityne/VSCode/TH/ThreadJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ThreadJSON.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ThreadJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- A Thread is a name/value pair. +-- If the value is structured (has children), a handle is provided to retrieve the children with the ThreadsRequest. +-- +data Thread = + Thread { + idThread :: Int -- Unique identifier for the thread. + , nameThread :: String -- A name of the thread. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Thread") } ''Thread) diff --git a/app/Phoityne/VSCode/TH/ThreadsRequestJSON.hs b/app/Phoityne/VSCode/TH/ThreadsRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ThreadsRequestJSON.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ThreadsRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Thread request; value of command field is "threads". +-- The request retrieves a list of all threads. +-- +data ThreadsRequest = + ThreadsRequest { + seqThreadsRequest :: Int -- Sequence number + , typeThreadsRequest :: String -- One of "request", "response", or "event" + , commandThreadsRequest :: String -- The command to execute + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ThreadsRequest") } ''ThreadsRequest) diff --git a/app/Phoityne/VSCode/TH/ThreadsResponseBodyJSON.hs b/app/Phoityne/VSCode/TH/ThreadsResponseBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ThreadsResponseBodyJSON.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ThreadsResponseBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ThreadJSON + +-- | +-- Response to "threads" request. +-- +data ThreadsResponseBody = + ThreadsResponseBody { + threadsThreadsResponseBody :: [Thread] -- All threads. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ThreadsResponseBody") } ''ThreadsResponseBody) + + +-- | +-- +defaultThreadsResponseBody :: ThreadsResponseBody +defaultThreadsResponseBody = ThreadsResponseBody [Thread 0 "ghci main thread"] + + diff --git a/app/Phoityne/VSCode/TH/ThreadsResponseJSON.hs b/app/Phoityne/VSCode/TH/ThreadsResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/ThreadsResponseJSON.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.ThreadsResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.ThreadsResponseBodyJSON +import Phoityne.VSCode.TH.ThreadsRequestJSON + +-- | +-- Response to "threads" request. +-- +data ThreadsResponse = + ThreadsResponse { + seqThreadsResponse :: Int -- Sequence number + , typeThreadsResponse :: String -- One of "request", "response", or "event" + , request_seqThreadsResponse :: Int -- Sequence number of the corresponding request + , successThreadsResponse :: Bool -- Outcome of the request + , commandThreadsResponse :: String -- The command requested + , messageThreadsResponse :: String -- Contains error message if success == false. + , bodyThreadsResponse :: ThreadsResponseBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "ThreadsResponse") } ''ThreadsResponse) + + + +-- | +-- +defaultThreadsResponse :: Int -> ThreadsRequest -> ThreadsResponse +defaultThreadsResponse seq (ThreadsRequest reqSeq _ _) = + ThreadsResponse seq "response" reqSeq True "threads" "" defaultThreadsResponseBody + + +-- | +-- +errorThreadsResponse :: Int -> ThreadsRequest -> String -> ThreadsResponse +errorThreadsResponse seq (ThreadsRequest reqSeq _ _) msg = + ThreadsResponse seq "response" reqSeq False "threads" msg defaultThreadsResponseBody + diff --git a/app/Phoityne/VSCode/TH/VariableJSON.hs b/app/Phoityne/VSCode/TH/VariableJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/VariableJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.VariableJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- A Variable is a name/value pair. +-- If the value is structured (has children), a handle is provided to retrieve the children with the VariablesRequest. +-- +data Variable = + Variable { + nameVariable :: String -- The variable's name + , typeVariable :: String -- he variable's type. + , valueVariable :: String -- The variable's value. For structured objects this can be a multi line text, e.g. for a function the body of a function. + , variablesReferenceVariable :: Int -- If variablesReference is > 0, the variable is structured and its children can be retrieved by passing variablesReference to the VariablesRequest. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "Variable") } ''Variable) diff --git a/app/Phoityne/VSCode/TH/VariablesArgumentsJSON.hs b/app/Phoityne/VSCode/TH/VariablesArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/VariablesArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.VariablesArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for "variables" request. +-- +data VariablesArguments = + VariablesArguments { + variablesReferenceVariablesArguments :: Int -- The Variable reference. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablesArguments") } ''VariablesArguments) diff --git a/app/Phoityne/VSCode/TH/VariablesBodyJSON.hs b/app/Phoityne/VSCode/TH/VariablesBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/VariablesBodyJSON.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.VariablesBodyJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.VariableJSON + +-- | +-- Response to "variables" request. +-- +data VariablesBody = + VariablesBody { + variablesVariablesBody :: [Variable] -- All children for the given variable reference. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablesBody") } ''VariablesBody) + +-- | +-- +defaultVariablesBody :: VariablesBody +defaultVariablesBody = VariablesBody [] + diff --git a/app/Phoityne/VSCode/TH/VariablesRequestJSON.hs b/app/Phoityne/VSCode/TH/VariablesRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/VariablesRequestJSON.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.VariablesRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.VariablesArgumentsJSON + +-- | +-- Variables request; value of command field is "variables". +-- Retrieves all children for the given variable reference. +-- +data VariablesRequest = + VariablesRequest { + seqVariablesRequest :: Int -- Sequence number + , typeVariablesRequest :: String -- One of "request", "response", or "event" + , commandVariablesRequest :: String -- The command to execute + , argumentsVariablesRequest :: VariablesArguments -- Arguments for "variables" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablesRequest") } ''VariablesRequest) diff --git a/app/Phoityne/VSCode/TH/VariablesResponseJSON.hs b/app/Phoityne/VSCode/TH/VariablesResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/VariablesResponseJSON.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.VariablesResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.VariablesBodyJSON +import Phoityne.VSCode.TH.VariablesRequestJSON + +-- | +-- Response to "variables" request. +-- +data VariablesResponse = + VariablesResponse { + seqVariablesResponse :: Int -- Sequence number + , typeVariablesResponse :: String -- One of "request", "response", or "event" + , request_seqVariablesResponse :: Int -- Sequence number of the corresponding request + , successVariablesResponse :: Bool -- Outcome of the request + , commandVariablesResponse :: String -- The command requested + , messageVariablesResponse :: String -- Contains error message if success == false. + , bodyVariablesResponse :: VariablesBody + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "VariablesResponse") } ''VariablesResponse) + + + +-- | +-- +defaultVariablesResponse :: Int -> VariablesRequest -> VariablesResponse +defaultVariablesResponse seq (VariablesRequest reqSeq _ _ _) = + VariablesResponse seq "response" reqSeq True "variables" "" defaultVariablesBody + +-- | +-- +errorVariablesResponse :: Int -> VariablesRequest -> String -> VariablesResponse +errorVariablesResponse seq (VariablesRequest reqSeq _ _ _) msg = + VariablesResponse seq "response" reqSeq False "variables" msg defaultVariablesBody + + diff --git a/app/Phoityne/VSCode/Utility.hs b/app/Phoityne/VSCode/Utility.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/Utility.hs @@ -0,0 +1,74 @@ + +module Phoityne.VSCode.Utility where + +-- システム +import Data.Either.Utils +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as L +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import qualified Data.ConfigFile as CFG +import qualified Data.Tree as TR + + +-- | +-- UTF8文字列をByteStringへの変換 +-- +str2bs :: String -> BS.ByteString +str2bs = TE.encodeUtf8 . T.pack + +-- | +-- ByteStringをUTF8文字列への変換 +-- +bs2str :: BS.ByteString -> String +bs2str = T.unpack. TE.decodeUtf8 + +-- | +-- UTF8文字列をLazyByteStringへの変換 +-- +str2lbs :: String -> LBS.ByteString +str2lbs = TLE.encodeUtf8 . TL.pack + +-- | +-- LazyByteStringをUTF8文字列への変換 +-- +lbs2str :: LBS.ByteString -> String +lbs2str = TL.unpack. TLE.decodeUtf8 + +-- | +-- INI設定の指定したセクションに含まれる +-- すべて設定項目を返す。 +-- +getIniItems :: CFG.ConfigParser + -> CFG.SectionSpec + -> [(CFG.OptionSpec, String)] +getIniItems cp sec = foldr go [] opts + where + opts = forceEither $ CFG.options cp sec + go opt acc = let value = forceEither $ CFG.get cp sec opt in + (opt, value) : acc + + +-- | +-- +-- +addChildTree :: TR.Tree a -> TR.Tree a -> TR.Tree a +addChildTree parent child = parent { TR.subForest = child : curForest} + where curForest = TR.subForest parent + + +-- | +-- +-- +pushWithLimit :: (Eq a, Ord a) => [a] -> a -> Int -> [a] +pushWithLimit [] item _ = [item] +pushWithLimit buf item maxSize = if length buf > maxSize then item : L.init buf else item : buf + +-- | +-- +rdrop :: Eq a => Int -> [a] -> [a] +rdrop cnt = reverse . drop cnt . reverse + diff --git a/phoityne-vscode.cabal b/phoityne-vscode.cabal --- a/phoityne-vscode.cabal +++ b/phoityne-vscode.cabal @@ -1,5 +1,5 @@ name: phoityne-vscode -version: 0.0.7.0 +version: 0.0.8.0 synopsis: ghci debug viewer on Visual Studio Code description: Please see README.md license: BSD3 @@ -19,87 +19,94 @@ hs-source-dirs: app main-is: Main.hs other-modules: Paths_phoityne_vscode - , Phoityne.Argument - , Phoityne.Constant - , Phoityne.Utility - , Phoityne.IO.Control - , Phoityne.IO.Main - , Phoityne.IO.Utility - , Phoityne.IO.CUI.GHCiControl - , Phoityne.IO.GUI.Control - , Phoityne.IO.GUI.VSCode.TH.BreakpointJSON - , Phoityne.IO.GUI.VSCode.TH.ContinueArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.ContinueRequestJSON - , Phoityne.IO.GUI.VSCode.TH.ContinueResponseJSON - , Phoityne.IO.GUI.VSCode.TH.DisconnectArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.DisconnectRequestJSON - , Phoityne.IO.GUI.VSCode.TH.DisconnectResponseJSON - , Phoityne.IO.GUI.VSCode.TH.ErrorResponseBodyJSON - , Phoityne.IO.GUI.VSCode.TH.ErrorResponseJSON - , Phoityne.IO.GUI.VSCode.TH.EvaluateArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.EvaluateBodyJSON - , Phoityne.IO.GUI.VSCode.TH.EvaluateRequestJSON - , Phoityne.IO.GUI.VSCode.TH.EvaluateResponseJSON - , Phoityne.IO.GUI.VSCode.TH.ExceptionBreakpointsFilterJSON - , Phoityne.IO.GUI.VSCode.TH.ExitedEventBodyJSON - , Phoityne.IO.GUI.VSCode.TH.ExitedEventJSON - , Phoityne.IO.GUI.VSCode.TH.InitializedEventJSON - , Phoityne.IO.GUI.VSCode.TH.InitializeRequestArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.InitializeRequestJSON - , Phoityne.IO.GUI.VSCode.TH.InitializeResponseCapabilitesJSON - , Phoityne.IO.GUI.VSCode.TH.InitializeResponseJSON - , Phoityne.IO.GUI.VSCode.TH.LaunchRequestArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.LaunchRequestJSON - , Phoityne.IO.GUI.VSCode.TH.LaunchResponseJSON - , Phoityne.IO.GUI.VSCode.TH.MessageJSON - , Phoityne.IO.GUI.VSCode.TH.NextArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.NextRequestJSON - , Phoityne.IO.GUI.VSCode.TH.NextResponseJSON - , Phoityne.IO.GUI.VSCode.TH.OutputEventJSON - , Phoityne.IO.GUI.VSCode.TH.OutputEventBodyJSON - , Phoityne.IO.GUI.VSCode.TH.PauseArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.PauseRequestJSON - , Phoityne.IO.GUI.VSCode.TH.PauseResponseJSON - , Phoityne.IO.GUI.VSCode.TH.RequestJSON - , Phoityne.IO.GUI.VSCode.TH.ScopeJSON - , Phoityne.IO.GUI.VSCode.TH.ScopesArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.ScopesBodyJSON - , Phoityne.IO.GUI.VSCode.TH.ScopesRequestJSON - , Phoityne.IO.GUI.VSCode.TH.ScopesResponseJSON - , Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestJSON - , Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseBodyJSON - , Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseJSON - , Phoityne.IO.GUI.VSCode.TH.SourceArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.SourceBreakpointJSON - , Phoityne.IO.GUI.VSCode.TH.SourceJSON - , Phoityne.IO.GUI.VSCode.TH.SourceRequestJSON - , Phoityne.IO.GUI.VSCode.TH.SourceResponseBodyJSON - , Phoityne.IO.GUI.VSCode.TH.SourceResponseJSON - , Phoityne.IO.GUI.VSCode.TH.StackFrameJSON - , Phoityne.IO.GUI.VSCode.TH.StackTraceArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.StackTraceBodyJSON - , Phoityne.IO.GUI.VSCode.TH.StackTraceRequestJSON - , Phoityne.IO.GUI.VSCode.TH.StackTraceResponseJSON - , Phoityne.IO.GUI.VSCode.TH.StepInArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.StepInRequestJSON - , Phoityne.IO.GUI.VSCode.TH.StepInResponseJSON - , Phoityne.IO.GUI.VSCode.TH.StepOutArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.StepOutRequestJSON - , Phoityne.IO.GUI.VSCode.TH.StepOutResponseJSON - , Phoityne.IO.GUI.VSCode.TH.StoppedEventBodyJSON - , Phoityne.IO.GUI.VSCode.TH.StoppedEventJSON - , Phoityne.IO.GUI.VSCode.TH.TerminatedEventBodyJSON - , Phoityne.IO.GUI.VSCode.TH.TerminatedEventJSON - , Phoityne.IO.GUI.VSCode.TH.ThreadJSON - , Phoityne.IO.GUI.VSCode.TH.ThreadsRequestJSON - , Phoityne.IO.GUI.VSCode.TH.ThreadsResponseBodyJSON - , Phoityne.IO.GUI.VSCode.TH.ThreadsResponseJSON - , Phoityne.IO.GUI.VSCode.TH.VariableJSON - , Phoityne.IO.GUI.VSCode.TH.VariablesArgumentsJSON - , Phoityne.IO.GUI.VSCode.TH.VariablesBodyJSON - , Phoityne.IO.GUI.VSCode.TH.VariablesRequestJSON - , Phoityne.IO.GUI.VSCode.TH.VariablesResponseJSON + , Phoityne.VSCode.Argument + , Phoityne.VSCode.IO.Control + , Phoityne.VSCode.IO.Main + , Phoityne.VSCode.IO.Core + , Phoityne.VSCode.Constant + , Phoityne.VSCode.Utility + , Phoityne.VSCode.IO.Utility + , Phoityne.VSCode.TH.BreakpointJSON + , Phoityne.VSCode.TH.ContinueArgumentsJSON + , Phoityne.VSCode.TH.ContinueRequestJSON + , Phoityne.VSCode.TH.ContinueResponseJSON + , Phoityne.VSCode.TH.DisconnectArgumentsJSON + , Phoityne.VSCode.TH.DisconnectRequestJSON + , Phoityne.VSCode.TH.DisconnectResponseJSON + , Phoityne.VSCode.TH.ErrorResponseBodyJSON + , Phoityne.VSCode.TH.ErrorResponseJSON + , Phoityne.VSCode.TH.EvaluateArgumentsJSON + , Phoityne.VSCode.TH.EvaluateBodyJSON + , Phoityne.VSCode.TH.EvaluateRequestJSON + , Phoityne.VSCode.TH.EvaluateResponseJSON + , Phoityne.VSCode.TH.ExceptionBreakpointsFilterJSON + , Phoityne.VSCode.TH.ExitedEventBodyJSON + , Phoityne.VSCode.TH.ExitedEventJSON + , Phoityne.VSCode.TH.FunctionBreakpointJSON + , Phoityne.VSCode.TH.InitializedEventJSON + , Phoityne.VSCode.TH.InitializeRequestArgumentsJSON + , Phoityne.VSCode.TH.InitializeRequestJSON + , Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON + , Phoityne.VSCode.TH.InitializeResponseJSON + , Phoityne.VSCode.TH.LaunchRequestArgumentsJSON + , Phoityne.VSCode.TH.LaunchRequestJSON + , Phoityne.VSCode.TH.LaunchResponseJSON + , Phoityne.VSCode.TH.MessageJSON + , Phoityne.VSCode.TH.NextArgumentsJSON + , Phoityne.VSCode.TH.NextRequestJSON + , Phoityne.VSCode.TH.NextResponseJSON + , Phoityne.VSCode.TH.OutputEventJSON + , Phoityne.VSCode.TH.OutputEventBodyJSON + , Phoityne.VSCode.TH.PauseArgumentsJSON + , Phoityne.VSCode.TH.PauseRequestJSON + , Phoityne.VSCode.TH.PauseResponseJSON + , Phoityne.VSCode.TH.RequestJSON + , Phoityne.VSCode.TH.ScopeJSON + , Phoityne.VSCode.TH.ScopesArgumentsJSON + , Phoityne.VSCode.TH.ScopesBodyJSON + , Phoityne.VSCode.TH.ScopesRequestJSON + , Phoityne.VSCode.TH.ScopesResponseJSON + , Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON + , Phoityne.VSCode.TH.SetBreakpointsRequestJSON + , Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON + , Phoityne.VSCode.TH.SetBreakpointsResponseJSON + , Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON + , Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON + , Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON + , Phoityne.VSCode.TH.SetFunctionBreakpointsResponseJSON + , Phoityne.VSCode.TH.SourceArgumentsJSON + , Phoityne.VSCode.TH.SourceBreakpointJSON + , Phoityne.VSCode.TH.SourceJSON + , Phoityne.VSCode.TH.SourceRequestJSON + , Phoityne.VSCode.TH.SourceResponseBodyJSON + , Phoityne.VSCode.TH.SourceResponseJSON + , Phoityne.VSCode.TH.StackFrameJSON + , Phoityne.VSCode.TH.StackTraceArgumentsJSON + , Phoityne.VSCode.TH.StackTraceBodyJSON + , Phoityne.VSCode.TH.StackTraceRequestJSON + , Phoityne.VSCode.TH.StackTraceResponseJSON + , Phoityne.VSCode.TH.StepInArgumentsJSON + , Phoityne.VSCode.TH.StepInRequestJSON + , Phoityne.VSCode.TH.StepInResponseJSON + , Phoityne.VSCode.TH.StepOutArgumentsJSON + , Phoityne.VSCode.TH.StepOutRequestJSON + , Phoityne.VSCode.TH.StepOutResponseJSON + , Phoityne.VSCode.TH.StoppedEventBodyJSON + , Phoityne.VSCode.TH.StoppedEventJSON + , Phoityne.VSCode.TH.TerminatedEventBodyJSON + , Phoityne.VSCode.TH.TerminatedEventJSON + , Phoityne.VSCode.TH.ThreadJSON + , Phoityne.VSCode.TH.ThreadsRequestJSON + , Phoityne.VSCode.TH.ThreadsResponseBodyJSON + , Phoityne.VSCode.TH.ThreadsResponseJSON + , Phoityne.VSCode.TH.VariableJSON + , Phoityne.VSCode.TH.VariablesArgumentsJSON + , Phoityne.VSCode.TH.VariablesBodyJSON + , Phoityne.VSCode.TH.VariablesRequestJSON + , Phoityne.VSCode.TH.VariablesResponseJSON + , Phoityne.GHCi + , Phoityne.GHCi.IO.Command + , Phoityne.GHCi.IO.Process build-depends: base >= 4.7 && < 5 , directory , Cabal @@ -125,15 +132,4 @@ , split , fsnotify default-language: Haskell2010 - -test-suite phoityne-vscode-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - build-depends: base - , aeson - , hspec - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 - diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-}