diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,6 @@ + +20160504 phoityne-vscode-0.0.1.0 + + * [Info] Initial release. + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ + + +# Phoityne VSCode + +Phoityne is a ghci debug viewer for Visual Studio Code. (on Windows) + + +## Debug on VSCode + +1. Start VSCode +2. Open stack project folder +3. Open debug view +4. Open launch.json +5. Set startup source file. Default file is test/Spec.hs +6. Run debug(F5) + +![Document](https://sites.google.com/site/phoityne/doc_jp/demo01.gif?attredirects=0) + + +## Install + + +### Run stack install + + % stack new project + . . . . . + % + % cd project + % stack install phoityne-vscode + . . . . . + % + + +### Prepare vscode extensions + +1. create folder "%USERPROFILE%\.vscode\extensions\phoityne-vscode" +2. copy "phoityne-vscode-0.0.1.0\vscode\package.json"(*) to "%USERPROFILE%\.vscode\extensions\phoityne-vscode" +3. copy "%USERPROFILE%\AppData\Roaming\local\bin\phoityne-vscode.exe" to "%USERPROFILE%\.vscode\extensions\phoityne-vscode" + +(*) download by stack unpack. + + % stack unpack phoityne-vscode + % + + +## Important + +* need c:\temp folder. phoityne.log file will be created. +* breakpoint can be set in a .hs file which defineds "module ... where". +* source file extension must be ".hs" + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +-- モジュール +import qualified Phoityne.IO.Main as M + +-- システム +import System.Exit + +-- | +-- メイン +-- +main :: IO () +main = do + M.run >>= \case + 0 -> exitSuccess + c -> exitWith . ExitFailure $ c + diff --git a/app/Phoityne/Argument.hs b/app/Phoityne/Argument.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/Argument.hs @@ -0,0 +1,121 @@ +{-# 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 + +-- | +-- ヘルプ表示時の例外 +-- +data HelpExitException = HelpExitException + deriving (Show, Typeable) + +instance E.Exception HelpExitException + +-- | +-- コマンドライン引数データ設定 +-- モードを使用する場合のサンプル +-- +data ArgData = ModeA + { + file :: String + , method :: Method + } + | ModeB + { + file :: String + , value :: Int + } deriving (Data, Typeable, Show, Read, Eq) + +-- | +-- アノテーション設定 +-- +config :: ArgData +config = modes [confA, confB] + &= summary sumMsg + &= program "prj-tpl" + + where + confA = ModeA { + file = def + &= name "f" + &= name "file" + &= explicit + &= typFile + &= help "ini file" + , method = enum + [ + Get + &= name "get" + &= explicit + &= help "method type Get" + , Post + &= name "post" + &= explicit + &= help " | type Post" + , Put + &= name "put" + &= explicit + &= help " | type Put" + , Delete + &= name "delete" + &= explicit + &= help " | type Delete" + ] + } &= name "ModeA" + &= details mdAMsg + &= auto + confB = ModeB { + file = def + &= name "f" + &= name "file" + &= explicit + &= typFile + &= help "ini file" + , value = def + &= name "value" + &= explicit + &= help "integer value" + } &= name "ModeB" + &= details mdBMsg + + sumMsg = unlines [ + "" + , " ☆ サマリ説明 ☆" + , "" + , " ここに簡単な説明を記載する。" + , "" + ] + + mdAMsg = [ + "" + , " ★ 詳細説明 ★" + , "" + , " ここにModeAの詳細な説明を記載する。" + , "" + ] + + mdBMsg = [ + "" + , " ★ 詳細説明 ★" + , "" + , " ここにModeBの詳細な説明を記載する。" + , "" + ] + +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/Constant.hs @@ -0,0 +1,74 @@ + +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/IO/CUI/GHCiControl.hs b/app/Phoityne/IO/CUI/GHCiControl.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/CUI/GHCiControl.hs @@ -0,0 +1,149 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/Control.hs @@ -0,0 +1,175 @@ +{-# 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.Info +import System.Log.Logger +import System.Exit +import Distribution.System +import Control.Concurrent +import Data.String.Utils +import qualified Data.ConfigFile as C + +-- | +-- ロジックメイン +-- +run :: A.ArgData -- コマンドライン引数 + -> C.ConfigParser -- INI設定 + -> IO Int -- exit code +run _ _ = do + + infoM _LOG_NAME $ "OS:" ++ os + infoM _LOG_NAME $ "ARCH:" ++ arch + infoM _LOG_NAME $ "BuildOS:" ++ show buildOS + + mvarCUI <- newMVar GHCI.defaultExternalCommandData + + let cmdData = createCmdData mvarCUI + + GUI.run cmdData + + return 1 + + + where + createCmdData mvarCUI = + GUI.DebugCommandData { + GUI.startDebugCommandData = debugStart mvarCUI + , GUI.stopDebugCommandData = stopDebug mvarCUI + , GUI.readDebugCommandData = readResult mvarCUI + , GUI.readLinesDebugCommandData = readLines mvarCUI + , GUI.promptDebugCommandData = execCmd mvarCUI $ ":set prompt \"" ++ _PHOITYNE_GHCI_PROMPT ++ "\"" + , 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 + } + + +-- | +-- +-- +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 -> FilePath -> IO () +debugStart mvarCUI cwd = do + exeData <- GHCI.run "stack" ["ghci", "--test", "--no-build", "--no-load"] $ 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 GHCI.ExternalCommandData -> IO String +readResult mvarCUI = readWhile mvarCUI $ not . endswith _PHOITYNE_GHCI_PROMPT + + +-- | +-- +-- +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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/Control.hs @@ -0,0 +1,1352 @@ +{-# 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 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.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.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 + + + +-- | +-- +-- +data DebugContext = + DebugContext { + resSeqDebugContext :: Int + , breakPointDatasDebugContext :: BreakPointDatas + , workspaceDebugContext :: FilePath + , startupDebugContext :: FilePath + , debugStartedDebugContext :: Bool + , debugStoppedPosDebugContext :: Maybe HighlightTextRangeData + , currentFrameIdDebugContext :: Int + } deriving (Show, Read, Eq, Ord) + + + +-- | +-- +-- +data DebugCommandData = + DebugCommandData { + startDebugCommandData :: 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 + } + +-- | +-- +-- +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 = '/' + + +-- | +-- +-- +defaultDebugContext :: DebugContext +defaultDebugContext = DebugContext _INITIAL_RESPONSE_SEQUENCE (MAP.fromList []) "" "" False Nothing 0 + + +-- | +-- +-- +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 ctx = 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 + infoM _LOG_NAME $ "[REQUEST] Content-Length: " ++ show len + cnt <- BSL.hGet stdin len + infoM _LOG_NAME $ "[REQUEST] " ++ lbs2str cnt + handleRequest cmdData ctx 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 -> IO () +handleRequest cmdData mvarCtx jsonStr = case J.eitherDecode jsonStr :: Either String J.Request of + Left err -> errRes jsonStr $ "requet parse error. [" ++ err ++ "]" + Right jsonDat -> sucRes jsonStr jsonDat + + where + errRes :: BSL.ByteString -> String -> IO () + errRes jsonStr msg = do + errorM _LOG_NAME $ msg ++ " [" ++ lbs2str jsonStr ++ "]" + wait cmdData mvarCtx + + sucRes jsonStr (J.Request cmd) = do + handle jsonStr cmd + wait cmdData mvarCtx + + handle jsonStr "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of + Left err -> errRes jsonStr $ "initialize parse error. [" ++ err ++ "]" + Right req -> initializeHandler mvarCtx req + + + handle jsonStr "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of + Left err -> errRes jsonStr $ "launch parse error. [" ++ err ++ "]" + Right req -> launchHandler cmdData mvarCtx req + + + handle jsonStr "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of + Left err -> errRes jsonStr $ "disconnect parse error. [" ++ err ++ "]" + Right req -> disconnectHandler cmdData mvarCtx req + + + handle jsonStr "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of + Left err -> errRes jsonStr $ "setBreakpoints parse error. [" ++ err ++ "]" + Right req -> setBreakpointsHandler cmdData mvarCtx req + + + handle jsonStr "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of + Left err -> errRes jsonStr $ "continue parse error. [" ++ err ++ "]" + Right req -> continueHandler cmdData mvarCtx req + + + handle jsonStr "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of + Left err -> errRes jsonStr $ "next parse error. [" ++ err ++ "]" + Right req -> stepOverHandler cmdData mvarCtx req + + + handle jsonStr "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of + Left err -> errRes jsonStr $ "stepIn parse error. [" ++ err ++ "]" + Right req -> stepInHandler cmdData mvarCtx req + + + handle jsonStr "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of + Left err -> errRes jsonStr $ "stepOut parse error. [" ++ err ++ "]" + 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." + + + handle jsonStr "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of + Left err -> errRes jsonStr $ "pause parse error. [" ++ err ++ "]" + 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." + + + handle jsonStr "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of + Left err -> errRes jsonStr $ "stackTrace parse error. [" ++ err ++ "]" + Right req -> stackTraceHandler cmdData mvarCtx req + + + handle jsonStr "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of + Left err -> errRes jsonStr $ "scopes parse error. [" ++ err ++ "]" + Right req -> scopesHandler cmdData mvarCtx req + + + + handle jsonStr "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of + Left err -> errRes jsonStr $ "variables parse error. [" ++ err ++ "]" + Right req -> variablesHandler cmdData mvarCtx req + + + handle jsonStr "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of + Left err -> errRes jsonStr $ "source parse error. [" ++ err ++ "]" + 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." + + + handle jsonStr "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of + Left err -> errRes jsonStr $ "threads parse error. [" ++ err ++ "]" + Right req -> threadsHandler cmdData mvarCtx req + + + handle jsonStr "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of + Left err -> errRes jsonStr $ "evaluate parse error. [" ++ err ++ "]" + Right req -> evaluateHandler cmdData mvarCtx req + + + handle jsonStr cmd = do + putStrLnStderr mvarCtx $ cmd ++ " command is not supported." + putStrLnStderr mvarCtx $ lbs2str jsonStr ++ " is requested." + + +-- | +-- +sendEvent :: BSL.ByteString -> IO () +sendEvent str = do + infoM _LOG_NAME $ "[EVENT] Content-Length: " ++ show (BSL.length str) + infoM _LOG_NAME $ "[EVENT] " ++ lbs2str str + + sendResponseInternal str + +-- | +-- +sendResponse :: BSL.ByteString -> IO () +sendResponse str = do + infoM _LOG_NAME $ "[RESPONSE] Content-Length: " ++ show (BSL.length str) + infoM _LOG_NAME $ "[RESPONSE] " ++ lbs2str 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 (J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do + resSeq <- incResSeq mvarCtx + let capa = J.InitializeResponseCapabilites False False True 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 = "initializeHandler:" ++ show e + errorM _LOG_NAME 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 + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx { + workspaceDebugContext = ws + , startupDebugContext = su + } + + runGHCi cmdData mvarCtx ws + + loadHsFile cmdData mvarCtx su + + resSeq <- incResSeq mvarCtx + sendResponse $ J.encode $ J.defaultLaunchResponse resSeq req + + resSeq <- incResSeq mvarCtx + sendEvent $ J.encode $ J.defaultInitializedEvent resSeq + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "launchHandler:" ++ show e + errorM _LOG_NAME msg + + +-- | +-- +disconnectHandler :: DebugCommandData -> MVar DebugContext -> J.DisconnectRequest -> IO () +disconnectHandler cmdData mvarCtx req = flip E.catches handlers $ do + + let exitCmd = stopDebugCommandData cmdData + quitCmd = quitDebugCommandData cmdData + readWhile = readWhileDebugCommandData cmdData + + 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 + sendResponse $ J.encode $ J.defaultDisconnectResponse resSeq req + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "disconnectHandler:" ++ show e + errorM _LOG_NAME msg + putStrLnStderr mvarCtx msg + +-- | +-- +setBreakpointsHandler :: DebugCommandData -> MVar DebugContext -> J.SetBreakpointsRequest -> IO () +setBreakpointsHandler cmdData mvarCtx req = flip E.catches handlers $ do + + 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} + sendResponse resStr + + resSeq <- incResSeq mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent stopEvtStr + + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "setBreakpointsHandler:" ++ show e + errorM _LOG_NAME 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 -> 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 + resSeq <- incResSeq mvarCtx + let resStr = J.encode $ J.defaultThreadsResponse resSeq req + sendResponse resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "threadsHandler:" ++ show e + errorM _LOG_NAME msg + +-- | +-- +-- +scopesHandler :: DebugCommandData -> MVar DebugContext -> J.ScopesRequest -> IO () +scopesHandler cmdData mvarCtx req = flip E.catches handlers $ do + + let args = J.argumentsScopesRequest req + traceId = J.frameIdScopesArguments args + + moveFrame cmdData mvarCtx traceId + + resSeq <- incResSeq mvarCtx + let resStr = J.encode $ J.defaultScopesResponse resSeq req + sendResponse resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "scopesHandler:" ++ show e + errorM _LOG_NAME msg + + +-- | +-- +-- +moveFrame :: DebugCommandData -> MVar DebugContext -> Int -> IO () +moveFrame cmdData mvarCtx traceId = do + ctx <- readMVar mvarCtx + let curTraceId = currentFrameIdDebugContext ctx + moveCount = curTraceId - traceId + traceCmd = if 0 > moveCount then traceForwardDebugCommandData cmdData + else traceBackDebugCommandData cmdData + getResult = readDebugCommandData cmdData + + _ <- foldM (go traceCmd getResult) (""::String) [1..(abs moveCount)] + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{currentFrameIdDebugContext = traceId} + + where + go traceCmd getResult _ _ = do + + cmdStr <- traceCmd + infoM _LOG_NAME cmdStr + putStrLnStdout mvarCtx cmdStr + + cmdStr <- getResult + infoM _LOG_NAME cmdStr + putStrStdout mvarCtx cmdStr + + return cmdStr + +-- | +-- +-- +variablesHandler :: DebugCommandData -> MVar DebugContext -> J.VariablesRequest -> IO () +variablesHandler cmdData mvarCtx req = flip E.catches handlers $ do + + vals <- currentBindings + + resSeq <- incResSeq mvarCtx + let res = J.defaultVariablesResponse resSeq req + resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals} + sendResponse resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "scopesHandler:" ++ show e + errorM _LOG_NAME msg + + currentBindings = do + let bindings = bindingsDebugCommandData cmdData + getResult = readDebugCommandData cmdData + + cmdStr <- bindings + infoM _LOG_NAME cmdStr + -- putStrLnStdout mvarCtx cmdStr + + bindStr <- getResult + infoM _LOG_NAME bindStr + -- putStrStdout mvarCtx bindStr + + case getBindingDataList bindStr of + Left err -> do + errorM _LOG_NAME $ show err + putStrLnStderr mvarCtx $ show err + return [] + + Right dats -> return $ map convBind2Vals dats + + convBind2Vals (BindingData varName _ val) = J.Variable varName val 0 + + +-- | +-- +-- +stackTraceHandler :: DebugCommandData -> MVar DebugContext -> J.StackTraceRequest -> IO () +stackTraceHandler cmdData mvarCtx req = flip E.catches handlers $ do + 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} + sendResponse 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} + sendResponse resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "stackTraceHandler:" ++ show e + errorM _LOG_NAME msg + + + createStackFrames (HighlightTextRangeData file sl sc _ _) = do + ctx <- readMVar mvarCtx + let cwd = workspaceDebugContext ctx + csf = J.StackFrame 0 "0" (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc + + let getResult = readDebugCommandData cmdData + history = traceHistDebugCommandData cmdData + + cmdStr <- history + infoM _LOG_NAME cmdStr + -- putStrLnStdout mvarCtx cmdStr + + traceStr <- getResult + infoM _LOG_NAME traceStr + -- putStrStdout mvarCtx traceStr + + case getTraceDataList traceStr of + Left err -> do + errorM _LOG_NAME $ show err + -- putStrLnStderr mvarCtx $ show err + return [csf] + + Right dats -> foldM (convTrace2Frame cwd) [csf] dats + + convTrace2Frame cwd xs (TraceData traceId _ filePath) = case parse parseHighlightTextRange "getActivatePosFromLine" filePath of + Left err -> do + infoM _LOG_NAME $ show err + return xs + Right (HighlightTextRangeData file sl sc _ _) -> return $ + J.StackFrame (read traceId) traceId (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc : xs + +-- | +-- +-- +evaluateHandler :: DebugCommandData -> MVar DebugContext -> J.EvaluateRequest -> IO () +evaluateHandler cmdData mvarCtx req = flip E.catches handlers $ do + + 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 = "continueHandler:" ++ show e + errorM _LOG_NAME msg + + eval "watch" exp = do + let forceVar = forceDebugCommandData cmdData + getResult = readDebugCommandData cmdData + + cmdStr <- forceVar exp + infoM _LOG_NAME cmdStr + putStrLnStdout mvarCtx cmdStr + + cmdStr <- getResult + infoM _LOG_NAME cmdStr + putStrStdout mvarCtx cmdStr + + let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr + + resSeq <- incResSeq mvarCtx + let body = J.EvaluateBody result 0 + res = J.defaultEvaluateResponse resSeq req + resStr = J.encode res{J.bodyEvaluateResponse = body} + sendResponse resStr + + + eval "repl" exp = do + let exec = execCommandData cmdData + getResult = readDebugCommandData cmdData + + cmdStr <- exec exp + infoM _LOG_NAME cmdStr + + cmdStr <- getResult + infoM _LOG_NAME cmdStr + + let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr + + resSeq <- incResSeq mvarCtx + let body = J.EvaluateBody result 0 + res = J.defaultEvaluateResponse resSeq req + resStr = J.encode res{J.bodyEvaluateResponse = body} + sendResponse resStr + + putStrStdout mvarCtx $ "\n" ++ _PHOITYNE_GHCI_PROMPT + + eval _ exp = do + let exec = execCommandData cmdData + getResult = readDebugCommandData cmdData + + cmdStr <- exec exp + infoM _LOG_NAME cmdStr + putStrLnStdout mvarCtx cmdStr + + cmdStr <- getResult + infoM _LOG_NAME cmdStr + putStrLnStdout mvarCtx cmdStr + + let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr + + resSeq <- incResSeq mvarCtx + let body = J.EvaluateBody result 0 + res = J.defaultEvaluateResponse resSeq req + resStr = J.encode res{J.bodyEvaluateResponse = body} + sendResponse resStr + + +-- | +-- +-- +continueHandler :: DebugCommandData -> MVar DebugContext -> J.ContinueRequest -> IO () +continueHandler cmdData mvarCtx req = flip E.catches handlers $ do + resSeq <- incResSeq mvarCtx + let resStr = J.encode $ J.defaultContinueResponse resSeq req + sendResponse resStr + + startDebug cmdData mvarCtx + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "continueHandler:" ++ show e + errorM _LOG_NAME msg + + +-- | +-- +-- +startDebug :: DebugCommandData -> MVar DebugContext -> IO () +startDebug cmdData mvarCtx = do + ctx <- readMVar mvarCtx + let started = debugStartedDebugContext ctx + + startDebugInternal started + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{currentFrameIdDebugContext = 0} + + 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 + 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 + + sendEventByDebugStopStatus cmdData mvarCtx cmdStr + + +-- | +-- +-- +sendEventByDebugStopStatus :: DebugCommandData -> MVar DebugContext -> String -> IO () +sendEventByDebugStopStatus _ 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 + infoM _LOG_NAME $ show pos + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStartedDebugContext = True, debugStoppedPosDebugContext = Just pos} + + resSeq <- incResSeq mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent stopEvtStr + + +-- | +-- +-- +stepOverHandler :: DebugCommandData -> MVar DebugContext -> J.NextRequest -> IO () +stepOverHandler cmdData mvarCtx req = flip E.catches handlers $ do + ctx <- readMVar mvarCtx + case debugStoppedPosDebugContext ctx of + Nothing -> do + resSeq <- incResSeq mvarCtx + let res = J.defaultNextResponse resSeq req + resStr = J.encode res{J.successNextResponse = False, J.messageNextResponse = "debug is initialized but not started yet. press F5(continue)."} + sendResponse resStr + Just _ -> stepOver + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "continueHandler:" ++ show e + errorM _LOG_NAME 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 + sendResponse resStr + + resSeq <- incResSeq mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent stopEvtStr + + +-- | +-- +-- +stepInHandler :: DebugCommandData -> MVar DebugContext -> J.StepInRequest -> IO () +stepInHandler cmdData mvarCtx req = flip E.catches handlers $ do + ctx <- readMVar mvarCtx + case debugStoppedPosDebugContext ctx of + Nothing -> do + resSeq <- incResSeq mvarCtx + let res = J.defaultStepInResponse resSeq req + resStr = J.encode res{J.successStepInResponse = False, J.messageStepInResponse = "debug is initialized but not started yet. press F5(continue)."} + sendResponse resStr + Just _ -> stepIn + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = "continueHandler:" ++ show e + errorM _LOG_NAME 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 + sendEvent 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 + sendResponse resStr + + resSeq <- incResSeq mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent stopEvtStr + + + + +-- |===================================================================== +-- +-- utility + + +-- | +-- +-- +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 + + + +-- | +-- +-- +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 -> FilePath -> IO Bool +runGHCi cmdData mvarCtx cwd = do + let startCmd = startDebugCommandData cmdData + readWhile = readWhileDebugCommandData cmdData + + infoM _LOG_NAME "% stack ghci --test --no-load --no-build \n" + putStrLnStdout mvarCtx "% stack ghci --test --no-load --no-build \n" + + startCmd cwd + + str <- readWhile $ not . endswith _GHCI_PROMPT + + infoM _LOG_NAME str + putStrStdout mvarCtx str + + withStarted $ endswith _GHCI_PROMPT str + + where + withStarted False = return False + withStarted True = do + readAndSetPrompt + return True + + readAndSetPrompt = do + let setPrompt = promptDebugCommandData cmdData + getResult = readDebugCommandData cmdData + printEvld = printEvldDebugCommandData cmdData + + promptStr <- setPrompt + putStrLnStdout mvarCtx promptStr + infoM _LOG_NAME promptStr + + cmdStr <- getResult + putStrStdout mvarCtx cmdStr + infoM _LOG_NAME cmdStr + + cmdStr <- printEvld + putStrLnStdout mvarCtx cmdStr + infoM _LOG_NAME cmdStr + + cmdStr <- getResult + putStrStdout mvarCtx cmdStr + infoM _LOG_NAME cmdStr + + +-- | +-- +-- +loadHsFile :: DebugCommandData -> MVar DebugContext -> FilePath -> IO Bool +loadHsFile cmdData mvarCtx path + | (False == endswith _HS_FILE_EXT path) = return False + | otherwise = do + let loadFile = loadFileDebugCommandData cmdData + readLines = readLinesDebugCommandData cmdData + getResult = readDebugCommandData cmdData + + cmdStr <- loadFile path + putStrLnStdout mvarCtx cmdStr + infoM _LOG_NAME cmdStr + + cont <- readLines debugStartResultHandler + + if | null cont -> return False + | startswith "Ok," (last cont) -> do + cmdStr <- getResult + putStrStdout mvarCtx cmdStr + infoM _LOG_NAME cmdStr + 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 + + +-- | +-- ブレークポイントをGHCi上でdeleteする +-- +deleteBreakPointOnCUI :: DebugCommandData -> MVar DebugContext -> BreakPointData -> IO () +deleteBreakPointOnCUI cmdData mvarCtx (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 mvarCtx (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 + + +-- |===================================================================== +-- +-- パーサ +-- + +-- | +-- +-- +getStoppedTextRangeData :: String -> Either ParseError HighlightTextRangeData +getStoppedTextRangeData = parse parser "getStoppedTextRangeData" + where + parser = do + _ <- manyTill anyChar (try (string "Stopped at ")) + parseHighlightTextRange + + +-- | +-- 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 (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) funcName (init (strip filePath)) + +-- | +-- バインディング値のパーサ +-- +-- parser of +-- args :: Project.Argument.ArgData = _ +-- _result :: IO Data.ConfigFile.Types.ConfigParser = _ +-- +getBindingDataList :: String -> Either ParseError [BindingData] +getBindingDataList res = parse parser "getBindingDataList" res + where + parser = manyTill parser1 (string _PHOITYNE_GHCI_PROMPT) + + 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 + + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/BreakpointJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/BreakpointJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/BreakpointJSON.hs @@ -0,0 +1,25 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ContinueArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ContinueRequestJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ContinueResponseJSON.hs @@ -0,0 +1,32 @@ +{-# 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" "" + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/DisconnectArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectRequestJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/DisconnectResponseJSON.hs @@ -0,0 +1,30 @@ +{-# 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" "" diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseBodyJSON.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ErrorResponseJSON.hs @@ -0,0 +1,31 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateArgumentsJSON.hs @@ -0,0 +1,21 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateBodyJSON.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateRequestJSON.hs @@ -0,0 +1,24 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/EvaluateResponseJSON.hs @@ -0,0 +1,34 @@ +{-# 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 + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/ExceptionBreakpointsFilterJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/ExceptionBreakpointsFilterJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ExceptionBreakpointsFilterJSON.hs @@ -0,0 +1,21 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ExitedEventBodyJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ExitedEventJSON.hs @@ -0,0 +1,27 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/InitializeRequestArgumentsJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/InitializeRequestJSON.hs @@ -0,0 +1,22 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseCapabilitesJSON.hs @@ -0,0 +1,23 @@ +{-# 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. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "InitializeResponseCapabilites") } ''InitializeResponseCapabilites) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/InitializeResponseJSON.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.IO.GUI.VSCode.TH.InitializeResponseJSON where + +import Data.Aeson.TH + +import Phoityne.Utility +import Phoityne.IO.GUI.VSCode.TH.InitializeResponseCapabilitesJSON + +-- | +-- 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) diff --git a/app/Phoityne/IO/GUI/VSCode/TH/InitializedEventJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/InitializedEventJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/InitializedEventJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestArgumentsJSON.hs @@ -0,0 +1,25 @@ +{-# 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 :: Bool -- If noDebug is true the launch request should launch the program without enabling debugging. + , nameLaunchRequestArguments :: String -- Phoityne specific argument. + , typeLaunchRequestArguments :: String -- Phoityne specific argument. + , requestLaunchRequestArguments :: String -- Phoityne specific argument. must be "request" + , startupLaunchRequestArguments :: String -- Phoityne specific argument. + , workspaceLaunchRequestArguments :: String -- Phoityne specific argument. + } 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/LaunchRequestJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/LaunchResponseJSON.hs @@ -0,0 +1,34 @@ +{-# 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" "" + + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/MessageJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/MessageJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/MessageJSON.hs @@ -0,0 +1,31 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/NextArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/NextRequestJSON.hs @@ -0,0 +1,24 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/NextResponseJSON.hs @@ -0,0 +1,34 @@ +{-# 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" "" + + + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/OutputEventBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/OutputEventBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/OutputEventBodyJSON.hs @@ -0,0 +1,26 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/OutputEventJSON.hs @@ -0,0 +1,25 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/PauseArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/PauseRequestJSON.hs @@ -0,0 +1,24 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/PauseResponseJSON.hs @@ -0,0 +1,32 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/RequestJSON.hs @@ -0,0 +1,18 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ScopeJSON.hs @@ -0,0 +1,21 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ScopesArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ScopesBodyJSON.hs @@ -0,0 +1,24 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ScopesRequestJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ScopesResponseJSON.hs @@ -0,0 +1,35 @@ +{-# 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 + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestArgumentsJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsRequestJSON.hs @@ -0,0 +1,25 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseBodyJSON.hs @@ -0,0 +1,32 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SetBreakpointsResponseJSON.hs @@ -0,0 +1,39 @@ +{-# 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 + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/SourceArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/SourceArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SourceArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SourceBreakpointJSON.hs @@ -0,0 +1,21 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SourceJSON.hs @@ -0,0 +1,22 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SourceRequestJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SourceResponseBodyJSON.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/SourceResponseJSON.hs @@ -0,0 +1,36 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StackFrameJSON.hs @@ -0,0 +1,24 @@ +{-# 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. + } 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceArgumentsJSON.hs @@ -0,0 +1,21 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceBodyJSON.hs @@ -0,0 +1,29 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceRequestJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StackTraceResponseJSON.hs @@ -0,0 +1,34 @@ +{-# 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 + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepInArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepInArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StepInArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StepInRequestJSON.hs @@ -0,0 +1,24 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StepInResponseJSON.hs @@ -0,0 +1,32 @@ +{-# 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" "" + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StepOutArgumentsJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StepOutArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StepOutArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StepOutRequestJSON.hs @@ -0,0 +1,24 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StepOutResponseJSON.hs @@ -0,0 +1,35 @@ +{-# 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" "" + + + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventBodyJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventBodyJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventBodyJSON.hs @@ -0,0 +1,31 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/StoppedEventJSON.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/TerminatedEventBodyJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/TerminatedEventJSON.hs @@ -0,0 +1,27 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ThreadJSON.hs @@ -0,0 +1,21 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ThreadsRequestJSON.hs @@ -0,0 +1,21 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseBodyJSON.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/ThreadsResponseJSON.hs @@ -0,0 +1,38 @@ +{-# 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 + + + + diff --git a/app/Phoityne/IO/GUI/VSCode/TH/VariableJSON.hs b/app/Phoityne/IO/GUI/VSCode/TH/VariableJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/VariableJSON.hs @@ -0,0 +1,22 @@ +{-# 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 + , 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/VariablesArgumentsJSON.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/VariablesBodyJSON.hs @@ -0,0 +1,26 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/VariablesRequestJSON.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/GUI/VSCode/TH/VariablesResponseJSON.hs @@ -0,0 +1,37 @@ +{-# 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 + + + diff --git a/app/Phoityne/IO/Main.hs b/app/Phoityne/IO/Main.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/Main.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} + +module Phoityne.IO.Main (run) where + +-- モジュール +import Phoityne.Constant +import qualified Phoityne.Argument as A +import qualified Phoityne.IO.Control as CTRL + +-- システム +import System.IO +import Data.Either.Utils +import Safe +import qualified Control.Exception as E +import qualified System.IO.Error as E +import qualified Data.ConfigFile as C +import qualified System.Console.CmdArgs as CMD +import qualified System.Log.Logger as L +import qualified System.Log.Formatter as L +import qualified System.Log.Handler as LH +import qualified System.Log.Handler.Simple as LHS + +-- | +-- アプリケーションメイン +-- +run :: IO Int +run = flip E.catches handlers $ do + + -- コマンドライン引数設定 + args <- getArgs + + -- INI設定ファイルのRead + iniSet <- loadIniFile args + + -- Loggerのセットアップ + setupLogger iniSet + + -- ロジック実行 + 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 args = do + cp <- if null (A.file args) then return $ forceEither $ C.readstring C.emptyCP defaultIniSetting + else forceEither <$> C.readfile C.emptyCP (A.file args) + + return cp{ C.accessfunc = C.interpolatingAccess 5 } + +-- | +-- デフォルトINI設定 +-- +defaultIniSetting :: String +defaultIniSetting = unlines [ + "[DEFAULT]" + , "work_dir = C:/temp/" + , "" + , "[LOG]" + , "file = %(work_dir)sphoityne.log" + , "level = WARNING" + , "" + , "[PHOITYNE]" + ] + +-- | +-- Loggerのセットアップ +-- +setupLogger :: C.ConfigParser -- INI設定 + -> IO () -- なし +setupLogger cp = do + let logFile = forceEither $ C.get cp _INI_SEC_LOG _INI_LOG_FILE + logLevel = forceEither $ C.get cp _INI_SEC_LOG _INI_LOG_LEVEL + + level <- case readMay logLevel of + Just a -> return a + Nothing -> E.throwIO . E.userError $ "invalid log level[" ++ logLevel ++ "]" + + logStream <- openFile logFile AppendMode + hSetEncoding logStream utf8 + + logH <- LHS.streamHandler logStream level + + let logHandle = logH {LHS.closeFunc = hClose} + logFormat = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT + logHandler = LH.setFormatter logHandle logFormat + + L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle]) + L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler] + L.updateGlobalLogger _LOG_NAME $ L.setLevel level + diff --git a/app/Phoityne/IO/Utility.hs b/app/Phoityne/IO/Utility.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/IO/Utility.hs @@ -0,0 +1,48 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/app/Phoityne/Utility.hs @@ -0,0 +1,74 @@ + +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/phoityne-vscode.cabal b/phoityne-vscode.cabal new file mode 100644 --- /dev/null +++ b/phoityne-vscode.cabal @@ -0,0 +1,139 @@ +name: phoityne-vscode +version: 0.0.1.0 +synopsis: ghci debug viewer on Visual Studio Code +description: Please see README.md +license: BSD3 +license-file: LICENSE +author: phoityne_hs +maintainer: phoityne.hs@gmail.com +homepage: https://sites.google.com/site/phoityne/ +copyright: 2016 phoityne_hs +category: Development +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + , Changelog.md +data-files: vscode/package.json + +executable phoityne-vscode + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing + 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 + build-depends: base >= 4.7 && < 5 + , directory + , Cabal + , hslogger + , ConfigFile + , cmdargs + , MissingH + , safe + , aeson + , bytestring + , containers + , conduit + , conduit-extra + , text + , resourcet + , process + , HStringTemplate + , transformers + , mtl + , filepath + , directory + , parsec + , split + 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 new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/vscode/package.json b/vscode/package.json new file mode 100644 --- /dev/null +++ b/vscode/package.json @@ -0,0 +1,47 @@ +{ + "name": "phoityne-vscode", + "displayName": "phoityne", + "version": "0.0.1", + "publisher": "phoityne.hs", + "description": "ghci debug viewer Phoityne, on Visual Studio Code.", + "categories": ["Debuggers"], + "author": {"name": "phoityne.hs"}, + "license": "BSD3", + "private": false, + "engines": {"vscode": "^0.10.1"}, + "dependencies": {}, + "contributes": { + "debuggers": [{ + "type": "ghc", + "label": "ghci debug viewer Phoityne", + "enableBreakpointsFor": { "languageIds": ["haskell"] }, + "program": "phoityne-vscode.exe", + "configurationAttributes": { + "launch": { + "required": ["program"], + "properties": { + "workspace": { + "type" : "string", + "description": "Absolute path to the workspace.", + "default" : "${workspaceRoot}" + }, + "startup": { + "type": "string", + "description": "Absolute path to the startup program.", + "default": "${workspaceRoot}/test/Spec.hs" + } + } + } + }, + "initialConfigurations": [ + { + "type": "ghc", + "name": "ghci debug viewer Phoityne", + "request": "launch", + "workspace": "${workspaceRoot}", + "startup": "${workspaceRoot}/test/Spec.hs" + } + ] + }] + } +}