From a58ebf25c34c38a0896a0b08c4bd9b98012b5292 Mon Sep 17 00:00:00 2001 From: David Johnson Date: Mon, 1 May 2023 08:50:29 -0500 Subject: [PATCH 1/2] - Added support for external-stg-interpreter - Added logging - Added hello example (working build with wpc-plugin) - Session TVar Map is now global - Added local connection locking - Fleshed out Event / Responses API - Made SeqNum an IORef - Added registerDebugSession and facilities to both run a new debugger and cancel execution - Added more facilities for parsing JSON - Updated haddocking - Working nix and stack builds --- .gitignore | 8 +- dap-extension/package.json | 12 +- dap-extension/src/extension.ts | 2 +- dap/cabal.project | 29 ++ dap/cbits/main.c | 14 - dap/dap.cabal | 7 +- dap/default.nix | 108 ++++++- dap/exe/Main.hs | 156 +++++++--- dap/hello/.vscode/launch.json | 14 + dap/hello/LICENSE | 24 ++ dap/hello/Setup.hs | 6 + dap/hello/foo | 6 + dap/hello/hello.cabal | 47 +++ dap/hello/src/hello.hs | 3 + dap/shell.nix | 6 +- dap/src/DAP/Adaptor.hs | 181 +++++++++-- dap/src/DAP/Internal.hs | 18 +- dap/src/DAP/Response.hs | 107 +++++-- dap/src/DAP/Server.hs | 51 +-- dap/src/DAP/Types.hs | 547 +++++++++++++++++++-------------- dap/src/DAP/Utils.hs | 18 +- dap/stack.yaml | 29 ++ dap/stack.yaml.lock | 83 +++++ 23 files changed, 1088 insertions(+), 388 deletions(-) create mode 100644 dap/cabal.project delete mode 100644 dap/cbits/main.c create mode 100644 dap/hello/.vscode/launch.json create mode 100644 dap/hello/LICENSE create mode 100644 dap/hello/Setup.hs create mode 100644 dap/hello/foo create mode 100644 dap/hello/hello.cabal create mode 100644 dap/hello/src/hello.hs create mode 100644 dap/stack.yaml create mode 100644 dap/stack.yaml.lock diff --git a/.gitignore b/.gitignore index 132b560..92fe056 100644 --- a/.gitignore +++ b/.gitignore @@ -32,4 +32,10 @@ main # C ./main *.dSYM -a.out \ No newline at end of file + +# stg +*.fullpak +*.modpak + +# tags +tags diff --git a/dap-extension/package.json b/dap-extension/package.json index f356a6c..3c69caa 100644 --- a/dap-extension/package.json +++ b/dap-extension/package.json @@ -7,7 +7,7 @@ "vscode": "^1.77.0" }, "categories": [ - "Other" + "Debuggers" ], "activationEvents": [ "onDebug", "onDebugResolve:dap-extension" ], "main": "./out/extension.js", @@ -16,9 +16,9 @@ { "type": "dap-extension", "languages": [ - "C" + "Haskell" ], - "program": "${workspaceFolder}/a.out", + "program": "${workspaceFolder}/test.fullpak", "label": "dap-extension", "configurationAttributes": { "attach": { @@ -26,8 +26,8 @@ "properties": { "program": { "type": "string", - "description": "Absolute path to the C program compiled with debugging (-g)", - "default": "${workspaceFolder}/a.out" + "description": "Absolute path to the program", + "default": "${workspaceFolder}/test.fullpak" } } } @@ -36,7 +36,7 @@ { "type": "dap-extension", "request": "attach", - "program": "${workspaceFolder}/a.out" + "program": "${workspaceFolder}/test.fullpak" } ] } diff --git a/dap-extension/src/extension.ts b/dap-extension/src/extension.ts index ad91265..13fbb67 100644 --- a/dap-extension/src/extension.ts +++ b/dap-extension/src/extension.ts @@ -46,7 +46,7 @@ export function runDebugger (context: vscode.ExtensionContext, factory: MockDebu }); vscode.debug.onDidReceiveDebugSessionCustomEvent((e) => { - console.log(e, 'custom event received hit') + console.log(e, 'custom event received hit'); }); } diff --git a/dap/cabal.project b/dap/cabal.project new file mode 100644 index 0000000..b3c7688 --- /dev/null +++ b/dap/cabal.project @@ -0,0 +1,29 @@ +packages: . + +source-repository-package + type: git + location: https://github.com/TeofilC/digest + tag: ac9616b94cb8c4a9e07188d19979a6225ebd5a10 + +source-repository-package + type: git + location: https://github.com/grin-compiler/ghc-whole-program-compiler-project + tag: 9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31 + subdir: + external-stg + external-stg-syntax + external-stg-interpreter + +source-repository-package + type: git + location: https://github.com/luc-tielen/souffle-haskell + tag: f8c9fc45eed709110af3d3301393f63f4535c71e + +constraints: + type-errors-pretty == 0.0.1.2, + souffle-haskell == 3.4.0 + +package digest + flags: -pkg-config + +allow-newer: type-errors-pretty:base \ No newline at end of file diff --git a/dap/cbits/main.c b/dap/cbits/main.c deleted file mode 100644 index 734843e..0000000 --- a/dap/cbits/main.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -int factorial (int n); - -int main (int argv, char **argc) { - printf("factorial(5) is equal to %i\n", factorial(5)); -} - -int factorial (int n) { - if (n == 0) { - return 1; - } - return n * factorial (n - 1); -} diff --git a/dap/dap.cabal b/dap/dap.cabal index 68c4e0d..22a47d8 100644 --- a/dap/dap.cabal +++ b/dap/dap.cabal @@ -25,8 +25,10 @@ executable dap base < 5 , dap , bytestring - , hgdbmi + , external-stg-interpreter + , lifted-base , network + , unagi-chan , unordered-containers , aeson , text @@ -53,12 +55,15 @@ library , aeson-pretty , base < 5 , bytestring + , lifted-base , mtl + , monad-control , network , network-simple , stm , text , time + , transformers-base , unordered-containers hs-source-dirs: src diff --git a/dap/default.nix b/dap/default.nix index 925b76d..b3628ed 100644 --- a/dap/default.nix +++ b/dap/default.nix @@ -4,35 +4,119 @@ with pkgs.haskell.lib; let + cabal-src = pkgs.fetchFromGitHub + { owner = "haskell"; + repo = "cabal"; + sha256 = "13x3dr257ivalhgiffjnyazffimn4a817dj3p96vvi50nx67cml2"; + rev = "3af1731c01c35614fd902ee5c1aec40f5587fde6"; + }; ghcidSrc = pkgs.fetchFromGitHub { owner = "ndmitchell"; repo = "ghcid"; sha256 = "0bsjbb6n7ssg411k2xj4f881v392hvb7xln99bq1r3vkg14mqqsd"; rev = "e2852979aa644c8fed92d46ab529d2c6c1c62b59"; }; - hgdbmiSrc = pkgs.fetchFromGitHub - { owner = "copton"; - repo = "hgdbmi"; - sha256 = "1s6gqd1680sm4xlxy324s6vvdn90hrw17s57zl34ljcck3r5qj6x"; - rev = "faa0881cad2ac3cc3c28009fd589b9bd7866c8dc"; + zip-cmd-src = pkgs.fetchFromGitHub + { owner = "grin-compiler"; + repo = "zip-cmd"; + sha256 = "1gsdcip4qrd8bbxira7v9yz1b05c0y7jbbd440hwdh5z6y94ah9g"; + rev = "97a6a768803958faee855de115c0402f29bad32b"; + }; + external-stg-src = pkgs.fetchFromGitHub + { owner = "grin-compiler"; + repo = "ghc-whole-program-compiler-project"; + sha256 = "0a9qxm29cn0vy5v0d399944j0155ck8pqqk58w1y350g70anych0"; + rev = "9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31"; + }; + souffle-haskell-src = pkgs.fetchFromGitHub + { owner = "luc-tielen"; + repo = "souffle-haskell"; + sha256 = "sha256-/BdDkSTlxh3m3ApxqdbDQ1yIGiE6mTfDljfpEYgE5Tg="; + rev = "f8c9fc45eed709110af3d3301393f63f4535c71e"; + }; + type-errors-pretty-src = pkgs.fetchFromGitHub + { owner = "kowainik"; + repo = "type-errors-pretty"; + sha256 = "1yylw5c8ffzybcv7cm6ff0k88an4iz0fhc59md09s9zlns03f3d0"; + rev = "c85d6d0a7bf2278ddb03abddb5782a5b6095d343"; + }; + ghc-wpc-src = builtins.fetchGit + { url = "https://github.com/grin-compiler/ghc-wpc.git"; + ref = "ghc-whole-program-compiler"; + submodules = true; }; + ghc-patch = pkgs.fetchpatch { + url = "https://gitlab.haskell.org/ghc/ghc/-/commit/ad2ef3a13f1eb000eab8e3d64592373b91a52806.patch"; + sha256 = "sha256-Dm9nOcS20wiA5Op4vF9Y8YqcgSSC3IKRlYusBukzf8Y="; + }; + + overrides961 = self: super: { + Cabal = self.callCabal2nix "Cabal" "${cabal-src}/Cabal" {}; + Cabal-syntax = self.callCabal2nix "Cabal-syntax" "${cabal-src}/Cabal-syntax" {}; + Cabal-tests = (self.callCabal2nix "Cabal-tests" "${cabal-src}/Cabal-tests" {}); + cabal-install-solver = (self.callCabal2nix "cabal-install-solver" "${cabal-src}/cabal-install-solver" {}); + cabal-install = (self.callCabal2nix "cabal-install" "${cabal-src}/cabal-install" {}); + Cabal-described = (self.callCabal2nix "Cabal-described" "${cabal-src}/Cabal-described" {}); + Cabal-QuickCheck = (self.callCabal2nix "Cabal-QuickCheck" "${cabal-src}/Cabal-QuickCheck" {}); + Cabal-tree-diff = (self.callCabal2nix "Cabal-tree-diff" "${cabal-src}/Cabal-tree-diff" {}); + zip-cmd = doJailbreak (self.callCabal2nix "zip-cmd" zip-cmd-src {}); + zip = dontCheck (doJailbreak (super.zip)); + wpc-plugin = self.callCabal2nix "wpc-plugin" "${external-stg-src}/wpc-plugin" {}; + external-stg = self.callCabal2nix "external-stg" "${external-stg-src}/external-stg" {}; + external-stg-syntax = self.callCabal2nix "external-stg-syntax" "${external-stg-src}/external-stg-syntax" {}; + hello = with self; + pkgs.lib.overrideDerivation (addBuildDepends (callCabal2nix "hello" ./hello {}) [zip-cmd external-stg]) (drv: { + postInstall = '' + ${external-stg}/bin/mkfullpak -a dist/build/hello/hello.o_ghc_stgapp + mv -v dist/build/hello/hello.fullpak $out/bin/hello.fullpak + ''; + }); + }; + + overrides924 = self: super: { + type-errors-pretty = + dontCheck (doJailbreak (self.callCabal2nix "type-errors-pretty" type-errors-pretty-src {})); + external-stg = + self.callCabal2nix "external-stg" "${external-stg-src}/external-stg" {}; + external-stg-interpreter = with pkgs.haskell.lib; + self.callCabal2nix "external-stg-interpreter" "${external-stg-src}/external-stg-interpreter" + (pkgs.lib.optionalAttrs (pkgs.stdenv.isDarwin) { omp = pkgs.llvmPackages.openmp; }); + external-stg-syntax = + self.callCabal2nix "external-stg-syntax" "${external-stg-src}/external-stg-syntax" {}; + souffle-haskell = with pkgs; + overrideCabal + (addBuildTool (self.callCabal2nix "souffle-haskell" souffle-haskell-src { }) souffle) + (o: { + doCheck = true; + checkPhase = '' + runHook preCheck + DATALOG_DIR="${o.src}/tests/fixtures/" SOUFFLE_BIN="${souffle}/bin/souffle" ./Setup test + runHook postCheck + ''; + }); - overrides = self: super: { ghcid = doJailbreak (self.callCabal2nix "ghcid" ghcidSrc {}); - hgdbmi = - dontCheck (doJailbreak (self.callCabal2nix "hgdbmi" hgdbmiSrc {})); dap = self.callCabal2nix "dap" ./. {}; }; - hPkgs = - pkgs.haskell.packages.ghc924.override { inherit overrides; }; + hPkgs924 = pkgs.haskell.packages.ghc924.override { overrides = overrides924; }; + hPkgs961 = pkgs.haskell.packages.ghc961.override { overrides = overrides961; }; + in { inherit pkgs; - inherit (hPkgs) - hgdbmi + inherit (hPkgs961) + hello + zip-cmd + cabal-install + wpc-plugin; + inherit (hPkgs924) + external-stg + external-stg-interpreter + external-stg-syntax + souffle-haskell ghcid dap; } diff --git a/dap/exe/Main.hs b/dap/exe/Main.hs index 4733039..bf72831 100644 --- a/dap/exe/Main.hs +++ b/dap/exe/Main.hs @@ -19,11 +19,24 @@ ---------------------------------------------------------------------------- module Main (main) where ---------------------------------------------------------------------------- -import Data.Aeson ( Value(Null) ) -import Data.Maybe ( fromMaybe ) -import System.Environment ( lookupEnv ) -import Text.Read ( readMaybe ) -import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack ) +import Control.Exception hiding (catch) +import Control.Monad.IO.Class (liftIO) +import Control.Exception.Lifted (catch) +import Control.Monad +import Data.Aeson ( Value(Null), FromJSON ) +import Data.Text ( Text ) +import Data.Maybe ( fromMaybe ) +import GHC.Generics ( Generic ) +import System.Environment ( lookupEnv ) +import Text.Read ( readMaybe ) +import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack ) +import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi +---------------------------------------------------------------------------- +import Stg.Interpreter +import Stg.Interpreter.Debug +import Stg.Interpreter.Base hiding (lookupEnv) +import Stg.Interpreter.Debugger +import Stg.Interpreter.Debugger.UI ---------------------------------------------------------------------------- import DAP ---------------------------------------------------------------------------- @@ -48,26 +61,83 @@ getConfig = do <*> pure defaultCapabilities <*> pure True ---------------------------------------------------------------------------- +-- | VSCode arguments are custom for attach +-- > "arguments": { +-- > "__configurationTarget": 6, +-- > "__sessionId": "6c0ba6f8-e478-4698-821e-356fc4a72c3d", +-- > "name": "thing", +-- > "program": "/home/dmjio/Desktop/stg-dap/test.fullpak", +-- > "request": "attach", +-- > "type": "dap-extension" +-- > } +-- +data AttachArgs + = AttachArgs + { __sessionId :: Text + -- ^ SessionID from VSCode + , program :: String + -- ^ Path to .fullpak file + } deriving stock (Show, Eq, Generic) + deriving anyclass FromJSON +---------------------------------------------------------------------------- +-- | ESTG specific state used with our AdaptorState +-- +---------------------------------------------------------------------------- +data ESTG + = ESTG + { inChan :: Unagi.InChan DebugCommand + , outChan :: Unagi.OutChan DebugOutput + , fullPakPath :: String + } +---------------------------------------------------------------------------- +-- | Intialize ESTG interpreter +---------------------------------------------------------------------------- +initESTG :: AttachArgs -> AdaptorClient ESTG () +initESTG AttachArgs {..} = do + (dbgCmdI, dbgCmdO) <- liftIO (Unagi.newChan 100) + (dbgOutI, dbgOutO) <- liftIO (Unagi.newChan 100) + let dbgChan = DebuggerChan (dbgCmdO, dbgOutI) + registerNewDebugSession __sessionId (ESTG dbgCmdI dbgOutO program) $ do + (liftIO (loadAndRunProgram True True program [] dbgChan DbgStepByStep False)) + `catch` + handleDebuggerExceptions +---------------------------------------------------------------------------- +-- | Exception Handler +handleDebuggerExceptions :: SomeException -> AdaptorClient ESTG () +handleDebuggerExceptions e = do + logError $ BL8.pack ("Caught: " <> show e) + sendTerminatedEvent (TerminatedEvent False) +---------------------------------------------------------------------------- -- | Main function where requests are received and Events + Responses are returned. -- The core logic of communicating between the client <-> adaptor <-> debugger -- is implemented in this function. ---------------------------------------------------------------------------- -talk :: Command -> AdaptorClient app () +talk :: Command -> AdaptorClient ESTG () ---------------------------------------------------------------------------- -- | Register SessionId and initialize program in the 'AppStore' -talk CommandAttach = +talk CommandAttach = do + initESTG =<< getArguments sendAttachResponse + where + emitEvent :: DebugOutput -> AdaptorClient ESTG () + emitEvent cmd = logInfo $ BL8.pack (show cmd) ---------------------------------------------------------------------------- -talk CommandBreakpointLocations = sendBreakpointsLocationResponse [] +talk CommandBreakpointLocations = sendBreakpointLocationsResponse [] ---------------------------------------------------------------------------- talk CommandContinue = sendContinueResponse (ContinueResponse True) ---------------------------------------------------------------------------- -talk CommandConfigurationDone = sendConfigurationDoneResponse +talk CommandConfigurationDone = do + withDebugSession $ \ESTG {..} -> + liftIO (Unagi.writeChan inChan CmdListClosures) + sendConfigurationDoneResponse ---------------------------------------------------------------------------- -talk CommandDisconnect = sendDisconnectResponse +talk CommandDisconnect = do + destroyDebugSession + sendExitedEvent (ExitedEvent 1) + sendDisconnectResponse ---------------------------------------------------------------------------- talk CommandInitialize = do - sendInitializedResponse + sendInitializeResponse sendInitializedEvent ---------------------------------------------------------------------------- talk CommandLoadedSources = sendLoadedSourcesResponse [] @@ -87,39 +157,43 @@ talk CommandSetFunctionBreakpoints = sendSetFunctionBreakpointsResponse [] ---------------------------------------------------------------------------- talk CommandSetInstructionBreakpoints = sendSetInstructionBreakpointsResponse [] ---------------------------------------------------------------------------- -talk CommandStackTrace - = sendStackTraceResponse - $ flip StackTraceResponse (Just 1) - [ StackFrame 1 "frame" source 1 1 10 10 False (Just "pointer-ref") (Just (Right "module")) - (Just PresentationHintNormal) - ] where - source :: Source - source = Source - (Just "Main.hs") - "/Users/j22293/Desktop/external-stg-dap/external-stg-dap/exe/Main.hs" - (Just 0) - (Just SourcePresentationHintNormal) - (Just "/Users/j22293/Desktop/external-stg-dap/external-stg-dap/exe/Main.hs") - [] - Null - [] +-- talk CommandStackTrace = do +-- sendStackTraceResponse resp +-- sendTerminatedEvent (TerminatedEvent False) +-- sendExitedEvent (ExitedEvent 0) +-- where +-- resp = StackTraceResponse +-- [ StackFrame 1 "frame" source 1 1 10 10 False +-- (Just "pointer-ref") (Just (Right "module"))(Just PresentationHintNormal) +-- ] (Just 1) + +-- source :: Source +-- source = Source +-- (Just "cbits/main.c.out") +-- "/Users/j22293/Desktop/external-stg-dap/external-stg-dap/exe/Main.hs" +-- (Just 0) +-- (Just SourcePresentationHintNormal) +-- (Just "/Users/j22293/Desktop/external-stg-dap/external-stg-dap/exe/Main.hs") +-- [] +-- Null +-- [] ---------------------------------------------------------------------------- talk CommandSource = sendSourceResponse (SourceResponse "file content" (Just "text/plain")) ---------------------------------------------------------------------------- -talk CommandThreads - = do sendThreadsResponse - [ Thread 1 "main" - ] - sendStoppedEvent $ - StoppedEvent - StoppedEventReasonPause - (Just "starting") - (Just 1) - False - (Just "starting now?") - False - [] +-- talk CommandThreads +-- = do sendThreadsResponse +-- [ Thread 1 "main" +-- ] +-- sendStoppedEvent $ +-- StoppedEvent +-- StoppedEventReasonPause +-- (Just "starting") +-- (Just 1) +-- False +-- (Just "starting now?") +-- False +-- [] ---------------------------------------------------------------------------- -talk command = debugMessage $ BL8.pack ("GOT command: " <> show command) +talk command = logInfo $ BL8.pack ("GOT command: " <> show command) ---------------------------------------------------------------------------- diff --git a/dap/hello/.vscode/launch.json b/dap/hello/.vscode/launch.json new file mode 100644 index 0000000..14e710c --- /dev/null +++ b/dap/hello/.vscode/launch.json @@ -0,0 +1,14 @@ +{ + // Use IntelliSense to learn about possible attributes. + // Hover to view descriptions of existing attributes. + // For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387 + "version": "0.2.0", + "configurations": [ + { + "type": "dap-extension", + "request": "attach", + "program": "${workspaceFolder}/test.fullpak", + "name": "hello" + } + ] +} \ No newline at end of file diff --git a/dap/hello/LICENSE b/dap/hello/LICENSE new file mode 100644 index 0000000..8cdf44c --- /dev/null +++ b/dap/hello/LICENSE @@ -0,0 +1,24 @@ +Copyright 2010, Simon Marlow +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. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND THE 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 AUTHOR OR THE +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/dap/hello/Setup.hs b/dap/hello/Setup.hs new file mode 100644 index 0000000..6fa548c --- /dev/null +++ b/dap/hello/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/dap/hello/foo b/dap/hello/foo new file mode 100644 index 0000000..5475b0f --- /dev/null +++ b/dap/hello/foo @@ -0,0 +1,6 @@ +packages: * + +package hello + ghc-options: + -fplugin-library=/nix/store/871x1xb4f2pxdx2py46q2qr52vzy2ykf-wpc-plugin-1.0.1/lib/ghc-9.6.1/lib/libwpc-plugin.so;wpc-plugin-unit;WPC.Plugin;[] + -fplugin-trustworthy diff --git a/dap/hello/hello.cabal b/dap/hello/hello.cabal new file mode 100644 index 0000000..4dde146 --- /dev/null +++ b/dap/hello/hello.cabal @@ -0,0 +1,47 @@ +-- Instructions on how to write this file are in the Cabal +-- documentation, which can be found here: +-- http://haskell.org/cabal/release/cabal-latest/doc/users-guide/ + +name: hello +version: 1.0.0.2 +license: BSD3 +license-file: LICENSE +copyright: (c) Simon Marlow +author: Simon Marlow +maintainer: Simon Marlow +bug-reports: mailto:marlowsd@gmail.com +stability: stable +homepage: http://www.haskell.org/hello/ +synopsis: Hello World, an example package +category: Console, Text +cabal-version: >= 1.8 +build-type: Simple + +Description: + This is an implementation of the classic "Hello World" program in + Haskell, as an example of how to create a minimal Haskell + application using Cabal and Hackage. Please submit any suggestions and + improvements. + +source-repository head + type: darcs + location: http://darcs.haskell.org/hello/ + +flag threaded + default: False + +executable hello + hs-source-dirs: src + main-is: hello.hs + ghc-options: + -fplugin=WPC.Plugin + build-depends: + base >= 4.2 && < 5 + , wpc-plugin + + -- ghc-options: + -- -fplugin-library=/nix/store/871x1xb4f2pxdx2py46q2qr52vzy2ykf-wpc-plugin-1.0.1/lib/ghc-9.6.1/lib/libwpc-plugin.so;wpc-plugin-unit;WPC.Plugin;[] + -- -fplugin-trustworthy + + if flag(threaded) + ghc-options: -threaded diff --git a/dap/hello/src/hello.hs b/dap/hello/src/hello.hs new file mode 100644 index 0000000..d9f755b --- /dev/null +++ b/dap/hello/src/hello.hs @@ -0,0 +1,3 @@ +module Main (main) where + +main = putStrLn "Hello, World!" diff --git a/dap/shell.nix b/dap/shell.nix index b8d2964..dd4c2da 100644 --- a/dap/shell.nix +++ b/dap/shell.nix @@ -5,13 +5,9 @@ with externalStgDapPkgs; dap.env.overrideAttrs (drv: { shellHook = '' - export PATH=$PATH:${pkgs.gdb}/bin + export PATH=$PATH:${pkgs.haskell.packages.ghc924.stack}/bin function ghcid () { ${ghcid}/bin/ghcid --poll --allow-eval -c 'cabal repl' } - function compile () { - echo "compiling cbits/main.c with debug info (-g) to main" - gcc -Wall -Werror -ansi -pedantic-errors -g cbits/main.c -o a.out - } ''; }) diff --git a/dap/src/DAP/Adaptor.hs b/dap/src/DAP/Adaptor.hs index 54f3388..6d34da7 100644 --- a/dap/src/DAP/Adaptor.hs +++ b/dap/src/DAP/Adaptor.hs @@ -13,6 +13,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} ---------------------------------------------------------------------------- module DAP.Adaptor ( debugMessage @@ -21,13 +22,29 @@ module DAP.Adaptor , sendSuccesfulEvent , getServerCapabilities , setBody + , withConnectionLock + , getArguments + , registerNewDebugSession + , withDebugSession + , getDebugSessionId + , destroyDebugSession + -- * Logging + , logWarn + , logError + , logInfo + , logger ) where ---------------------------------------------------------------------------- +import Control.Concurrent.Lifted ( fork, killThread ) +import Control.Exception ( throwIO ) import Control.Concurrent.STM ( atomically, readTVarIO, modifyTVar' ) import Control.Monad ( when ) import Control.Monad.State ( MonadIO(liftIO), gets, modify' ) +import Data.Aeson ( FromJSON, Result (..), fromJSON ) import Data.Aeson.Encode.Pretty ( encodePretty ) import Data.Aeson.Types ( object, Key, KeyValue((.=)), ToJSON ) +import Data.IORef ( atomicModifyIORef', readIORef, atomicWriteIORef ) +import Data.Text ( unpack, Text ) import Network.Socket ( SockAddr ) import System.IO ( Handle ) import qualified Data.ByteString.Lazy.Char8 as BL8 @@ -38,27 +55,52 @@ import DAP.Types import DAP.Utils import DAP.Internal ---------------------------------------------------------------------------- +-- | Meant for internal consumption +logDebug :: DebugStatus -> BL8.ByteString -> AdaptorClient app () +logDebug d = logWithAddr DEBUG (Just d) +---------------------------------------------------------------------------- +logWarn :: BL8.ByteString -> AdaptorClient app () +logWarn msg = logWithAddr WARN Nothing (withBraces msg) +---------------------------------------------------------------------------- +logError :: BL8.ByteString -> AdaptorClient app () +logError msg = logWithAddr ERROR Nothing (withBraces msg) +---------------------------------------------------------------------------- +logInfo :: BL8.ByteString -> AdaptorClient app () +logInfo msg = logWithAddr INFO Nothing (withBraces msg) +---------------------------------------------------------------------------- +-- | Meant for internal consumption debugMessage :: BL8.ByteString -> AdaptorClient app () debugMessage msg = do shouldLog <- getDebugLogging + addr <- getAddress liftIO $ when shouldLog + $ logger DEBUG addr Nothing msg +---------------------------------------------------------------------------- +-- | Meant for external consumption +logWithAddr :: Level -> Maybe DebugStatus -> BL8.ByteString -> AdaptorClient app () +logWithAddr level status msg = do + addr <- getAddress + liftIO (logger level addr status msg) +---------------------------------------------------------------------------- +-- | Meant for external consumption +logger :: Level -> SockAddr -> Maybe DebugStatus -> BL8.ByteString -> IO () +logger level addr maybeDebug msg = do + liftIO $ withGlobalLock - $ BL8.putStrLn msg + $ BL8.putStrLn formatted + where + formatted + = BL8.concat + [ withBraces $ BL8.pack (show addr) + , withBraces $ BL8.pack (show level) + , maybe mempty (withBraces . BL8.pack . show) maybeDebug + , msg + ] ---------------------------------------------------------------------------- getDebugLogging :: AdaptorClient app Bool getDebugLogging = gets (debugLogging . adaptorServerConfig) ---------------------------------------------------------------------------- -sendMessage :: ToJSON event => SockAddr -> Handle -> event -> AdaptorClient app () -sendMessage addr handle evt = do - let msg = encodeBaseProtocolMessage evt - shouldLog <- getDebugLogging - debugMessage $ BL8.intercalate "\n" - [ BL8.pack ("[SENT][" <> show addr <> "]") - , encodePretty evt - ] - liftIO (BS.hPutStr handle msg) ----------------------------------------------------------------------------- getServerCapabilities :: AdaptorClient app Capabilities getServerCapabilities = gets (serverCapabilities . adaptorServerConfig) ---------------------------------------------------------------------------- @@ -70,31 +112,77 @@ getHandle = gets handle ---------------------------------------------------------------------------- getNextSeqNum :: AdaptorClient app Seq getNextSeqNum = do - modify' $ \s -> s { seqNum = seqNum s + 1 } - gets seqNum + ref <- gets seqRef + liftIO $ atomicModifyIORef' ref $ \x -> (x, x + 1) ---------------------------------------------------------------------------- getRequestSeqNum :: AdaptorClient app Seq getRequestSeqNum = gets (requestSeqNum . request) ---------------------------------------------------------------------------- -getSessionId :: AdaptorClient app (Maybe SessionId) -getSessionId = gets sessionId +getDebugSessionId :: AdaptorClient app (Maybe SessionId) +getDebugSessionId = liftIO . readIORef =<< gets sessionId ---------------------------------------------------------------------------- -registerNewSession :: SessionId -> app -> AdaptorClient app () -registerNewSession k v = do - store <- gets adaptorAppStore - liftIO . atomically $ modifyTVar' store (H.insert k v) +setDebugSessionId :: SessionId -> AdaptorClient app () +setDebugSessionId session = do + ref <- gets sessionId + liftIO (atomicWriteIORef ref (Just session)) ---------------------------------------------------------------------------- -withSession :: (app -> AdaptorClient app ()) -> AdaptorClient app () -withSession continuation = do - maybeSessionId <- getSessionId - case maybeSessionId of +registerNewDebugSession + :: SessionId + -> app + -> AdaptorClient app () + -- ^ Long running operation, meant to be used as a sink for + -- the debugger to emit events and for the adaptor to forward to the editor + -- This function should be in a 'forever' loop waiting on the read end of + -- a debugger channel. + -> AdaptorClient app () +registerNewDebugSession k v action = do + store <- gets adaptorAppStore + tid <- fork (resetAdaptorStatePayload >> action) + liftIO . atomically $ modifyTVar' store (H.insert k (tid, v)) + setDebugSessionId k + logInfo $ BL8.pack $ "Registered new debug session: " <> unpack k +---------------------------------------------------------------------------- +withDebugSession :: (app -> AdaptorClient app ()) -> AdaptorClient app () +withDebugSession continuation = do + getDebugSessionId >>= \case Nothing -> sessionNotFound Just sessionId -> do appStore <- liftIO . readTVarIO =<< getAppStore - maybe appNotFound continuation (H.lookup sessionId appStore) + case H.lookup sessionId appStore of + Nothing -> + appNotFound sessionId + Just (_, state) -> + continuation state where - appNotFound = pure () - sessionNotFound = pure () + appNotFound sessionId = do + logError "A Session exists but no debugger has been registered" + let err = concat + [ "SessionID: " <> unpack sessionId + , "has no corresponding Debugger registered" + ] + liftIO $ throwIO (DebugSessionIdException err) + sessionNotFound = + logWarn "No Debug Session has started" +---------------------------------------------------------------------------- +-- | Whenever a debug Session ends (cleanly or otherwise) this function +-- will remove the local debugger communication state from the global state +---------------------------------------------------------------------------- +destroyDebugSession :: AdaptorClient app () +destroyDebugSession = do + getDebugSessionId >>= \case + Nothing -> sessionNotFound + Just sessionId -> do + appStoreTVar <- getAppStore + appStore <- liftIO (readTVarIO appStoreTVar) + case H.lookup sessionId appStore of + Nothing -> sessionNotFound + Just (tid, state) -> do + killThread tid + liftIO . atomically $ modifyTVar' appStoreTVar (H.delete sessionId) + logInfo $ BL8.pack $ "SessionId " <> unpack sessionId <> " ended" + where + sessionNotFound = + logWarn "No Debug Session has started" ---------------------------------------------------------------------------- getAppStore :: AdaptorClient app (AppStore app) getAppStore = gets adaptorAppStore @@ -130,11 +218,24 @@ send action = do payload <- object <$> gets adaptorPayload -- Send payload to client from debug adaptor - sendMessage address handle payload + writeToHandle address handle payload -- Reset payload each time a send occurs resetAdaptorStatePayload ---------------------------------------------------------------------------- +-- | Writes payload to the given 'Handle' using the local connection lock +---------------------------------------------------------------------------- +writeToHandle + :: ToJSON event + => SockAddr + -> Handle + -> event + -> AdaptorClient app () +writeToHandle addr handle evt = do + let msg = encodeBaseProtocolMessage evt + logDebug SENT ("\n" <> encodePretty evt) + withConnectionLock (BS.hPutStr handle msg) +---------------------------------------------------------------------------- -- | Resets Adaptor's payload ---------------------------------------------------------------------------- resetAdaptorStatePayload :: AdaptorClient app () @@ -215,3 +316,29 @@ setField key value = do { adaptorPayload = (key .= value) : payload } ---------------------------------------------------------------------------- +withConnectionLock + :: IO () + -> AdaptorClient app () +withConnectionLock action = do + lock <- gets handleLock + liftIO (withLock lock action) +---------------------------------------------------------------------------- +-- | Attempt to parse arguments from the Request +---------------------------------------------------------------------------- +getArguments + :: (Show value, FromJSON value) + => AdaptorClient app value +getArguments = do + maybeArgs <- gets (args . request) + let msg = "No args found for this message" + case maybeArgs of + Nothing -> do + logError (BL8.pack msg) + liftIO $ throwIO (ExpectedArguments msg) + Just val -> + case fromJSON val of + Success r -> pure r + x -> do + logError (BL8.pack (show x)) + liftIO $ throwIO (ParseException (show x)) +---------------------------------------------------------------------------- diff --git a/dap/src/DAP/Internal.hs b/dap/src/DAP/Internal.hs index f97377c..bcc8831 100644 --- a/dap/src/DAP/Internal.hs +++ b/dap/src/DAP/Internal.hs @@ -8,21 +8,33 @@ -- Portability : non-portable -- Description : Internal functions for consumption by other modules like Server.hs ---------------------------------------------------------------------------- -module DAP.Internal where +module DAP.Internal + ( withLock + , withGlobalLock + ) where ---------------------------------------------------------------------------- import Control.Concurrent ( modifyMVar_, newMVar, MVar ) import System.IO.Unsafe ( unsafePerformIO ) ---------------------------------------------------------------------------- --- | Used for logging in the presence of multiple threads +-- | Used for logging in the presence of multiple threads. lock :: MVar () {-# NOINLINE lock #-} lock = unsafePerformIO $ newMVar () ---------------------------------------------------------------------------- -- | Used for performing actions (e.g. printing debug logs to stdout) +-- Also used for writing to each connections Handle. +-- Ensures operations occur one thread at a time. +-- +-- Used internally only +-- +withLock :: MVar () -> IO () -> IO () +withLock mvar action = modifyMVar_ mvar $ \x -> x <$ action +---------------------------------------------------------------------------- +-- | Used for performing actions (e.g. printing debug logs to stdout) -- Ensures operations occur one thread at a time. -- -- Used internally only -- withGlobalLock :: IO () -> IO () -withGlobalLock action = modifyMVar_ lock $ \x -> x <$ action +withGlobalLock = withLock lock ---------------------------------------------------------------------------- diff --git a/dap/src/DAP/Response.hs b/dap/src/DAP/Response.hs index 204ec1f..2413590 100644 --- a/dap/src/DAP/Response.hs +++ b/dap/src/DAP/Response.hs @@ -17,33 +17,46 @@ module DAP.Response ( -- * Response message API sendAttachResponse + , sendBreakpointLocationsResponse + , sendCompletionsResponse + , sendConfigurationDoneResponse + , sendContinueResponse + , sendDataBreakpointInfoResponse + , sendDisassembleResponse + , sendDisconnectResponse + , sendEvaluateResponse + , sendExceptionInfoResponse + , sendGotoResponse + , sendGotoTargetsResponse + , sendInitializeResponse + , sendLaunchResponse + , sendLoadedSourcesResponse , sendModulesResponse - , sendBreakpointsLocationResponse - , sendSetDataBreakpointsResponse + , sendNextResponse + , sendPauseResponse + , sendReadMemoryResponse + , sendRestartResponse + , sendRestartFrameResponse + , sendReverseContinueResponse + , sendScopesResponse , sendSetBreakpointsResponse - , sendSetFunctionBreakpointsResponse + , sendSetDataBreakpointsResponse , sendSetExceptionBreakpointsResponse + , sendSetExpressionResponse + , sendSetFunctionBreakpointsResponse , sendSetInstructionBreakpointsResponse - , sendContinueResponse - , sendConfigurationDoneResponse - , sendLaunchResponse - , sendRestartResponse - , sendDisconnectResponse - , sendTerminateResponse - , sendNextResponse + , sendSetVariableResponse + , sendSourceResponse + , sendStackTraceResponse + , sendStepBackResponse , sendStepInResponse + , sendStepInTargetsResponse , sendStepOutResponse - , sendStepBackResponse - , sendReverseContinueResponse - , sendRestartFrameResponse - , sendGotoResponse - , sendPauseResponse - , sendInitializedResponse - , sendThreadsResponse + , sendTerminateResponse , sendTerminateThreadsResponse - , sendStackTraceResponse - , sendSourceResponse - , sendLoadedSourcesResponse + , sendThreadsResponse + , sendVariablesResponse + , sendWriteMemoryResponse ) where ---------------------------------------------------------------------------- import DAP.Adaptor @@ -54,10 +67,10 @@ sendAttachResponse :: AdaptorClient app () sendAttachResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | BreakpointLocationResponse has no body by default -sendBreakpointsLocationResponse +sendBreakpointLocationsResponse :: [BreakpointLocation] -> AdaptorClient app () -sendBreakpointsLocationResponse +sendBreakpointLocationsResponse = sendSuccesfulResponse . setBody . Breakpoints @@ -170,13 +183,10 @@ sendRestartFrameResponse :: AdaptorClient app () sendRestartFrameResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- --- | InitializedReponse --- --- 'Capabilities' is present in the `ServerConfig` when the DAP server starts --- This function reads the global 'Capabilities' from the 'ServerConfig' -sendInitializedResponse +-- | InitializeReponse +sendInitializeResponse :: AdaptorClient app () -sendInitializedResponse = do +sendInitializeResponse = do capabilities <- getServerCapabilities sendSuccesfulResponse (setBody capabilities) ---------------------------------------------------------------------------- @@ -185,6 +195,11 @@ sendGotoResponse :: AdaptorClient app () sendGotoResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- +-- | GotoTargetsResponse +sendGotoTargetsResponse + :: AdaptorClient app () +sendGotoTargetsResponse = sendSuccesfulEmptyResponse +---------------------------------------------------------------------------- -- | PauseResponse sendPauseResponse :: AdaptorClient app () @@ -210,3 +225,39 @@ sendThreadsResponse = sendSuccesfulResponse . setBody . ThreadsResponse sendLoadedSourcesResponse :: [Source] -> AdaptorClient app () sendLoadedSourcesResponse = sendSuccesfulResponse . setBody . LoadedSourcesResponse ---------------------------------------------------------------------------- +sendWriteMemoryResponse :: WriteMemoryResponse -> AdaptorClient app () +sendWriteMemoryResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendReadMemoryResponse :: ReadMemoryResponse -> AdaptorClient app () +sendReadMemoryResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendCompletionsResponse :: CompletionsResponse -> AdaptorClient app () +sendCompletionsResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendDataBreakpointInfoResponse :: DataBreakpointInfoResponse -> AdaptorClient app () +sendDataBreakpointInfoResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendDisassembleResponse :: DisassembleResponse -> AdaptorClient app () +sendDisassembleResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendEvaluateResponse :: EvaluateResponse -> AdaptorClient app () +sendEvaluateResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendExceptionInfoResponse :: ExceptionInfoResponse -> AdaptorClient app () +sendExceptionInfoResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendScopesResponse :: ScopesResponse -> AdaptorClient app () +sendScopesResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendSetExpressionResponse :: SetExpressionResponse -> AdaptorClient app () +sendSetExpressionResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendSetVariableResponse :: SetVariableResponse -> AdaptorClient app () +sendSetVariableResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendStepInTargetsResponse :: StepInTargetsResponse -> AdaptorClient app () +sendStepInTargetsResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- +sendVariablesResponse :: VariablesResponse -> AdaptorClient app () +sendVariablesResponse = sendSuccesfulResponse . setBody +---------------------------------------------------------------------------- diff --git a/dap/src/DAP/Server.hs b/dap/src/DAP/Server.hs index d4a953f..c6eff8a 100644 --- a/dap/src/DAP/Server.hs +++ b/dap/src/DAP/Server.hs @@ -20,6 +20,9 @@ module DAP.Server ( runDAPServer ) where ---------------------------------------------------------------------------- +import Control.Monad (when) +import Data.IORef ( newIORef, atomicWriteIORef ) +import Control.Concurrent.MVar ( newMVar ) import Control.Concurrent.STM ( newTVarIO ) import Control.Exception ( SomeException , IOException @@ -46,6 +49,8 @@ import qualified Data.ByteString.Char8 as BS ---------------------------------------------------------------------------- import DAP.Types import DAP.Internal +import DAP.Utils +import DAP.Adaptor ---------------------------------------------------------------------------- runDAPServer :: ServerConfig @@ -55,22 +60,25 @@ runDAPServer -> IO () runDAPServer serverConfig@ServerConfig {..} communicate = withSocketsDo $ do putStrLn ("Running DAP server on " <> show port <> "...") + appStore <- newTVarIO mempty serve (Host host) (show port) $ \(socket, address) -> do withGlobalLock (putStrLn $ "TCP connection established from " ++ show address) handle <- socketToHandle socket ReadWriteMode hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF } - appStore <- newTVarIO mempty - let sessionId = Nothing + connectionLock <- newMVar () + seqRef <- newIORef 0 + sessionRef <- newIORef Nothing flip catch (exceptionHandler handle address) $ forever $ do request <- getRequest handle address - let adaptorState = mkAdaptorState appStore request handle address + atomicWriteIORef seqRef (requestSeqNum request) + let adaptorState = mkAdaptorState appStore request handle address seqRef connectionLock sessionRef runAdaptorClient adaptorState $ communicate (command request) where ---------------------------------------------------------------------------- -- | Makes empty adaptor state - mkAdaptorState appStore request handle address + mkAdaptorState appStore request handle address seqRef connectionLock sessionRef = AdaptorState MessageTypeResponse [] appStore serverConfig - (requestSeqNum request) handle request address Nothing + seqRef handle request address sessionRef connectionLock ---------------------------------------------------------------------------- -- | Utility for evaluating a monad transformer stack runAdaptorClient :: AdaptorState app -> AdaptorClient app a -> IO a @@ -80,17 +88,20 @@ runDAPServer serverConfig@ServerConfig {..} communicate = withSocketsDo $ do exceptionHandler :: Handle -> SockAddr -> SomeException -> IO () exceptionHandler handle address (e :: SomeException) = do let - logError + dumpError | Just (ParseException msg) <- fromException e - = putStrLn ("Parse Exception encountered: " <> msg) + = logger ERROR address Nothing + $ withBraces + $ BL8.pack ("Parse Exception encountered: " <> msg) | Just (err :: IOException) <- fromException e, isEOFError err - = putStrLn "Empty payload received" - | otherwise = do - putStrLn "Unknown Exception" - print e - withGlobalLock $ do - logError - putStrLn ("Closing connection: " <> show address) + = logger ERROR address Nothing + $ withBraces "Empty payload received" + | otherwise + = logger ERROR address Nothing + $ withBraces + $ BL8.pack ("Unknown Exception: " <> show e) + dumpError + logger ERROR address Nothing "[Closing Connection]" hClose handle ---------------------------------------------------------------------------- -- | Internal function for parsing a 'ProtocolMessage' header @@ -104,15 +115,17 @@ runDAPServer serverConfig@ServerConfig {..} communicate = withSocketsDo $ do headerBytes <- BS.hGetLine handle void (BS.hGetLine handle) parseHeader headerBytes >>= \case - Left errorMessage -> + Left errorMessage -> do + logger ERROR addr Nothing (BL8.pack errorMessage) throwIO (ParseException errorMessage) Right count -> do body <- BS.hGet handle count - withGlobalLock $ do - putStrLn $ "[RECEIVED][" <> show addr <> "]" - BL8.putStrLn $ encodePretty (decodeStrict body :: Maybe Value) + when debugLogging $ do + logger DEBUG addr (Just RECEIVED) + ("\n" <> encodePretty (decodeStrict body :: Maybe Value)) case eitherDecode (BL8.fromStrict body) of - Left couldn'tDecodeBody -> + Left couldn'tDecodeBody -> do + logger ERROR addr Nothing (BL8.pack couldn'tDecodeBody) throwIO (ParseException couldn'tDecodeBody) Right request -> pure request diff --git a/dap/src/DAP/Types.hs b/dap/src/DAP/Types.hs index 5b3be82..ed4f1ad 100644 --- a/dap/src/DAP/Types.hs +++ b/dap/src/DAP/Types.hs @@ -10,6 +10,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveAnyClass #-} @@ -60,6 +61,16 @@ module DAP.Types , ValueFormat (..) , Variable (..) , VariablePresentationHint (..) + , ColumnDescriptorType (..) + , ScopePresentationHint (..) + , PresentationHintKind (..) + , PresentationHintAttributes (..) + , PresentationHintVisibility (..) + , EventGroup (..) + , EventReason (..) + , StartMethod (..) + , EvaluateArgumentsContext (..) + , PathFormat (..) -- * Command , Command (..) -- * Event @@ -98,12 +109,25 @@ module DAP.Types , Seq , SessionId -- * Responses + , CompletionsResponse (..) , ContinueResponse (..) + , DataBreakpointInfoResponse (..) + , DisassembleResponse (..) + , EvaluateResponse (..) + , ExceptionInfoResponse (..) + , GotoTargetsResponse (..) + , LoadedSourcesResponse (..) , ModulesResponse (..) - , StackTraceResponse (..) + , ReadMemoryResponse (..) + , ScopesResponse (..) + , SetExpressionResponse (..) + , SetVariableResponse (..) , SourceResponse (..) + , StackTraceResponse (..) + , StepInTargetsResponse (..) , ThreadsResponse (..) - , LoadedSourcesResponse (..) + , VariablesResponse (..) + , WriteMemoryResponse (..) -- * Arguments , AttachRequestArguments (..) , BreakpointLocationsArguments (..) @@ -148,39 +172,54 @@ module DAP.Types , WriteMemoryArguments (..) -- * defaults , defaultCapabilities + -- * Log level + , Level (..) + , DebugStatus (..) ) where ---------------------------------------------------------------------------- -import Data.Typeable ( typeRep ) -import Control.Concurrent.STM ( TVar, newTVarIO ) -import Control.Exception ( Exception ) -import Control.Monad.State ( StateT, MonadState, MonadIO ) -import Data.Aeson ( (.:), (.:?), withObject, withText, object - , FromJSON(parseJSON), Value(Null), KeyValue((.=)) - , ToJSON(toJSON), fieldLabelModifier - , genericParseJSON, genericToJSON, defaultOptions - ) -import Data.Aeson.Types ( Pair, typeMismatch ) -import Data.IORef ( IORef ) -import Data.Proxy ( Proxy(Proxy) ) -import Data.String ( IsString(..) ) -import Data.Time ( UTCTime ) -import GHC.Generics ( Generic ) -import Network.Socket ( SockAddr ) -import System.IO ( Handle ) -import Text.Read ( readMaybe ) -import Data.Text (Text) -import qualified Data.Text as T ( pack, unpack ) -import qualified Data.HashMap.Strict as H -import GHC.TypeLits (TypeError) -import qualified GHC.TypeLits as TypeLits ----------------------------------------------------------------------------- -import DAP.Utils ( capitalize, enumToLowerCamel, toLowerCase, modifier, getName, genericParseJSONWithModifier, genericToJSONWithModifier ) +import Control.Monad.Base ( MonadBase ) +import Control.Monad.Trans.Control ( MonadBaseControl ) +import Control.Concurrent ( ThreadId ) +import Control.Concurrent.MVar ( MVar ) +import Control.Applicative ( (<|>) ) +import Data.Typeable ( typeRep ) +import Control.Concurrent.STM ( TVar, newTVarIO ) +import Control.Exception ( Exception ) +import Control.Monad.State ( StateT, MonadState, MonadIO ) +import Data.Aeson ( (.:), (.:?), withObject, withText, object + , FromJSON(parseJSON), Value(Null), KeyValue((.=)) + , ToJSON(toJSON), fieldLabelModifier + , genericParseJSON, genericToJSON, defaultOptions + ) +import Data.Aeson.Types ( Pair, typeMismatch ) +import Data.IORef ( IORef ) +import Data.Proxy ( Proxy(Proxy) ) +import Data.String ( IsString(..) ) +import Data.Time ( UTCTime ) +import GHC.Generics ( Generic ) +import Network.Socket ( SockAddr ) +import System.IO ( Handle ) +import Text.Read ( readMaybe ) +import Data.Text (Text) +import qualified Data.Text as T ( pack, unpack ) +import qualified Data.HashMap.Strict as H +import GHC.TypeLits (TypeError) +import qualified GHC.TypeLits as TypeLits +---------------------------------------------------------------------------- +import DAP.Utils ( capitalize, enumToLowerCamel, toLowerCase, modifier, getName, genericParseJSONWithModifier, genericToJSONWithModifier ) ---------------------------------------------------------------------------- -- | Core type for Debug Adaptor to send and receive messages in a type safe way. -- the state is 'AdaptorState' which holds configuration information, along with -- the current event / response being constructed and the type of the message. +-- Of note: A 'StateT' is used because 'adaptorPayload' should not be shared +-- with other threads. newtype AdaptorClient store a = AdaptorClient (StateT (AdaptorState store) IO a) - deriving newtype (Monad, MonadIO, Applicative, Functor, MonadState (AdaptorState store) ) + deriving newtype + ( Monad + , MonadIO, Applicative, Functor, MonadState (AdaptorState store) + , MonadBaseControl IO + , MonadBase IO + ) ---------------------------------------------------------------------------- -- | The adaptor state is local to a single connection / thread data AdaptorState app @@ -192,6 +231,8 @@ data AdaptorState app -- , adaptorPayload :: ![Pair] -- ^ Payload of the current message to be sent + -- This should never be manually modified by the end user + -- The payload is accumulated automatically by usage of the API -- , adaptorAppStore :: AppStore app -- ^ Global app store, accessible on a per session basis @@ -201,7 +242,7 @@ data AdaptorState app -- ^ Configuration information for the ServerConfig -- Identical across all debugging sessions -- - , seqNum :: !Seq + , seqRef :: IORef Seq -- ^ Thread local sequence number, updating as responses and events are set -- , handle :: Handle @@ -213,15 +254,22 @@ data AdaptorState app , address :: SockAddr -- ^ Address of Connection -- - , sessionId :: Maybe SessionId + , sessionId :: IORef (Maybe SessionId) -- ^ Session ID + -- Local to the current connection's debugger session + -- + , handleLock :: MVar () + -- ^ A lock for writing to a Handle exists for each new connection -- } ---------------------------------------------------------------------------- type SessionId = Text ---------------------------------------------------------------------------- -- | Used to store a map of debugging sessions -type AppStore app = TVar (H.HashMap SessionId app) +-- The 'ThreadId' is meant to be an asynchronous operation that +-- allows initalized debuggers to emit custom events +-- when they receive messages from the debugger +type AppStore app = TVar (H.HashMap SessionId (ThreadId, app)) ---------------------------------------------------------------------------- data ServerConfig = ServerConfig @@ -232,7 +280,11 @@ data ServerConfig } deriving stock (Show, Eq) ---------------------------------------------------------------------------- -- | Used to signify a malformed message has been received -data ParseException = ParseException String +data ParseException + = ParseException String + | ExpectedArguments String + | DebugSessionIdException String + | DebuggerException String deriving stock (Show, Eq) deriving anyclass Exception ---------------------------------------------------------------------------- @@ -242,10 +294,10 @@ data MessageType = MessageTypeEvent | MessageTypeResponse | MessageTypeRequest - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance ToJSON MessageType where - toJSON = enumToLowerCamel (Proxy @MessageType) + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- type Seq = Int ---------------------------------------------------------------------------- @@ -322,22 +374,10 @@ data Breakpoint -- The offset from the instruction reference. -- This can be negative. -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance ToJSON Breakpoint where - toJSON Breakpoint {..} = - object - [ "id" .= breakpointId - , "verified" .= breakpointVerified - , "message" .= breakpointMessage - , "source" .= breakpointSource - , "line" .= breakpointLine - , "column" .= breakpointColumn - , "endLine" .= breakpointEndLine - , "endColumn" .= breakpointEndColumn - , "instructionReference" .= breakpointInstructionReference - , "offset" .= breakpointOffset - ] + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- newtype Breakpoints breakpoint = Breakpoints [breakpoint] deriving stock (Show, Eq) @@ -400,14 +440,10 @@ data Source } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance FromJSON Source where - parseJSON = genericParseJSON defaultOptions { - fieldLabelModifier = modifier (Proxy @Source) - } + parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- instance ToJSON Source where - toJSON = genericToJSON defaultOptions { - fieldLabelModifier = modifier (Proxy @Source) - } + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- newtype Sources = Sources { getSources :: [Source] } deriving stock (Show, Eq) ---------------------------------------------------------------------------- @@ -416,40 +452,32 @@ instance ToJSON Sources where toJSON (Sources s) = object [ "sources" .= s ] data SourcePresentationHint = SourcePresentationHintNormal | SourcePresentationHintEmphasize - | SourcePresentationHintDeEmphasize - deriving stock (Show, Eq) ----------------------------------------------------------------------------- -instance ToJSON SourcePresentationHint where - toJSON SourcePresentationHintNormal = "normal" - toJSON SourcePresentationHintEmphasize = "emphasize" - toJSON SourcePresentationHintDeEmphasize = "deemphasize" + | SourcePresentationHintDeemphasize + deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance FromJSON SourcePresentationHint where - parseJSON = withText "SourcePresentationHint" $ \txt -> - case txt of - "normal" -> pure SourcePresentationHintNormal - "emphasize" -> pure SourcePresentationHintEmphasize - "deemphasize" -> pure SourcePresentationHintDeEmphasize - s -> typeMismatch "SourcePresentationHint" (toJSON s) + parseJSON = genericParseJSONWithModifier +---------------------------------------------------------------------------- +instance ToJSON SourcePresentationHint where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- --- | presentationHint?: 'normal' | 'label' | 'subtle'; data PresentationHint = PresentationHintNormal | PresentationHintLabel | PresentationHintSubtle - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance ToJSON PresentationHint where - toJSON = enumToLowerCamel (Proxy @PresentationHint) + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data Checksum = Checksum { algorithm :: ChecksumAlgorithm - -- ^ The algorithm used to calculate this checksum. - -- + -- ^ The algorithm used to calculate this checksum. + -- , checksum :: Text - -- ^ Value of the checksum, encoded as a hexadecimal value. - -- + -- ^ Value of the checksum, encoded as a hexadecimal value. + -- } deriving stock (Show, Eq, Generic) deriving anyclass (ToJSON, FromJSON) ---------------------------------------------------------------------------- @@ -479,65 +507,65 @@ instance FromJSON ChecksumAlgorithm where data StackFrame = StackFrame { stackFrameId :: Int - -- ^ - -- An identifier for the stack frame. It must be unique across all threads. - -- This id can be used to retrieve the scopes of the frame with the `scopes` - -- request or to restart the execution of a stack frame. - -- + -- ^ + -- An identifier for the stack frame. It must be unique across all threads. + -- This id can be used to retrieve the scopes of the frame with the `scopes` + -- request or to restart the execution of a stack frame. + -- , stackFrameName :: Text - -- ^ - -- The name of the stack frame, typically a method name. - -- + -- ^ + -- The name of the stack frame, typically a method name. + -- , stackFrameSource :: Source - -- ^ - -- The source of the frame. - -- + -- ^ + -- The source of the frame. + -- , stackFrameLine :: Int - -- ^ - -- The line within the source of the frame. If the source attribute is missing - -- or doesn't exist, `line` is 0 and should be ignored by the client. - -- + -- ^ + -- The line within the source of the frame. If the source attribute is missing + -- or doesn't exist, `line` is 0 and should be ignored by the client. + -- , stackFrameColumn :: Int - -- ^ - -- Start position of the range covered by the stack frame. It is measured in - -- UTF-16 code units and the client capability `columnsStartAt1` determines - -- whether it is 0- or 1-based. If attribute `source` is missing or doesn't - -- exist, `column` is 0 and should be ignored by the client. - -- + -- ^ + -- Start position of the range covered by the stack frame. It is measured in + -- UTF-16 code units and the client capability `columnsStartAt1` determines + -- whether it is 0- or 1-based. If attribute `source` is missing or doesn't + -- exist, `column` is 0 and should be ignored by the client. + -- , stackFrameEndLine :: Int - -- ^ - -- The end line of the range covered by the stack frame. - -- + -- ^ + -- The end line of the range covered by the stack frame. + -- , stackFrameEndColumn :: Int - -- ^ - -- End position of the range covered by the stack frame. It is measured in - -- UTF-16 code units and the client capability `columnsStartAt1` determines - -- whether it is 0- or 1-based. - -- + -- ^ + -- End position of the range covered by the stack frame. It is measured in + -- UTF-16 code units and the client capability `columnsStartAt1` determines + -- whether it is 0- or 1-based. + -- , stackFrameCanRestart :: Bool - -- ^ - -- Indicates whether this frame can be restarted with the `restart` request. - -- Clients should only use this if the debug adapter supports the `restart` - -- request and the corresponding capability `supportsRestartRequest` is true. - -- If a debug adapter has this capability, then `canRestart` defaults to - -- `true` if the property is absent. - -- + -- ^ + -- Indicates whether this frame can be restarted with the `restart` request. + -- Clients should only use this if the debug adapter supports the `restart` + -- request and the corresponding capability `supportsRestartRequest` is true. + -- If a debug adapter has this capability, then `canRestart` defaults to + -- `true` if the property is absent. + -- , stackFrameInstructionPointerReference :: Maybe Text - -- ^ - -- A memory reference for the current instruction pointer in this frame. - -- + -- ^ + -- A memory reference for the current instruction pointer in this frame. + -- , stackFrameModuleId :: Maybe (Either Int Text) - -- ^ - -- The module associated with this frame, if any. - -- + -- ^ + -- The module associated with this frame, if any. + -- , stackFramePresentationHint :: Maybe PresentationHint - -- ^ - -- A hint for how to present this frame in the UI. - -- A value of `label` can be used to indicate that the frame is an artificial - -- frame that is used as a visual label or separator. A value of `subtle` can - -- be used to change the appearance of a frame in a 'subtle' way. - -- Values: 'normal', 'label', 'subtle' - -- + -- ^ + -- A hint for how to present this frame in the UI. + -- A value of `label` can be used to indicate that the frame is an artificial + -- frame that is used as a visual label or separator. A value of `subtle` can + -- be used to change the appearance of a frame in a 'subtle' way. + -- Values: 'normal', 'label', 'subtle' + -- } deriving stock (Show, Eq) ---------------------------------------------------------------------------- instance ToJSON StackFrame where @@ -560,25 +588,18 @@ instance ToJSON StackFrame where data Thread = Thread { threadId :: Int - -- ^ Unique identifier for the thread. - -- + -- ^ Unique identifier for the thread. + -- , threadName :: Text - -- ^ The name of the thread. - -- - } deriving stock (Show, Eq) + -- ^ The name of the thread. + -- + } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance ToJSON Thread where - toJSON Thread {..} - = object - [ "id" .= threadId - , "name" .= threadName - ] + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- instance FromJSON Thread where - parseJSON = withObject "Thread" $ \o -> - Thread - <$> o .: "id" - <*> o .: "name" + parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- defaultCapabilities :: Capabilities defaultCapabilities = capabilities @@ -854,14 +875,14 @@ data ErrorMessage = ErrorMessageCancelled | ErrorMessageNotStopped | ErrorMessageCustom Text - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance IsString ErrorMessage where fromString = ErrorMessageCustom . T.pack ---------------------------------------------------------------------------- instance ToJSON ErrorMessage where toJSON (ErrorMessageCustom e) = toJSON e - toJSON msg = enumToLowerCamel (Proxy @Command) msg + toJSON msg = genericToJSONWithModifier msg ---------------------------------------------------------------------------- data BreakpointLocation = BreakpointLocation @@ -1265,7 +1286,8 @@ data VariablesResponse -- ^ -- All (or a range) of variables for the given variable reference. -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) + deriving anyclass ToJSON ---------------------------------------------------------------------------- data Variable = Variable @@ -1597,7 +1619,10 @@ data EvaluateResponse -- This attribute should be returned by a debug adapter if corresponding -- capability `supportsMemoryReferences` is true. -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON EvaluateResponse where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data SetExpressionResponse = SetExpressionResponse @@ -1637,7 +1662,10 @@ data SetExpressionResponse -- UI and fetch them in chunks. -- The value should be less than or equal to 2147483647 (2^31-1). -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON SetExpressionResponse where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data StepInTargetsResponse = StepInTargetsResponse @@ -1645,7 +1673,10 @@ data StepInTargetsResponse -- ^ -- The possible step-in targets of the specified source location. -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON StepInTargetsResponse where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data StepInTarget = StepInTarget @@ -1676,7 +1707,10 @@ data StepInTarget -- UTF-16 code units and the client capability `columnsStartAt1` determines -- whether it is 0- or 1-based. -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON StepInTarget where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data GotoTargetsResponse = GotoTargetsResponse @@ -1684,49 +1718,45 @@ data GotoTargetsResponse -- ^ -- The possible goto targets of the specified location. -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON GotoTargetsResponse where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data GotoTarget = GotoTarget { gotoTargetId :: Int -- ^ -- Unique identifier for a goto target. This is used in the `goto` request. - , gotoTargetLabel :: String - -- /---- - -- -- The name of the goto target (shown in the UI). - -- --/ - - - -- /---- - -- -- The line of the goto target. - -- --/ - -- line: number; - - -- /---- - -- -- The column of the goto target. - -- --/ - -- column?: number; - - -- /---- - -- -- The end line of the range covered by the goto target. - -- --/ - -- endLine?: number; - - -- /---- - -- -- The end column of the range covered by the goto target. - -- --/ - -- endColumn?: number; - - -- /---- - -- -- A memory reference for the instruction pointer value represented by this - -- -- target. - -- --/ - -- instructionPointerReference?: string; - -- -- ^ - -- -- The possible goto targets of the specified location. - -- -- - } deriving stock (Show, Eq) + -- ^ + -- The name of the goto target (shown in the UI). + -- + , gotoTargetLine :: Int + -- ^ + -- The line of the gotoTarget target. + -- + , gotoTargetColumn :: Maybe Int + -- ^ + -- The column of the gotoTarget target. + -- + , gotoTargetEndLine :: Int + -- ^ + -- The end line of the range covered by the gotoTarget target. + -- + , gotoTargetEndColumn :: Maybe Int + -- ^ + -- The end column of the range covered by the gotoTarget target. + -- + , gotoTargetInstructionPointerReference :: Maybe String + -- ^ + -- A memory reference for the instruction pointer value represented by this + -- target. + -- + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON GotoTarget where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data CompletionsResponse = CompletionsResponse @@ -1734,7 +1764,10 @@ data CompletionsResponse -- ^ -- The possible completions for . -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON CompletionsResponse where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data CompletionItem = CompletionItem @@ -1793,6 +1826,12 @@ data CompletionItem -- } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- +instance ToJSON CompletionItem where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- +instance ToJSON CompletionItemType where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- data ExceptionInfoResponse = ExceptionInfoResponse { exceptionInfoResponseId :: Text @@ -1811,16 +1850,58 @@ data ExceptionInfoResponse -- ^ -- Detailed information about the exception. -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- -data ExceptionBreakMode = ExceptionBreakMode +instance ToJSON ExceptionInfoResponse where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- +data ExceptionBreakMode + = Never + | Always + | Unhandled + | UserUnhandled deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- +instance ToJSON ExceptionBreakMode where + toJSON Never = "never" + toJSON Always = "always" + toJSON Unhandled = "unhandled" + toJSON UserUnhandled = "userUnhandled" +---------------------------------------------------------------------------- instance FromJSON ExceptionBreakMode where parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- -data ExceptionDetails = ExceptionDetails - deriving stock (Show, Eq) +data ExceptionDetails + = ExceptionDetails + { exceptionDetailsMessage :: String + -- ^ + -- Message contained in the exception. + -- + , exceptionDetailstypeName :: Maybe Text + -- ^ + -- Short type name of the exception object. + -- + , exceptionDetailsFullTypeName :: Maybe Text + -- ^ + -- Fully-qualified type name of the exception object. + -- + , exceptionDetailsEvaluateName :: Maybe Text + -- ^ + -- An expression that can be evaluated in the current scope to obtain the + -- exception object. + -- + , exceptionDetailsStackTrace :: Maybe Text + -- ^ + -- Stack trace at the time the exception was thrown. + -- + , exceptionDetailsInnerException :: [ExceptionDetails] + -- ^ + -- Details of the exception contained by this exception, if any. + -- + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON ExceptionDetails where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data ReadMemoryResponse = ReadMemoryResponse @@ -1845,11 +1926,14 @@ data ReadMemoryResponse -- assume it's reached the end of readable memory. -- , readMemoryResponseData :: Maybe Text - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON ReadMemoryResponse where + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data WriteMemoryResponse = WriteMemoryResponse - { writeMemoryResponseOffset:: Maybe Int + { writeMemoryResponseOffset :: Maybe Int -- ^ -- Property that should be returned when `allowPartial` is true to indicate -- the offset of the first byte of data successfully written. Can be @@ -1863,7 +1947,7 @@ data WriteMemoryResponse } deriving stock (Show, Eq) ---------------------------------------------------------------------------- instance ToJSON WriteMemoryResponse where - toJSON WriteMemoryResponse{..} + toJSON WriteMemoryResponse {..} = object [ "offset" .= writeMemoryResponseOffset , "bytesWritten" .= writeMemoryResponseOffset @@ -1927,13 +2011,10 @@ data DisassembledInstruction -- ^ -- The end column of the range that corresponds to this instruction, if any. -- - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance ToJSON DisassembledInstruction where - toJSON DisassembledInstruction {..} - = object - [ -- "" .= - ] + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data StoppedEventReason = StoppedEventReasonStep @@ -2010,8 +2091,8 @@ data StoppedEvent } deriving stock (Show, Eq) ---------------------------------------------------------------------------- instance ToJSON StoppedEvent where - toJSON StoppedEvent{..} = - object + toJSON StoppedEvent{..} + = object [ "reason" .= stoppedEventReason , "description" .= stoppedEventDescription , "threadId" .= stoppedEventThreadId @@ -2720,31 +2801,37 @@ data RestartArguments } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance FromJSON RestartArguments where - parseJSON = genericParseJSONWithModifier + parseJSON = withObject "RestartArguments" $ \o -> do + o .:? "arguments" >>= \case + Nothing -> + pure (RestartArguments Nothing) + Just r -> do + value <- Left <$> parseJSON r <|> Right <$> parseJSON r + pure $ RestartArguments (Just value) ---------------------------------------------------------------------------- data DisconnectArguments = DisconnectArguments { disconnectArgumentsRestart :: Bool - -- ^ - -- A value of true indicates that this `disconnect` request is part of a - -- restart sequence. - -- + -- ^ + -- A value of true indicates that this `disconnect` request is part of a + -- restart sequence. + -- , disconnectArgumentsTerminateDebuggee :: Bool - -- ^ - -- Indicates whether the debuggee should be terminated when the debugger is - -- disconnected. - -- If unspecified, the debug adapter is free to do whatever it thinks is best. - -- The attribute is only honored by a debug adapter if the corresponding - -- capability `supportTerminateDebuggee` is true. - -- + -- ^ + -- Indicates whether the debuggee should be terminated when the debugger is + -- disconnected. + -- If unspecified, the debug adapter is free to do whatever it thinks is best. + -- The attribute is only honored by a debug adapter if the corresponding + -- capability `supportTerminateDebuggee` is true. + -- , disconnectArgumentsSuspendDebuggee :: Bool - -- ^ - -- Indicates whether the debuggee should stay suspended when the debugger is - -- disconnected. - -- If unspecified, the debuggee should resume execution. - -- The attribute is only honored by a debug adapter if the corresponding - -- capability `supportSuspendDebuggee` is true. - -- + -- ^ + -- Indicates whether the debuggee should stay suspended when the debugger is + -- disconnected. + -- If unspecified, the debuggee should resume execution. + -- The attribute is only honored by a debug adapter if the corresponding + -- capability `supportSuspendDebuggee` is true. + -- } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance FromJSON DisconnectArguments where @@ -3096,7 +3183,7 @@ data StepInArguments -- ^ -- If this flag is true, all other suspended threads are not resumed. -- - , stepInArgumentsTargetId:: Maybe Int + , stepInArgumentsTargetId :: Maybe Int -- ^ -- Id of the target to step into. -- @@ -3277,11 +3364,11 @@ instance FromJSON StackFrameFormat where data ScopesArguments = ScopesArguments { scopesArgumentsFrameId :: Int - -- ^ - -- Retrieve the scopes for the stack frame identified by `frameId`. The - -- `frameId` must have been obtained in the current suspended state. See - -- 'Lifetime of Object References' in the Overview section for details. - -- + -- ^ + -- Retrieve the scopes for the stack frame identified by `frameId`. The + -- `frameId` must have been obtained in the current suspended state. See + -- 'Lifetime of Object References' in the Overview section for details. + -- } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance FromJSON ScopesArguments where @@ -3730,16 +3817,16 @@ data CompletionItemType -- | An ExceptionBreakpointsFilter is shown in the UI as an filter option for configuring how exceptions are dealt with. data ExceptionBreakpointsFilter = ExceptionBreakpointsFilter - { exceptionBreakpointsFilterFilter :: String + { exceptionBreakpointsFilterFilter :: Text -- ^ -- The internal ID of the filter option. This value is passed to the -- `setExceptionBreakpoints` request. -- - , exceptionBreakpointsFilterLabel :: String + , exceptionBreakpointsFilterLabel :: Text -- ^ -- The name of the filter option. This is shown in the UI. -- - , exceptionBreakpointsFilterDescription :: Maybe String + , exceptionBreakpointsFilterDescription :: Maybe Text -- ^ -- A help text providing additional information about the exception filter. -- This string is typically shown as a hover and can be translated. @@ -3754,7 +3841,7 @@ data ExceptionBreakpointsFilter -- Controls whether a condition can be specified for this filter option. If -- false or missing, a condition can not be set. -- - , exceptionBreakpointsFilterConditionDescription :: Maybe String + , exceptionBreakpointsFilterConditionDescription :: Maybe Text -- ^ -- A help text providing information about the condition. This string is shown -- as the placeholder text for a text box and can be translated. @@ -3778,7 +3865,15 @@ data ConfigurationDoneArguments = ConfigurationDoneArguments instance FromJSON ConfigurationDoneArguments where parseJSON _ = pure ConfigurationDoneArguments ---------------------------------------------------------------------------- -data ThreadsArguments - = ThreadsArguments +data ThreadsArguments = ThreadsArguments deriving stock (Show, Eq) ---------------------------------------------------------------------------- +instance FromJSON ThreadsArguments where + parseJSON _ = pure ThreadsArguments +---------------------------------------------------------------------------- +data Level = DEBUG | INFO | WARN | ERROR + deriving (Show, Eq) +---------------------------------------------------------------------------- +data DebugStatus = SENT | RECEIVED + deriving (Show, Eq) +---------------------------------------------------------------------------- diff --git a/dap/src/DAP/Utils.hs b/dap/src/DAP/Utils.hs index b7d5dfb..a619269 100644 --- a/dap/src/DAP/Utils.hs +++ b/dap/src/DAP/Utils.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,7 +18,7 @@ ---------------------------------------------------------------------------- module DAP.Utils where ---------------------------------------------------------------------------- -import GHC.Generics (Generic, Rep) +import GHC.Generics (Generic, Rep) import Data.Aeson ( ToJSON(toJSON), Value, fieldLabelModifier , genericToJSON, genericParseJSON, fieldLabelModifier , defaultOptions, GToJSON, GFromJSON, Zero, Options @@ -96,9 +101,10 @@ genericToJSONWithModifier :: forall a . (Generic a, GToJSON Zero (Rep a), Typeable a) => a -> Value genericToJSONWithModifier - = genericToJSON defaultOptions { - fieldLabelModifier = modifier (Proxy @a) - } + = genericToJSON defaultOptions + { fieldLabelModifier = modifier (Proxy @a) + , constructorTagModifier = modifier (Proxy @a) + } ---------------------------------------------------------------------------- -- | Used as a fieldLabelModifier when generating aeson parsers -- >>> getName (Proxy @Int) @@ -113,3 +119,7 @@ genericParseJSONWithModifier , constructorTagModifier = modifier (Proxy @a) } ---------------------------------------------------------------------------- +-- | Log formatting util +withBraces :: BL8.ByteString -> BL8.ByteString +withBraces x = "[" <> x <> "]" +---------------------------------------------------------------------------- diff --git a/dap/stack.yaml b/dap/stack.yaml new file mode 100644 index 0000000..bb3a79d --- /dev/null +++ b/dap/stack.yaml @@ -0,0 +1,29 @@ +resolver: lts-20.18 + +packages: + - '.' + +extra-deps: + - souffle-haskell-3.4.0 + - type-errors-pretty-0.0.1.2@sha256:9042b64d1ac2f69aa55690576504a2397ebea8a6a55332242c88f54027c7eb57,2781 + - async-pool-0.9.1@sha256:4015140f896c3f1652b06a679b0ade2717d05557970c283ea2c372a71be2a6a1,1605 + + - git: https://github.com/TeofilC/digest + commit: ac9616b94cb8c4a9e07188d19979a6225ebd5a10 + + - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project + commit: 9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31 + subdirs: + - external-stg + - external-stg-syntax + - external-stg-interpreter + +flags: + digest: + pkg-config: false + +nix: + enable: false + packages: [ zlib bzip2 ] + +allow-newer: true diff --git a/dap/stack.yaml.lock b/dap/stack.yaml.lock new file mode 100644 index 0000000..dc64d68 --- /dev/null +++ b/dap/stack.yaml.lock @@ -0,0 +1,83 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: souffle-haskell-3.4.0@sha256:eff3243641adbc8864bbf4e9f96518695881d73fef434898569413e5ecfcab0e,11625 + pantry-tree: + sha256: 099c0d0fe6f8ff77de2ddab42a5cb3f8b83daa0fbd65512feed4c75e0c7a9132 + size: 5045 + original: + hackage: souffle-haskell-3.4.0 +- completed: + hackage: type-errors-pretty-0.0.1.2@sha256:9042b64d1ac2f69aa55690576504a2397ebea8a6a55332242c88f54027c7eb57,2781 + pantry-tree: + sha256: 9a9076d1392b2423c083964c1e630cb99981dfcd1ada3d2b53d81217198ff576 + size: 339 + original: + hackage: type-errors-pretty-0.0.1.2@sha256:9042b64d1ac2f69aa55690576504a2397ebea8a6a55332242c88f54027c7eb57,2781 +- completed: + hackage: async-pool-0.9.1@sha256:4015140f896c3f1652b06a679b0ade2717d05557970c283ea2c372a71be2a6a1,1605 + pantry-tree: + sha256: 525b46e6a39c80b7461e8cd146d540c27d47abc717b746ff34c21aa9b1c47743 + size: 443 + original: + hackage: async-pool-0.9.1@sha256:4015140f896c3f1652b06a679b0ade2717d05557970c283ea2c372a71be2a6a1,1605 +- completed: + commit: ac9616b94cb8c4a9e07188d19979a6225ebd5a10 + git: https://github.com/TeofilC/digest + name: digest + pantry-tree: + sha256: 0dd2d847aebc95b064a75af09105c8d5c4a4cc92dec48e504c627661ec145c2d + size: 733 + version: 0.0.1.7 + original: + commit: ac9616b94cb8c4a9e07188d19979a6225ebd5a10 + git: https://github.com/TeofilC/digest +- completed: + commit: 9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31 + git: https://github.com/grin-compiler/ghc-whole-program-compiler-project + name: external-stg + pantry-tree: + sha256: 2f87458fec844aff8161c25e8932d7024e909cc56dfc1a1f934f09a28e283bd8 + size: 1084 + subdir: external-stg + version: 0.1.0.1 + original: + commit: 9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31 + git: https://github.com/grin-compiler/ghc-whole-program-compiler-project + subdir: external-stg +- completed: + commit: 9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31 + git: https://github.com/grin-compiler/ghc-whole-program-compiler-project + name: external-stg-syntax + pantry-tree: + sha256: 7839732c99f760c92b6b12dfe90745d07acca1f4282cad04087d9d63db5fecaa + size: 268 + subdir: external-stg-syntax + version: 1.0.1 + original: + commit: 9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31 + git: https://github.com/grin-compiler/ghc-whole-program-compiler-project + subdir: external-stg-syntax +- completed: + commit: 9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31 + git: https://github.com/grin-compiler/ghc-whole-program-compiler-project + name: external-stg-interpreter + pantry-tree: + sha256: d296571bee5b9ce9e7bb3c4f63b59bd1077a1f90881d9e3524e11017fefdcc2a + size: 6662 + subdir: external-stg-interpreter + version: 0.1.0.1 + original: + commit: 9d7a96a0b831f980d8c9d5a30a9185b64fbbfa31 + git: https://github.com/grin-compiler/ghc-whole-program-compiler-project + subdir: external-stg-interpreter +snapshots: +- completed: + sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9 + size: 649606 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml + original: lts-20.18 From 5e5180ded4b00ced3e3d23b487ee32131c0faa69 Mon Sep 17 00:00:00 2001 From: David Johnson Date: Mon, 1 May 2023 19:38:23 -0500 Subject: [PATCH 2/2] Update top-level DAP.hs exports --- dap/src/DAP.hs | 189 ++++++++++++++++++++++++++++++++++++++-- dap/src/DAP/Response.hs | 8 ++ dap/src/DAP/Types.hs | 8 +- 3 files changed, 193 insertions(+), 12 deletions(-) diff --git a/dap/src/DAP.hs b/dap/src/DAP.hs index 3c0cf61..eb86233 100644 --- a/dap/src/DAP.hs +++ b/dap/src/DAP.hs @@ -1,12 +1,185 @@ module DAP - ( module DAP.Adaptor - , module DAP.Event - , module DAP.Internal - , module DAP.Response - , module DAP.Server - , module DAP.Types - ) -where + ( -- * Adaptor + AdaptorClient + , AdaptorState + -- * Adaptor API + , getServerCapabilities + , getArguments + , getAddress + , getRequestSeqNum + , getAppStore + -- * Configuration + , ServerConfig (..) + -- * Logging + , logWarn + , logError + , logInfo + , logger + -- * Debugger Sessions + , AppStore (..) + , registerNewDebugSession + , withDebugSession + , getDebugSessionId + , destroyDebugSession + , setDebugSessionId + -- * Command + , Command (..) + -- * Events + , EventType (..) + --- * Event Operations + , sendBreakpointEvent + , sendCapabilitiesEvent + , sendContinuedEvent + , sendExitedEvent + , sendInitializedEvent + , sendInvalidatedEvent + , sendLoadedSourceEvent + , sendMemoryEvent + , sendModuleEvent + , sendOutputEvent + , sendProcessEvent + , sendProgressEndEvent + , sendProgressStartEvent + , sendProgressUpdateEvent + , sendStoppedEvent + , sendTerminatedEvent + , sendThreadEvent + -- * Request / Response + --- * Attach + , sendAttachResponse + , AttachRequestArguments (..) + --- * BreakpointLocations + , sendBreakpointLocationsResponse + , BreakpointLocationsRequestArguments (..) + --- * Completions + , sendCompletionsResponse + , CompletionsResponse (..) + --- * ConfigurationDone + , sendConfigurationDoneResponse + , ConfigurationDoneResponse (..) + --- * Continue + , sendContinueResponse + , ContinueResponse (..) + --- * DataBreakpointInfo + , sendDataBreakpointInfoResponse + , DataBreakpointInfoResponse (..) + --- * Disassemble + , sendDisassembleResponse + , DisassembleResponse (..) + --- * Disconnect + , sendDisconnectResponse + , DisconnectResponse (..) + --- * Evaluate + , sendEvaluateResponse + , EvaluateResponse (..) + --- * ExceptionInfo + , sendExceptionInfoResponse + , ExceptionInfoResponse (..) + --- * Goto + , sendGotoResponse + , GotoResponse (..) + --- * GotoTargets + , sendGotoTargetsResponse + , GotoTargetsResponse (..) + --- * Initialize + , sendInitializeResponse + , InitializeResponse (..) + --- * Launch + , sendLaunchResponse + , LaunchResponse (..) + --- * LoadedSources + , sendLoadedSourcesResponse + , LoadedSourcesResponse (..) + --- * Modules + , sendModulesResponse + , ModulesResponse (..) + --- * Next + , sendNextResponse + , NextResponse (..) + --- * Pause + , sendPauseResponse + , PauseResponse (..) + --- * ReadMemory + , sendReadMemoryResponse + , ReadMemoryResponse (..) + --- * Restart + , sendRestartResponse + , RestartResponse (..) + --- * RestartFrame + , sendRestartFrameResponse + , RestartFrameResponse (..) + --- * ReverseContinue + , sendReverseContinueResponse + , ReverseContinueResponse (..) + --- * Scopes + , sendScopesResponse + , ScopesResponse (..) + --- * SetBreakpoints + , sendSetBreakpointsResponse + , SetBreakpointsResponse (..) + --- * SetDataBreakpoints + , sendSetDataBreakpointsResponse + , SetDataBreakpointsResponse (..) + --- * SetExceptionBreakpoints + , sendSetExceptionBreakpointsResponse + , SetExceptionBreakpointsResponse (..) + --- * SetExpression + , sendSetExpressionResponse + , SetExpressionResponse (..) + --- * SetFunctionBreakpoints + , sendSetFunctionBreakpointsResponse + , SetFunctionBreakpointsResponse (..) + --- * SetInstructionBreakpoints + , sendSetInstructionBreakpointsResponse + , SetInstructionBreakpointsResponse (..) + --- * SetVariable + , sendSetVariableResponse + , SetVariableResponse (..) + --- * Source + , sendSourceResponse + , SourceResponse (..) + --- * StackTrace + , sendStackTraceResponse + , StackTraceResponse (..) + --- * StepBack + , sendStepBackResponse + , StepBackResponse (..) + --- * StepIn + , sendStepInResponse + , StepInResponse (..) + --- * StepInTargets + , sendStepInTargetsResponse + , StepInTargetsResponse (..) + --- * StepOut + , sendStepOutResponse + , StepOutResponse (..) + --- * Terminate + , sendTerminateResponse + , TerminateResponse (..) + --- * TerminateThreads + , sendTerminateThreadsResponse + , TerminateThreadsResponse (..) + --- * Threads + , sendThreadsResponse + , ThreadsResponse (..) + --- * Variables + , sendVariablesResponse + , VariablesResponse (..) + --- * Write Memory + , sendWriteMemoryResponse + , WriteMemoryResponse (..) + -- * Reverse Requests + --- * RunInTerminal + , RunInTerminalResponse (..) + , sendRunInTerminalResponse + --- * StartDebugging + , StartDebuggingResponse (..) + , sendStartDebuggingResponse + -- * Errors + , sendErrorResponse + , ErrorResponse (..) + , ErrorMessage (..) + ) where import DAP.Adaptor import DAP.Event diff --git a/dap/src/DAP/Response.hs b/dap/src/DAP/Response.hs index 2413590..49b36b7 100644 --- a/dap/src/DAP/Response.hs +++ b/dap/src/DAP/Response.hs @@ -57,6 +57,8 @@ module DAP.Response , sendThreadsResponse , sendVariablesResponse , sendWriteMemoryResponse + , sendRunInTerminalResponse + , sendStartDebuggingResponse ) where ---------------------------------------------------------------------------- import DAP.Adaptor @@ -261,3 +263,9 @@ sendStepInTargetsResponse = sendSuccesfulResponse . setBody sendVariablesResponse :: VariablesResponse -> AdaptorClient app () sendVariablesResponse = sendSuccesfulResponse . setBody ---------------------------------------------------------------------------- +sendRunInTerminalResponse :: RunInTerminalResponse -> AdaptorClient app () +sendRunInTerminalResponse = sendSuccessfulResponse . setBody +---------------------------------------------------------------------------- +sendStartDebuggingResponse :: AdaptorClient app () +sendStartDebuggingResponse = sendSuccesfulEmptyResponse +---------------------------------------------------------------------------- diff --git a/dap/src/DAP/Types.hs b/dap/src/DAP/Types.hs index ed4f1ad..c7a94e6 100644 --- a/dap/src/DAP/Types.hs +++ b/dap/src/DAP/Types.hs @@ -280,7 +280,7 @@ data ServerConfig } deriving stock (Show, Eq) ---------------------------------------------------------------------------- -- | Used to signify a malformed message has been received -data ParseException +data AdaptorException = ParseException String | ExpectedArguments String | DebugSessionIdException String @@ -807,7 +807,7 @@ data EventType deriving stock (Show, Eq, Read) ---------------------------------------------------------------------------- instance ToJSON EventType where - toJSON = enumToLowerCamel (Proxy @EventType) + toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- data Command = CommandCancel @@ -855,7 +855,7 @@ data Command | CommandWriteMemory | CommandDisassemble | CommandUnknown Text - deriving stock (Show, Eq, Read) + deriving stock (Show, Eq, Read, Generic) ---------------------------------------------------------------------------- instance FromJSON Command where parseJSON = withText name $ \command -> @@ -869,7 +869,7 @@ instance FromJSON Command where ---------------------------------------------------------------------------- instance ToJSON Command where toJSON (CommandUnknown x) = toJSON x - toJSON cmd = enumToLowerCamel (Proxy @Command) cmd + toJSON cmd = genericToJSONWithModifier cmd ---------------------------------------------------------------------------- data ErrorMessage = ErrorMessageCancelled