dap (empty) → 0.1.0.0
raw patch · 12 files changed
+5588/−0 lines, 12 filesdep +aesondep +aeson-prettydep +async
Dependencies added: aeson, aeson-pretty, async, base, bytestring, containers, hspec, lifted-base, monad-control, mtl, network, network-simple, stm, string-conversions, text, time, transformers-base, unordered-containers
Files
- CHANGELOG.md +5/−0
- LICENSE +28/−0
- dap.cabal +94/−0
- src/DAP.hs +15/−0
- src/DAP/Adaptor.hs +410/−0
- src/DAP/Event.hs +208/−0
- src/DAP/Internal.hs +39/−0
- src/DAP/Response.hs +270/−0
- src/DAP/Server.hs +184/−0
- src/DAP/Types.hs +4027/−0
- src/DAP/Utils.hs +115/−0
- test/Main.hs +193/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for dap++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2023, haskell-debugger++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ dap.cabal view
@@ -0,0 +1,94 @@+name: dap+version: 0.1.0.0+description: A library for the Debug Adaptor Protocol (DAP)+synopsis: A debug adaptor protocol library+bug-reports: https://github.com/dap/issues+license: BSD3+license-file: LICENSE+author: David Johnson, Csaba Hruska+maintainer: djohnson.m@gmail.com+copyright: (c) 2023 David Johnson+category: Debuggers, Language+build-type: Simple+tested-with: GHC==9.2.7+cabal-version: >= 1.10++extra-source-files:+ CHANGELOG.md++library+ exposed-modules:+ DAP+ other-modules:+ DAP.Adaptor+ DAP.Event+ DAP.Internal+ DAP.Response+ DAP.Server+ DAP.Types+ DAP.Utils+ build-depends:+ aeson >= 2.0.3 && < 2.1,+ aeson-pretty >= 0.8.9 && < 0.9,+ base < 5,+ bytestring >= 0.11.4 && < 0.12,+ containers >= 0.6.5 && < 0.7,+ lifted-base >= 0.2.3 && < 0.3,+ monad-control >= 1.0.3 && < 1.1,+ mtl >= 2.2.2 && < 2.3,+ network >= 3.1.2 && < 3.2,+ network-simple >= 0.4.5 && < 0.5,+ text >= 1.2.5 && < 1.3,+ time >= 1.11.1 && < 1.12,+ unordered-containers >= 0.2.19 && < 0.3,+ stm >= 2.5.0 && < 2.6,+ transformers-base >= 0.4.6 && < 0.5+ ghc-options:+ -Wall+ hs-source-dirs:+ src+ default-language:+ Haskell2010++test-suite tests+ type:+ exitcode-stdio-1.0+ ghc-options:+ -Wall+ hs-source-dirs:+ test, src+ main-is:+ Main.hs+ other-modules:+ DAP.Response+ DAP.Internal+ DAP.Adaptor+ DAP.Server+ DAP.Types+ DAP.Event+ DAP.Utils+ build-depends:+ aeson+ , aeson-pretty+ , async < 2.3+ , base < 5+ , bytestring+ , containers+ , lifted-base+ , monad-control+ , hspec < 2.12+ , mtl+ , network+ , network-simple+ , stm+ , string-conversions < 0.5+ , text+ , time+ , transformers-base+ , unordered-containers+ default-language:+ Haskell2010++source-repository head+ type: git+ location: git://github.com/haskell-debugger/dap.git
+ src/DAP.hs view
@@ -0,0 +1,15 @@+module DAP+ ( module DAP.Adaptor+ , module DAP.Event+ , module DAP.Internal+ , module DAP.Response+ , module DAP.Server+ , module DAP.Types+ ) where++import DAP.Adaptor+import DAP.Event+import DAP.Internal+import DAP.Response+import DAP.Server+import DAP.Types
+ src/DAP/Adaptor.hs view
@@ -0,0 +1,410 @@+-----------------------------------------------------------------------------+-- |+-- Module : DAP.Adaptor+-- Copyright : (C) 2023 David M. Johnson+-- License : BSD3-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+----------------------------------------------------------------------------+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+----------------------------------------------------------------------------+module DAP.Adaptor+ ( -- * Message Construction+ setBody+ , setField+ -- * Response+ , sendSuccesfulEmptyResponse+ , sendSuccesfulResponse+ , sendErrorResponse+ -- * Events+ , sendSuccesfulEvent+ -- * Server+ , getServerCapabilities+ , withConnectionLock+ -- * Request Arguments+ , getArguments+ , getRequestSeqNum+ -- * Debug Session+ , registerNewDebugSession+ , updateDebugSession+ , getDebugSession+ , getDebugSessionId+ , destroyDebugSession+ -- * Error handling+ , sendError+ -- * Logging+ , logWarn+ , logError+ , logInfo+ , logger+ , debugMessage+ -- * Internal use+ , send+ , sendRaw+ -- * Internal function used to execute actions on behalf of the DAP server+ -- from child threads (useful for handling asynchronous debugger events).+ , runAdaptorWith+ ) where+----------------------------------------------------------------------------+import Control.Concurrent.MVar ( modifyMVar_, MVar )+import Control.Concurrent.Lifted ( fork, killThread )+import Control.Exception ( throwIO )+import Control.Concurrent.STM ( atomically, readTVarIO, modifyTVar' )+import Control.Monad ( when, unless )+import Control.Monad.Except ( runExceptT, throwError )+import Control.Monad.State ( runStateT, gets, 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.Text ( unpack, pack )+import Network.Socket ( SockAddr )+import System.IO ( Handle )+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashMap.Strict as H+----------------------------------------------------------------------------+import DAP.Types+import DAP.Utils+import DAP.Internal+----------------------------------------------------------------------------+logWarn :: BL8.ByteString -> Adaptor app ()+logWarn msg = logWithAddr WARN Nothing (withBraces msg)+----------------------------------------------------------------------------+logError :: BL8.ByteString -> Adaptor app ()+logError msg = logWithAddr ERROR Nothing (withBraces msg)+----------------------------------------------------------------------------+logInfo :: BL8.ByteString -> Adaptor app ()+logInfo msg = logWithAddr INFO Nothing (withBraces msg)+----------------------------------------------------------------------------+-- | Meant for internal consumption, used to signify a message has been+-- SENT from the server+debugMessage :: BL8.ByteString -> Adaptor app ()+debugMessage msg = do+ shouldLog <- getDebugLogging+ addr <- getAddress+ liftIO+ $ when shouldLog+ $ logger DEBUG addr (Just SENT) msg+----------------------------------------------------------------------------+-- | Meant for external consumption+logWithAddr :: Level -> Maybe DebugStatus -> BL8.ByteString -> Adaptor 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 formatted+ where+ formatted+ = BL8.concat+ [ withBraces $ BL8.pack (show addr)+ , withBraces $ BL8.pack (show level)+ , maybe mempty (withBraces . BL8.pack . show) maybeDebug+ , msg+ ]+----------------------------------------------------------------------------+getDebugLogging :: Adaptor app Bool+getDebugLogging = gets (debugLogging . serverConfig)+----------------------------------------------------------------------------+getServerCapabilities :: Adaptor app Capabilities+getServerCapabilities = gets (serverCapabilities . serverConfig)+----------------------------------------------------------------------------+getAddress :: Adaptor app SockAddr+getAddress = gets address+----------------------------------------------------------------------------+getHandle :: Adaptor app Handle+getHandle = gets handle+----------------------------------------------------------------------------+getRequestSeqNum :: Adaptor app Seq+getRequestSeqNum = gets (requestSeqNum . request)+----------------------------------------------------------------------------+getDebugSessionId :: Adaptor app SessionId+getDebugSessionId = do+ gets sessionId >>= \case+ Nothing -> sessionNotFound+ Just sessionId -> pure sessionId+ where+ sessionNotFound = do+ let err = "No Debug Session has started"+ sendError (ErrorMessage (pack err)) Nothing+----------------------------------------------------------------------------+setDebugSessionId :: SessionId -> Adaptor app ()+setDebugSessionId session = modify' $ \s -> s { sessionId = Just session }+----------------------------------------------------------------------------+registerNewDebugSession+ :: SessionId+ -> app+ -> IO ()+ -- ^ Action to run debugger (operates in a forked thread that gets killed when disconnect is set)+ -> ((Adaptor app () -> IO ()) -> IO ())+ -- ^ 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.+ --+ -- This event handler thread also takes an argument that allows any child thread to execute+ -- events on behalf of the DAP server (in 'Adaptor app ()'). This function should always be+ -- used when sending events to the editor from the debugger (or from any forked thread).+ --+ -- >+ -- > registerNewDebugSession sessionId appState loadDebugger $ \withAdaptor ->+ -- > forever $ getDebuggerOutput >>= \output -> do+ -- > withAdaptor $ sendOutputEvent defaultOutputEvent { outputEventOutput = output }+ -- >+ --+ -> Adaptor app ()+registerNewDebugSession k v debuggerExecution outputEventSink = do+ store <- gets appStore+ adaptorStateMVar <- gets adaptorStateMVar+ debuggerThreadState <- liftIO $+ DebuggerThreadState+ <$> fork debuggerExecution+ <*> fork (outputEventSink (runAdaptorWith adaptorStateMVar))+ liftIO . atomically $ modifyTVar' store (H.insert k (debuggerThreadState, v))+ setDebugSessionId k+ logInfo $ BL8.pack $ "Registered new debug session: " <> unpack k+----------------------------------------------------------------------------+updateDebugSession :: (app -> app) -> Adaptor app ()+updateDebugSession updateFun = do+ sessionId <- getDebugSessionId+ store <- gets appStore+ liftIO . atomically $ modifyTVar' store (H.adjust (fmap updateFun) sessionId)+----------------------------------------------------------------------------+getDebugSession :: Adaptor a a+getDebugSession = do+ (_, _, app) <- getDebugSessionWithThreadIdAndSessionId+ pure app+----------------------------------------------------------------------------+getDebugSessionWithThreadIdAndSessionId :: Adaptor app (SessionId, DebuggerThreadState, app)+getDebugSessionWithThreadIdAndSessionId = do+ sessionId <- getDebugSessionId+ appStore <- liftIO . readTVarIO =<< getAppStore+ case H.lookup sessionId appStore of+ Nothing -> do+ appNotFound sessionId+ Just (tid, app) ->+ pure (sessionId, tid, app)+ where+ appNotFound sessionId = do+ let err = concat+ [ "SessionID: " <> unpack sessionId+ , "has no corresponding Debugger registered"+ ]+ sendError (ErrorMessage (pack err)) Nothing+----------------------------------------------------------------------------+-- | Whenever a debug Session ends (cleanly or otherwise) this function+-- will remove the local debugger communication state from the global state+----------------------------------------------------------------------------+destroyDebugSession :: Adaptor app ()+destroyDebugSession = do+ (sessionId, DebuggerThreadState {..}, _) <- getDebugSessionWithThreadIdAndSessionId+ store <- getAppStore+ liftIO $ do+ killThread debuggerThread+ killThread debuggerOutputEventThread+ atomically $ modifyTVar' store (H.delete sessionId)+ logInfo $ BL8.pack $ "SessionId " <> unpack sessionId <> " ended"+----------------------------------------------------------------------------+getAppStore :: Adaptor app (AppStore app)+getAppStore = gets appStore+----------------------------------------------------------------------------+getCommand :: Adaptor app Command+getCommand = command <$> gets request+----------------------------------------------------------------------------+-- | 'sendRaw' (internal use only)+-- Sends a raw JSON payload to the editor. No "seq", "type" or "command" fields are set.+-- The message is still encoded with the ProtocolMessage Header, byte count, and CRLF.+--+sendRaw :: ToJSON value => value -> Adaptor app ()+sendRaw value = do+ handle <- getHandle+ address <- getAddress+ writeToHandle address handle value+----------------------------------------------------------------------------+-- | Function for constructing a payload and writing bytes to a socket.+-- This function takes care of incrementing sequence numbers+-- and setting fields automatically that are required for 'response' messages.+-- i.e. "request_seq" and "command".+-- We also have to be sure to reset the message payload+----------------------------------------------------------------------------+send :: Adaptor app () -> Adaptor app ()+send action = do+ () <- action+ cmd <- getCommand+ handle <- getHandle+ messageType <- gets messageType+ address <- getAddress+ requestSeqNum <- getRequestSeqNum+ let seqNum = requestSeqNum + 1++ -- Additional fields are required to be set for 'response' or 'reverse_request' messages.+ when (messageType == MessageTypeResponse) (setField "request_seq" requestSeqNum)+ when (messageType `elem` [MessageTypeResponse, MessageTypeRequest]) (setField "command" cmd)++ -- "seq" and "type" must be set for all protocol messages+ setField "type" messageType+ unless (messageType == MessageTypeEvent) $+ setField "seq" seqNum++ -- Once all fields are set, fetch the payload for sending+ payload <- object <$> gets payload++ -- Send payload to client from debug adaptor+ 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+ -> Adaptor app ()+writeToHandle _ handle evt = do+ let msg = encodeBaseProtocolMessage evt+ debugMessage ("\n" <> encodePretty evt)+ withConnectionLock (BS.hPutStr handle msg)+----------------------------------------------------------------------------+-- | Resets Adaptor's payload+----------------------------------------------------------------------------+resetAdaptorStatePayload :: Adaptor app ()+resetAdaptorStatePayload = modify' $ \s -> s { payload = [] }+----------------------------------------------------------------------------+sendSuccesfulResponse :: Adaptor app () -> Adaptor app ()+sendSuccesfulResponse action = do+ send $ do+ setType MessageTypeResponse+ setSuccess True+ action+----------------------------------------------------------------------------+sendSuccesfulEmptyResponse :: Adaptor app ()+sendSuccesfulEmptyResponse = sendSuccesfulResponse (pure ())+----------------------------------------------------------------------------+-- | Sends successful event+sendSuccesfulEvent :: EventType -> Adaptor app () -> Adaptor app ()+sendSuccesfulEvent event action = do+ send $ do+ setEvent event+ setType MessageTypeEvent+ action+----------------------------------------------------------------------------+-- | Raises an error+-- Meant abort the current reqeust / response cycle, prematurely sending an 'ErrorResponse'+-- <https://microsoft.github.io/debug-adapter-protocol/specification#Base_Protocol_ErrorResponse>+--+sendError+ :: ErrorMessage+ -> Maybe Message+ -> Adaptor app a+sendError errorMessage maybeMessage = do+ throwError (errorMessage, maybeMessage)+----------------------------------------------------------------------------+-- | Sends unsuccessful response+-- Only used internally within the Server module+sendErrorResponse+ :: ErrorMessage+ -> Maybe Message+ -> Adaptor app ()+sendErrorResponse errorMessage maybeMessage = do+ send $ do+ setType MessageTypeResponse+ setSuccess False+ setErrorMessage errorMessage+ setBody (ErrorResponse maybeMessage)+----------------------------------------------------------------------------+setErrorMessage+ :: ErrorMessage+ -> Adaptor app ()+setErrorMessage v = setField "message" v+----------------------------------------------------------------------------+-- | Sends successful event+setSuccess+ :: Bool+ -> Adaptor app ()+setSuccess = setField "success"+----------------------------------------------------------------------------+setBody+ :: ToJSON value+ => value+ -> Adaptor app ()+setBody value = setField "body" value+----------------------------------------------------------------------------+setType+ :: MessageType+ -> Adaptor app ()+setType messageType = do+ modify' $ \adaptorState ->+ adaptorState+ { messageType = messageType+ }+----------------------------------------------------------------------------+setEvent+ :: EventType+ -> Adaptor app ()+setEvent = setField "event"+----------------------------------------------------------------------------+setField+ :: ToJSON value+ => Key+ -> value+ -> Adaptor app ()+setField key value = do+ currentPayload <- gets payload+ modify' $ \adaptorState ->+ adaptorState+ { payload = (key .= value) : currentPayload+ }+----------------------------------------------------------------------------+withConnectionLock+ :: IO ()+ -> Adaptor app ()+withConnectionLock action = do+ lock <- gets handleLock+ liftIO (withLock lock action)+----------------------------------------------------------------------------+-- | Attempt to parse arguments from the Request+----------------------------------------------------------------------------+getArguments+ :: (Show value, FromJSON value)+ => Adaptor 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))++----------------------------------------------------------------------------+-- | Evaluates Adaptor action by using and updating the state in the MVar+runAdaptorWith :: MVar (AdaptorState app) -> Adaptor app () -> IO ()+runAdaptorWith adaptorStateMVar action = do+ modifyMVar_ adaptorStateMVar (flip runAdaptor (resetAdaptorStatePayload >> action))++----------------------------------------------------------------------------+-- | Utility for evaluating a monad transformer stack+runAdaptor :: AdaptorState app -> Adaptor app () -> IO (AdaptorState app)+runAdaptor adaptorState (Adaptor client) =+ runStateT (runExceptT client) adaptorState >>= \case+ (Left (errorMessage, maybeMessage), nextState) ->+ runAdaptor nextState (sendErrorResponse errorMessage maybeMessage)+ (Right (), nextState) -> pure nextState
+ src/DAP/Event.hs view
@@ -0,0 +1,208 @@+-----------------------------------------------------------------------------+-- |+-- Module : DAP.Event+-- Copyright : (C) 2023 David M. Johnson+-- License : BSD3-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+----------------------------------------------------------------------------+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+----------------------------------------------------------------------------+module DAP.Event+ ( -- * Event message API+ sendBreakpointEvent+ , sendCapabilitiesEvent+ , sendContinuedEvent+ , sendExitedEvent+ , sendInitializedEvent+ , sendInvalidatedEvent+ , sendLoadedSourceEvent+ , sendMemoryEvent+ , sendModuleEvent+ , sendOutputEvent+ , sendProcessEvent+ , sendProgressEndEvent+ , sendProgressStartEvent+ , sendProgressUpdateEvent+ , sendStoppedEvent+ , sendTerminatedEvent+ , sendThreadEvent+ -- * Defaults+ , defaultContinuedEvent+ , defaultExitedEvent+ , defaultInvalidatedEvent+ , defaultMemoryEvent+ , defaultOutputEvent+ , defaultProcessEvent+ , defaultProgressEndEvent+ , defaultProgressStartEvent+ , defaultProgressUpdateEvent+ , defaultStoppedEvent+ , defaultTerminatedEvent+ , defaultThreadEvent+ ) where+----------------------------------------------------------------------------+import DAP.Types+import DAP.Adaptor+----------------------------------------------------------------------------+sendBreakpointEvent :: BreakpointEvent -> Adaptor app ()+sendBreakpointEvent = sendSuccesfulEvent EventTypeBreakpoint . setBody+----------------------------------------------------------------------------+sendCapabilitiesEvent :: CapabilitiesEvent -> Adaptor app ()+sendCapabilitiesEvent = sendSuccesfulEvent EventTypeCapabilities . setBody+----------------------------------------------------------------------------+sendContinuedEvent :: ContinuedEvent -> Adaptor app ()+sendContinuedEvent = sendSuccesfulEvent EventTypeContinued . setBody+----------------------------------------------------------------------------+defaultContinuedEvent :: ContinuedEvent+defaultContinuedEvent+ = ContinuedEvent+ { continuedEventThreadId = 0+ , continuedEventAllThreadsContinued = False+ }+----------------------------------------------------------------------------+sendExitedEvent :: ExitedEvent -> Adaptor app ()+sendExitedEvent = sendSuccesfulEvent EventTypeExited . setBody+----------------------------------------------------------------------------+defaultExitedEvent :: ExitedEvent+defaultExitedEvent+ = ExitedEvent+ { exitedEventExitCode = 0+ }+----------------------------------------------------------------------------+sendInitializedEvent :: Adaptor app ()+sendInitializedEvent = sendSuccesfulEvent EventTypeInitialized (pure ())+----------------------------------------------------------------------------+sendInvalidatedEvent :: InvalidatedEvent -> Adaptor app ()+sendInvalidatedEvent = sendSuccesfulEvent EventTypeInvalidated . setBody+----------------------------------------------------------------------------+defaultInvalidatedEvent :: InvalidatedEvent+defaultInvalidatedEvent+ = InvalidatedEvent+ { invalidatedEventAreas = []+ , invalidatedEventThreadId = Nothing+ , invalidatedEventStackFrameId = Nothing+ }++----------------------------------------------------------------------------+sendLoadedSourceEvent :: LoadedSourceEvent -> Adaptor app ()+sendLoadedSourceEvent = sendSuccesfulEvent EventTypeLoadedSource . setBody+----------------------------------------------------------------------------+sendMemoryEvent :: MemoryEvent -> Adaptor app ()+sendMemoryEvent = sendSuccesfulEvent EventTypeMemory . setBody+----------------------------------------------------------------------------+defaultMemoryEvent :: MemoryEvent+defaultMemoryEvent+ = MemoryEvent+ { memoryEventMemoryReference = mempty+ , memoryEventOffset = 0+ , memoryEventCount = 0+ }+----------------------------------------------------------------------------+sendModuleEvent :: ModuleEvent -> Adaptor app ()+sendModuleEvent = sendSuccesfulEvent EventTypeModule . setBody+----------------------------------------------------------------------------+sendOutputEvent :: OutputEvent -> Adaptor app ()+sendOutputEvent = sendSuccesfulEvent EventTypeOutput . setBody+----------------------------------------------------------------------------+defaultOutputEvent :: OutputEvent+defaultOutputEvent+ = OutputEvent+ { outputEventCategory = Nothing+ , outputEventOutput = mempty+ , outputEventGroup = Nothing+ , outputEventVariablesReference = Nothing+ , outputEventSource = Nothing+ , outputEventLine = Nothing+ , outputEventColumn = Nothing+ , outputEventData = Nothing+ }+----------------------------------------------------------------------------+sendProcessEvent :: ProcessEvent -> Adaptor app ()+sendProcessEvent = sendSuccesfulEvent EventTypeProcess . setBody+----------------------------------------------------------------------------+defaultProcessEvent :: ProcessEvent+defaultProcessEvent+ = ProcessEvent+ { processEventName = mempty+ , processEventSystemProcessId = Nothing+ , processEventIsLocalProcess = True+ , processEventStartMethod = Nothing+ , processEventPointerSize = Nothing+ }+----------------------------------------------------------------------------+sendProgressEndEvent :: ProgressEndEvent -> Adaptor app ()+sendProgressEndEvent = sendSuccesfulEvent EventTypeProgressEnd . setBody+----------------------------------------------------------------------------+defaultProgressEndEvent :: ProgressEndEvent+defaultProgressEndEvent+ = ProgressEndEvent+ { progressEndEventProgressId = mempty+ , progressEndEventMessage = Nothing+ }+----------------------------------------------------------------------------+sendProgressStartEvent :: ProgressStartEvent -> Adaptor app ()+sendProgressStartEvent = sendSuccesfulEvent EventTypeProgressStart . setBody+----------------------------------------------------------------------------+defaultProgressStartEvent :: ProgressStartEvent+defaultProgressStartEvent+ = ProgressStartEvent+ { progressStartEventProgressId = mempty+ , progressStartEventTitle = mempty+ , progressStartEventRequestId = Nothing+ , progressStartEventCancellable = False+ , progressStartEventMessage = Nothing+ , progressStartEventPercentage = Nothing+ }+----------------------------------------------------------------------------+sendProgressUpdateEvent :: ProgressUpdateEvent -> Adaptor app ()+sendProgressUpdateEvent = sendSuccesfulEvent EventTypeProgressUpdate . setBody+----------------------------------------------------------------------------+defaultProgressUpdateEvent :: ProgressUpdateEvent+defaultProgressUpdateEvent+ = ProgressUpdateEvent+ { progressUpdateEventProgressId = mempty+ , progressUpdateEventMessage = Nothing+ , progressUpdateEventPercentage = Nothing+ }+----------------------------------------------------------------------------+sendStoppedEvent :: StoppedEvent -> Adaptor app ()+sendStoppedEvent = sendSuccesfulEvent EventTypeStopped . setBody+----------------------------------------------------------------------------+defaultStoppedEvent :: StoppedEvent+defaultStoppedEvent+ = StoppedEvent+ { stoppedEventReason = StoppedEventReasonStep+ , stoppedEventDescription = Nothing+ , stoppedEventThreadId = Just 0+ , stoppedEventPreserveFocusHint = False+ , stoppedEventText = Nothing+ , stoppedEventAllThreadsStopped = False+ , stoppedEventHitBreakpointIds = []+ }+----------------------------------------------------------------------------+sendTerminatedEvent :: TerminatedEvent -> Adaptor app ()+sendTerminatedEvent = sendSuccesfulEvent EventTypeTerminated . setBody+----------------------------------------------------------------------------+defaultTerminatedEvent :: TerminatedEvent+defaultTerminatedEvent+ = TerminatedEvent+ { terminatedEventRestart = False+ }+----------------------------------------------------------------------------+sendThreadEvent :: ThreadEvent -> Adaptor app ()+sendThreadEvent = sendSuccesfulEvent EventTypeThread . setBody+----------------------------------------------------------------------------+defaultThreadEvent :: ThreadEvent+defaultThreadEvent+ = ThreadEvent+ { threadEventReason = ThreadEventReasonStarted+ , threadEventThreadId = 0+ }+----------------------------------------------------------------------------+
+ src/DAP/Internal.hs view
@@ -0,0 +1,39 @@+----------------------------------------------------------------------------+-- |+-- Module : DAP.Internal+-- Copyright : (C) 2023 David M. Johnson+-- License : BSD3-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+-- Description : Internal functions for consumption by other modules like Server.hs+----------------------------------------------------------------------------+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.+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 = withLock lock+----------------------------------------------------------------------------
+ src/DAP/Response.hs view
@@ -0,0 +1,270 @@+-----------------------------------------------------------------------------+-- |+-- Module : DAP.Response+-- Copyright : (C) 2023 David M. Johnson+-- License : BSD3-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+----------------------------------------------------------------------------+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+----------------------------------------------------------------------------+module DAP.Response+ ( -- * Response message API+ sendAttachResponse+ , sendBreakpointLocationsResponse+ , sendCompletionsResponse+ , sendConfigurationDoneResponse+ , sendContinueResponse+ , sendDataBreakpointInfoResponse+ , sendDisassembleResponse+ , sendDisconnectResponse+ , sendEvaluateResponse+ , sendExceptionInfoResponse+ , sendGotoResponse+ , sendGotoTargetsResponse+ , sendInitializeResponse+ , sendLaunchResponse+ , sendLoadedSourcesResponse+ , sendModulesResponse+ , sendNextResponse+ , sendPauseResponse+ , sendReadMemoryResponse+ , sendRestartResponse+ , sendRestartFrameResponse+ , sendReverseContinueResponse+ , sendScopesResponse+ , sendSetBreakpointsResponse+ , sendSetDataBreakpointsResponse+ , sendSetExceptionBreakpointsResponse+ , sendSetExpressionResponse+ , sendSetFunctionBreakpointsResponse+ , sendSetInstructionBreakpointsResponse+ , sendSetVariableResponse+ , sendSourceResponse+ , sendStackTraceResponse+ , sendStepBackResponse+ , sendStepInResponse+ , sendStepInTargetsResponse+ , sendStepOutResponse+ , sendTerminateResponse+ , sendTerminateThreadsResponse+ , sendThreadsResponse+ , sendVariablesResponse+ , sendWriteMemoryResponse+ , sendRunInTerminalResponse+ , sendStartDebuggingResponse+ ) where+----------------------------------------------------------------------------+import DAP.Adaptor+import DAP.Types+----------------------------------------------------------------------------+-- | AttachResponse has no body by default+sendAttachResponse :: Adaptor app ()+sendAttachResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | BreakpointLocationResponse has no body by default+sendBreakpointLocationsResponse+ :: [BreakpointLocation]+ -> Adaptor app ()+sendBreakpointLocationsResponse+ = sendSuccesfulResponse+ . setBody+ . Breakpoints+----------------------------------------------------------------------------+-- | 'SetDataBreakpointsResponse'+sendSetDataBreakpointsResponse+ :: [Breakpoint]+ -> Adaptor app ()+sendSetDataBreakpointsResponse+ = sendSuccesfulResponse+ . setBody+ . Breakpoints+----------------------------------------------------------------------------+-- | BreakpointResponse has no body by default+sendSetBreakpointsResponse+ :: [Breakpoint]+ -> Adaptor app ()+sendSetBreakpointsResponse+ = sendSuccesfulResponse+ . setBody+ . Breakpoints+----------------------------------------------------------------------------+-- | SetInstructionsBreakpointResponse has no body by default+sendSetInstructionBreakpointsResponse+ :: [Breakpoint]+ -> Adaptor app ()+sendSetInstructionBreakpointsResponse+ = sendSuccesfulResponse+ . setBody+ . Breakpoints+----------------------------------------------------------------------------+-- | SetFunctionBreakpointResponse has no body by default+sendSetFunctionBreakpointsResponse+ :: [Breakpoint]+ -> Adaptor app ()+sendSetFunctionBreakpointsResponse+ = sendSuccesfulResponse+ . setBody+ . Breakpoints+----------------------------------------------------------------------------+-- | SetExceptionBreakpointsResponse has no body by default+sendSetExceptionBreakpointsResponse+ :: [Breakpoint]+ -> Adaptor app ()+sendSetExceptionBreakpointsResponse+ = sendSuccesfulResponse+ . setBody+ . Breakpoints+----------------------------------------------------------------------------+-- | ContinueResponse+sendContinueResponse+ :: ContinueResponse+ -> Adaptor app ()+sendContinueResponse continueResponse = do+ sendSuccesfulResponse (setBody continueResponse)+----------------------------------------------------------------------------+-- | ConfigurationDoneResponse+sendConfigurationDoneResponse+ :: Adaptor app ()+sendConfigurationDoneResponse = do+ sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | LaunchResponse+sendLaunchResponse+ :: Adaptor app ()+sendLaunchResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | RestartResponse+sendRestartResponse+ :: Adaptor app ()+sendRestartResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | DisconnectResponse+sendDisconnectResponse+ :: Adaptor app ()+sendDisconnectResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | TerminateResponse+sendTerminateResponse+ :: Adaptor app ()+sendTerminateResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | NextResponse+sendNextResponse+ :: Adaptor app ()+sendNextResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | StepInResponse+sendStepInResponse+ :: Adaptor app ()+sendStepInResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | StepOutResponse+sendStepOutResponse+ :: Adaptor app ()+sendStepOutResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | StepBackResponse+sendStepBackResponse+ :: Adaptor app ()+sendStepBackResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | ReverseContinueResponse+sendReverseContinueResponse+ :: Adaptor app ()+sendReverseContinueResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | RestartFrameResponse+sendRestartFrameResponse+ :: Adaptor app ()+sendRestartFrameResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | InitializeReponse+sendInitializeResponse+ :: Adaptor app ()+sendInitializeResponse = do+ capabilities <- getServerCapabilities+ sendSuccesfulResponse (setBody capabilities)+----------------------------------------------------------------------------+-- | GotoResponse+sendGotoResponse+ :: Adaptor app ()+sendGotoResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | GotoTargetsResponse+sendGotoTargetsResponse+ :: Adaptor app ()+sendGotoTargetsResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | PauseResponse+sendPauseResponse+ :: Adaptor app ()+sendPauseResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+-- | TerminateThreadsResponse+sendTerminateThreadsResponse+ :: Adaptor app ()+sendTerminateThreadsResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------+sendModulesResponse :: ModulesResponse -> Adaptor app ()+sendModulesResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendStackTraceResponse :: StackTraceResponse -> Adaptor app ()+sendStackTraceResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendSourceResponse :: SourceResponse -> Adaptor app ()+sendSourceResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendThreadsResponse :: [Thread] -> Adaptor app ()+sendThreadsResponse = sendSuccesfulResponse . setBody . ThreadsResponse+----------------------------------------------------------------------------+sendLoadedSourcesResponse :: [Source] -> Adaptor app ()+sendLoadedSourcesResponse = sendSuccesfulResponse . setBody . LoadedSourcesResponse+----------------------------------------------------------------------------+sendWriteMemoryResponse :: WriteMemoryResponse -> Adaptor app ()+sendWriteMemoryResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendReadMemoryResponse :: ReadMemoryResponse -> Adaptor app ()+sendReadMemoryResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendCompletionsResponse :: CompletionsResponse -> Adaptor app ()+sendCompletionsResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendDataBreakpointInfoResponse :: DataBreakpointInfoResponse -> Adaptor app ()+sendDataBreakpointInfoResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendDisassembleResponse :: DisassembleResponse -> Adaptor app ()+sendDisassembleResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendEvaluateResponse :: EvaluateResponse -> Adaptor app ()+sendEvaluateResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendExceptionInfoResponse :: ExceptionInfoResponse -> Adaptor app ()+sendExceptionInfoResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendScopesResponse :: ScopesResponse -> Adaptor app ()+sendScopesResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendSetExpressionResponse :: SetExpressionResponse -> Adaptor app ()+sendSetExpressionResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendSetVariableResponse :: SetVariableResponse -> Adaptor app ()+sendSetVariableResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendStepInTargetsResponse :: StepInTargetsResponse -> Adaptor app ()+sendStepInTargetsResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendVariablesResponse :: VariablesResponse -> Adaptor app ()+sendVariablesResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendRunInTerminalResponse :: RunInTerminalResponse -> Adaptor app ()+sendRunInTerminalResponse = sendSuccesfulResponse . setBody+----------------------------------------------------------------------------+sendStartDebuggingResponse :: Adaptor app ()+sendStartDebuggingResponse = sendSuccesfulEmptyResponse+----------------------------------------------------------------------------
+ src/DAP/Server.hs view
@@ -0,0 +1,184 @@+-----------------------------------------------------------------------------+-- |+-- Module : DAP.Server+-- Copyright : (C) 2023 David M. Johnson+-- License : BSD3-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+----------------------------------------------------------------------------+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+----------------------------------------------------------------------------+module DAP.Server+ ( runDAPServer+ , readPayload+ ) where+----------------------------------------------------------------------------+import Control.Concurrent.MVar ( MVar )+import Control.Monad ( when )+import Control.Concurrent.MVar ( newMVar, newEmptyMVar, modifyMVar_+ , putMVar, readMVar )+import Control.Concurrent.STM ( newTVarIO )+import Control.Exception ( SomeException+ , IOException+ , catch+ , fromException+ , throwIO )+import Control.Monad ( void )+import Control.Monad.State ( gets )+import Data.Aeson ( decodeStrict, eitherDecode, Value, FromJSON )+import Data.Aeson.Encode.Pretty ( encodePretty )+import Data.ByteString ( ByteString )+import Data.Char ( isDigit )+import Network.Simple.TCP ( serve, HostPreference(Host) )+import Network.Socket ( socketToHandle, withSocketsDo, SockAddr )+import System.IO ( hClose, hSetNewlineMode, Handle, Newline(CRLF)+ , NewlineMode(NewlineMode, outputNL, inputNL)+ , IOMode(ReadWriteMode) )+import System.IO.Error ( isEOFError )+import Text.Read ( readMaybe )+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Char8 as BS+----------------------------------------------------------------------------+import DAP.Types+import DAP.Internal+import DAP.Utils+import DAP.Adaptor+----------------------------------------------------------------------------+runDAPServer+ :: ServerConfig+ -- ^ Top-level Server configuration, global across all debug sessions+ -> (Command -> Adaptor app ())+ -- ^ A function to facilitate communication between DAP clients, debug adaptors and debuggers+ -> IO ()+runDAPServer serverConfig@ServerConfig {..} communicate = withSocketsDo $ do+ when debugLogging $ putStrLn ("Running DAP server on " <> show port <> "...")+ appStore <- newTVarIO mempty+ serve (Host host) (show port) $ \(socket, address) -> do+ when debugLogging $ do+ withGlobalLock $ do+ putStrLn $ "TCP connection established from " ++ show address+ handle <- socketToHandle socket ReadWriteMode+ hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF }+ request <- getRequest handle address serverConfig+ adaptorStateMVar <- initAdaptorState handle address appStore serverConfig request+ serviceClient communicate adaptorStateMVar `catch` exceptionHandler handle address debugLogging++-- | Initializes the Adaptor+--+initAdaptorState+ :: Handle+ -> SockAddr+ -> AppStore app+ -> ServerConfig+ -> Request+ -> IO (MVar (AdaptorState app))+initAdaptorState handle address appStore serverConfig request = do+ handleLock <- newMVar ()+ sessionId <- pure Nothing+ adaptorStateMVar <- newEmptyMVar+ putMVar adaptorStateMVar AdaptorState+ { messageType = MessageTypeResponse+ , payload = []+ , ..+ }+ pure adaptorStateMVar+----------------------------------------------------------------------------+-- | Communication loop between editor and adaptor+-- Evaluates the current 'Request' located in the 'AdaptorState'+-- Fetches, updates and recurses on the next 'Request'+--+serviceClient+ :: (Command -> Adaptor app ())+ -> MVar (AdaptorState app)+ -> IO ()+serviceClient communicate adaptorStateMVar = do+ runAdaptorWith adaptorStateMVar $ do+ request <- gets request+ communicate (command request)++ -- HINT: getRequest is a blocking action so we use readMVar to leave MVar available+ AdaptorState { address, handle, serverConfig } <- readMVar adaptorStateMVar+ nextRequest <- getRequest handle address serverConfig+ modifyMVar_ adaptorStateMVar $ \s -> pure s { request = nextRequest }++ -- loop: serve the next request+ serviceClient communicate adaptorStateMVar++----------------------------------------------------------------------------+-- | Handle exceptions from client threads, parse and log accordingly+exceptionHandler :: Handle -> SockAddr -> Bool -> SomeException -> IO ()+exceptionHandler handle address shouldLog (e :: SomeException) = do+ let+ dumpError+ | Just (ParseException msg) <- fromException e+ = logger ERROR address Nothing+ $ withBraces+ $ BL8.pack ("Parse Exception encountered: " <> msg)+ | Just (err :: IOException) <- fromException e, isEOFError err+ = logger INFO address (Just SENT)+ $ withBraces "Client has ended its connection"+ | otherwise+ = logger ERROR address Nothing+ $ withBraces+ $ BL8.pack ("Unknown Exception: " <> show e)+ when shouldLog $ do+ dumpError+ logger INFO address (Just SENT) (withBraces "Closing Connection")+ hClose handle+----------------------------------------------------------------------------+-- | Internal function for parsing a 'ProtocolMessage' header+-- This function also dispatches on 'talk'+--+-- 'parseHeader' Attempts to parse 'Content-Length: <byte-count>'+-- Helper function for parsing message headers+-- e.g. ("Content-Length: 11\r\n")+getRequest :: Handle -> SockAddr -> ServerConfig -> IO Request+getRequest handle addr ServerConfig {..} = do+ headerBytes <- BS.hGetLine handle+ void (BS.hGetLine handle)+ parseHeader headerBytes >>= \case+ Left errorMessage -> do+ logger ERROR addr Nothing (BL8.pack errorMessage)+ throwIO (ParseException errorMessage)+ Right count -> do+ body <- BS.hGet handle count+ when debugLogging $ do+ logger DEBUG addr (Just RECEIVED)+ ("\n" <> encodePretty (decodeStrict body :: Maybe Value))+ case eitherDecode (BL8.fromStrict body) of+ Left couldn'tDecodeBody -> do+ logger ERROR addr Nothing (BL8.pack couldn'tDecodeBody)+ throwIO (ParseException couldn'tDecodeBody)+ Right request ->+ pure request+----------------------------------------------------------------------------+-- | Parses the HeaderPart of all ProtocolMessages+parseHeader :: ByteString -> IO (Either String PayloadSize)+parseHeader bytes = do+ let byteSize = BS.takeWhile isDigit (BS.drop (BS.length "Content-Length: ") bytes)+ case readMaybe (BS.unpack byteSize) of+ Just contentLength ->+ pure (Right contentLength)+ Nothing ->+ pure $ Left ("Invalid payload: " <> BS.unpack bytes)++-- | Helper function to parse a 'ProtocolMessage', extracting it's body.+-- used for testing.+--+readPayload :: FromJSON json => Handle -> IO (Either String json)+readPayload handle = do+ headerBytes <- BS.hGetLine handle+ void (BS.hGetLine handle)+ parseHeader headerBytes >>= \case+ Left e -> pure (Left e)+ Right count -> do+ body <- BS.hGet handle count+ pure $ eitherDecode (BL8.fromStrict body)
+ src/DAP/Types.hs view
@@ -0,0 +1,4027 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main+-- Copyright : (C) 2023 David M. Johnson+-- License : BSD3-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+----------------------------------------------------------------------------+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+----------------------------------------------------------------------------+module DAP.Types+ ( -- * Message Type+ MessageType (..)+ -- * Types+ , Breakpoint (..)+ , Breakpoints (..)+ , BreakpointLocation (..)+ , Capabilities (..)+ , Checksum (..)+ , ChecksumAlgorithm (..)+ , ColumnDescriptor (..)+ , CompletionItem (..)+ , CompletionItemType (..)+ , DataBreakpoint (..)+ , DataBreakpointAccessType (..)+ , DisassembledInstruction (..)+ , ExceptionBreakMode (..)+ , ExceptionBreakpointsFilter (..)+ , ExceptionDetails (..)+ , ExceptionFilterOptions (..)+ , ExceptionOptions (..)+ , ExceptionPathSegment (..)+ , FunctionBreakpoint (..)+ , GotoTarget (..)+ , InstructionBreakpoint (..)+ , InvalidatedAreas (..)+ , Message (..)+ , Module (..)+ , ModulesViewDescriptor (..)+ , PresentationHint (..)+ , Scope (..)+ , Source (..)+ , SourceBreakpoint (..)+ , SourcePresentationHint (..)+ , StackFrame (..)+ , StackFrameFormat (..)+ , StepInTarget (..)+ , SteppingGranularity (..)+ , StoppedEventReason (..)+ , Thread (..)+ , ThreadEventReason (..)+ , ValueFormat (..)+ , Variable (..)+ , VariablePresentationHint (..)+ , ColumnDescriptorType (..)+ , ScopePresentationHint (..)+ , PresentationHintKind (..)+ , PresentationHintAttributes (..)+ , PresentationHintVisibility (..)+ , EventGroup (..)+ , EventReason (..)+ , StartMethod (..)+ , EvaluateArgumentsContext (..)+ , PathFormat (..)+ -- * Command+ , Command (..)+ -- * Event+ , EventType (..)+ -- ** Events+ , StoppedEvent (..)+ , ContinuedEvent (..)+ , ExitedEvent (..)+ , TerminatedEvent (..)+ , ThreadEvent (..)+ , OutputEvent (..)+ , BreakpointEvent (..)+ , ModuleEvent (..)+ , LoadedSourceEvent (..)+ , ProcessEvent (..)+ , CapabilitiesEvent (..)+ , ProgressStartEvent (..)+ , ProgressUpdateEvent (..)+ , ProgressEndEvent (..)+ , InvalidatedEvent (..)+ , MemoryEvent (..)+ -- * Server+ , ServerConfig (..)+ -- * Client+ , Adaptor (..)+ , AdaptorState (..)+ , AppStore+ -- * Errors+ , AdaptorException (..)+ , ErrorMessage (..)+ , ErrorResponse (..)+ -- * Request+ , Request (..)+ -- * Misc.+ , PayloadSize+ , Seq+ , SessionId+ -- * Responses+ , CompletionsResponse (..)+ , ContinueResponse (..)+ , DataBreakpointInfoResponse (..)+ , DisassembleResponse (..)+ , EvaluateResponse (..)+ , ExceptionInfoResponse (..)+ , GotoTargetsResponse (..)+ , LoadedSourcesResponse (..)+ , ModulesResponse (..)+ , ReadMemoryResponse (..)+ , ScopesResponse (..)+ , SetExpressionResponse (..)+ , SetVariableResponse (..)+ , SourceResponse (..)+ , StackTraceResponse (..)+ , StepInTargetsResponse (..)+ , ThreadsResponse (..)+ , VariablesResponse (..)+ , WriteMemoryResponse (..)+ -- * Arguments+ , AttachRequestArguments (..)+ , BreakpointLocationsArguments (..)+ , CompletionsArguments (..)+ , ConfigurationDoneArguments (..)+ , ContinueArguments (..)+ , DataBreakpointInfoArguments (..)+ , DisassembleArguments (..)+ , DisconnectArguments (..)+ , EvaluateArguments (..)+ , ExceptionInfoArguments (..)+ , GotoArguments (..)+ , GotoTargetsArguments (..)+ , InitializeRequestArguments (..)+ , LaunchRequestArguments (..)+ , LoadedSourcesArguments (..)+ , ModulesArguments (..)+ , NextArguments (..)+ , PauseArguments (..)+ , ReadMemoryArguments (..)+ , RestartArguments (..)+ , RestartFrameArguments (..)+ , ReverseContinueArguments (..)+ , ScopesArguments (..)+ , SetBreakpointsArguments (..)+ , SetDataBreakpointsArguments (..)+ , SetExceptionBreakpointsArguments (..)+ , SetExpressionArguments (..)+ , SetFunctionBreakpointsArguments (..)+ , SetInstructionBreakpointsArguments (..)+ , SetVariableArguments (..)+ , SourceArguments (..)+ , StackTraceArguments (..)+ , StepBackArguments (..)+ , StepInArguments (..)+ , StepInTargetsArguments (..)+ , StepOutArguments (..)+ , TerminateArguments (..)+ , TerminateThreadsArguments (..)+ , ThreadsArguments (..)+ , VariablesArguments (..)+ , WriteMemoryArguments (..)+ , RunInTerminalResponse (..)+ -- * defaults+ , defaultBreakpoint+ , defaultBreakpointLocation+ , defaultCapabilities+ , defaultColumnDescriptor+ , defaultCompletionItem+ , defaultDisassembledInstruction+ , defaultExceptionBreakpointsFilter+ , defaultExceptionDetails+ , defaultFunctionBreakpoint+ , defaultGotoTarget+ , defaultMessage+ , defaultModule+ , defaultModulesViewDescriptor+ , defaultScope+ , defaultSource+ , defaultSourceBreakpoint+ , defaultStackFrame+ , defaultStackFrameFormat+ , defaultStepInTarget+ , defaultThread+ , defaultValueFormat+ , defaultVariable+ , defaultVariablePresentationHint+ -- * Log level+ , Level (..)+ , DebugStatus (..)+ -- * Debug Thread state+ , DebuggerThreadState (..)+ ) where+----------------------------------------------------------------------------+import Control.Monad.Base ( MonadBase )+import Control.Monad.Except ( MonadError, ExceptT )+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 )+import Control.Exception ( Exception )+import Control.Monad.State ( StateT, MonadState, MonadIO )+import Data.Aeson ( (.:), (.:?), withObject, withText, object+ , FromJSON(parseJSON), Value, KeyValue((.=))+ , ToJSON(toJSON), genericParseJSON, defaultOptions+ )+import Data.Aeson.Types ( Pair, typeMismatch )+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 DAP.Utils ( capitalize, 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 Adaptor store a =+ Adaptor (ExceptT (ErrorMessage, Maybe Message) (StateT (AdaptorState store) IO) a)+ deriving newtype+ ( Monad+ , MonadIO, Applicative, Functor, MonadState (AdaptorState store)+ , MonadBaseControl IO+ , MonadError (ErrorMessage, Maybe Message)+ , MonadBase IO+ )+----------------------------------------------------------------------------+-- | The adaptor state is local to a single connection / thread+data AdaptorState app+ = AdaptorState+ { messageType :: MessageType+ -- ^ Current message type being created+ -- This was added as a convenience so we can set the 'request_seq'+ -- and 'command' fields automatically.+ --+ , payload :: ![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+ --+ , appStore :: AppStore app+ -- ^ Global app store, accessible on a per session basis+ -- Initialized during 'attach' sessions+ --+ , serverConfig :: ServerConfig+ -- ^ Configuration information for the ServerConfig+ -- Identical across all debugging sessions+ --+ , handle :: Handle+ -- ^ Connection Handle+ --+ , request :: Request+ -- ^ Connection Request information+ --+ , address :: SockAddr+ -- ^ Address of Connection+ --+ , sessionId :: Maybe SessionId+ -- ^ Session ID+ -- Local to the current connection's debugger session+ --+ , adaptorStateMVar :: MVar (AdaptorState app)+ -- ^ Shared state for serializable concurrency+ --+ , handleLock :: MVar ()+ -- ^ A lock for writing to a Handle. One lock is created per connection+ -- and exists for the duration of that connection+ --+ }++----------------------------------------------------------------------------+type SessionId = Text+----------------------------------------------------------------------------+-- | Used to store a map of debugging sessions+-- 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 (DebuggerThreadState, app))++-- | 'DebuggerThreadState'+-- State to hold both the thread that executes the debugger and the thread used+-- to propagate output events from the debugger + debuggee to the editor (via the+-- DAP server).+data DebuggerThreadState+ = DebuggerThreadState+ { debuggerThread :: ThreadId+ , debuggerOutputEventThread :: ThreadId+ }++----------------------------------------------------------------------------+data ServerConfig+ = ServerConfig+ { host :: String+ , port :: Int+ , serverCapabilities :: Capabilities+ , debugLogging :: Bool+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+-- | Used to signify a malformed message has been received+data AdaptorException+ = ParseException String+ | ExpectedArguments String+ | DebugSessionIdException String+ | DebuggerException String+ deriving stock (Show, Eq)+ deriving anyclass Exception+----------------------------------------------------------------------------+type PayloadSize = Int+----------------------------------------------------------------------------+data MessageType+ = MessageTypeEvent+ | MessageTypeResponse+ | MessageTypeRequest+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON MessageType where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+type Seq = Int+----------------------------------------------------------------------------+data Request+ = Request+ { args :: Maybe Value+ -- ^ Request arguments+ --+ , requestSeqNum :: Seq+ -- ^ Request sequence number+ --+ , command :: Command+ -- ^ Command of Request+ --+ } deriving stock (Show)+----------------------------------------------------------------------------+instance FromJSON Request where+ parseJSON = withObject "Request" $ \o -> do+ Request+ <$> o .:? "arguments"+ <*> o .: "seq"+ <*> o .: "command"+----------------------------------------------------------------------------+data Breakpoint+ = Breakpoint+ { breakpointId :: Maybe Int+ -- ^+ -- The identifier for the breakpoint. It is needed if breakpoint events are+ -- used to update or remove breakpoints.+ --+ , breakpointVerified :: Bool+ -- ^+ -- If true, the breakpoint could be set (but not necessarily at the desired+ -- location).+ --+ , breakpointMessage :: Maybe Text+ -- ^+ -- A message about the state of the breakpoint.+ -- This is shown to the user and can be used to explain why a breakpoint could+ -- not be verified.+ --+ , breakpointSource :: Maybe Source+ -- ^+ -- The source where the breakpoint is located.+ --+ , breakpointLine :: Maybe Int+ -- ^+ -- The start line of the actual range covered by the breakpoint.+ --+ , breakpointColumn :: Maybe Int+ -- ^+ -- Start position of the source range covered by the breakpoint. It is+ -- measured in UTF-16 code units and the client capability `columnsStartAt1`+ -- determines whether it is 0- or 1-based.+ --+ , breakpointEndLine :: Maybe Int+ -- ^+ -- The end line of the actual range covered by the breakpoint.+ --+ , breakpointEndColumn :: Maybe Int+ -- ^+ -- End position of the source range covered by the breakpoint. It is measured+ -- in UTF-16 code units and the client capability `columnsStartAt1` determines+ -- whether it is 0- or 1-based.+ -- If no end line is given, then the end column is assumed to be in the start+ -- line.+ --+ , breakpointInstructionReference :: Maybe Text+ -- ^+ -- A memory reference to where the breakpoint is set.+ --+ , breakpointOffset :: Maybe Int+ -- ^+ -- The offset from the instruction reference.+ -- This can be negative.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultBreakpoint :: Breakpoint+defaultBreakpoint = Breakpoint+ { breakpointId = Nothing+ , breakpointVerified = False+ , breakpointMessage = Nothing+ , breakpointSource = Nothing+ , breakpointLine = Nothing+ , breakpointColumn = Nothing+ , breakpointEndLine = Nothing+ , breakpointEndColumn = Nothing+ , breakpointInstructionReference = Nothing+ , breakpointOffset = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON Breakpoint where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+newtype Breakpoints breakpoint = Breakpoints [breakpoint]+ deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON breakpoint => ToJSON (Breakpoints breakpoint) where+ toJSON (Breakpoints breakpoints)+ = object+ [ "breakpoints" .= breakpoints+ ]+----------------------------------------------------------------------------+data Source+ = Source+ { sourceName :: Maybe Text+ -- ^+ -- The short name of the source. Every source returned from the debug adapter+ -- has a name.+ -- When sending a source to the debug adapter this name is optional.+ --+ , sourcePath :: Maybe Text+ -- ^+ -- The path of the source to be shown in the UI.+ -- It is only used to locate and load the content of the source if no+ -- `sourceReference` is specified (or its value is 0).+ --+ , sourceSourceReference :: Maybe Int+ -- ^+ -- If the value > 0 the contents of the source must be retrieved through the+ -- `source` request (even if a path is specified).+ -- Since a `sourceReference` is only valid for a session, it can not be used+ -- to persist a source.+ -- The value should be less than or equal to 2147483647 (2^31-1).+ --+ , sourcePresentationHint :: Maybe SourcePresentationHint+ -- ^+ -- A hint for how to present the source in the UI.+ -- A value of `deemphasize` can be used to indicate that the source is not+ -- available or that it is skipped on stepping.+ -- Values: 'normal', 'emphasize', 'deemphasize'+ --+ , sourceOrigin :: Maybe Text+ -- ^+ -- The origin of this source. For example, 'internal module', 'inlined content+ -- from source map', etc.+ --+ , sourceSources :: Maybe [Source]+ -- ^+ -- A list of sources that are related to this source. These may be the source+ -- that generated this source.+ --+ , sourceAdapterData :: Maybe Value+ -- ^+ -- Additional data that a debug adapter might want to loop through the client.+ -- The client should leave the data intact and persist it across sessions. The+ -- client should not interpret the data.+ --+ , sourceChecksums :: Maybe [Checksum]+ -- ^+ -- The checksums associated with this file.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultSource :: Source+defaultSource+ = Source+ { sourceName = Nothing+ , sourcePath = Nothing+ , sourceSourceReference = Nothing+ , sourcePresentationHint = Nothing+ , sourceOrigin = Nothing+ , sourceSources = Nothing+ , sourceAdapterData = Nothing+ , sourceChecksums = Nothing+ }+----------------------------------------------------------------------------+instance FromJSON Source where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+instance ToJSON Source where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+newtype Sources = Sources { getSources :: [Source] } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON Sources where toJSON (Sources s) = object [ "sources" .= s ]+----------------------------------------------------------------------------+data SourcePresentationHint+ = SourcePresentationHintNormal+ | SourcePresentationHintEmphasize+ | SourcePresentationHintDeemphasize+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SourcePresentationHint where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+instance ToJSON SourcePresentationHint where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data PresentationHint+ = PresentationHintNormal+ | PresentationHintLabel+ | PresentationHintSubtle+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON PresentationHint where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data Checksum+ = Checksum+ { algorithm :: ChecksumAlgorithm+ -- ^ The algorithm used to calculate this checksum.+ --+ , checksum :: Text+ -- ^ Value of the checksum, encoded as a hexadecimal value.+ --+ } deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON, FromJSON)+----------------------------------------------------------------------------+data ChecksumAlgorithm+ = MD5+ | SHA1+ | SHA256+ | TimeStamp UTCTime+ deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON ChecksumAlgorithm where+ toJSON MD5 = "md5"+ toJSON SHA1 = "sha1"+ toJSON SHA256 = "sha256"+ toJSON (TimeStamp utcTime) = toJSON utcTime+----------------------------------------------------------------------------+instance FromJSON ChecksumAlgorithm where+ parseJSON = withText name $ \txt ->+ case txt of+ "md5" -> pure MD5+ "sha1" -> pure SHA1+ "sha256" -> pure SHA256+ s -> typeMismatch name (toJSON s)+ where+ name = getName (Proxy @ChecksumAlgorithm)+----------------------------------------------------------------------------+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.+ --+ , stackFrameName :: Text+ -- ^+ -- The name of the stack frame, typically a method name.+ --+ , stackFrameSource :: Maybe Source+ -- ^+ -- 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.+ --+ , 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.+ --+ , stackFrameEndLine :: Maybe Int+ -- ^+ -- The end line of the range covered by the stack frame.+ --+ , stackFrameEndColumn :: Maybe 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.+ --+ , stackFrameCanRestart :: Maybe 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.+ --+ , stackFrameInstructionPointerReference :: Maybe Text+ -- ^+ -- A memory reference for the current instruction pointer in this frame.+ --+ , stackFrameModuleId :: Maybe (Either Int Text)+ -- ^+ -- 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'+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultStackFrame :: StackFrame+defaultStackFrame+ = StackFrame+ { stackFrameId = 0+ , stackFrameName = mempty+ , stackFrameSource = Nothing+ , stackFrameLine = 0+ , stackFrameColumn = 0+ , stackFrameEndLine = Nothing+ , stackFrameEndColumn = Nothing+ , stackFrameCanRestart = Nothing+ , stackFrameInstructionPointerReference = Nothing+ , stackFrameModuleId = Nothing+ , stackFramePresentationHint = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON StackFrame where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data Thread+ = Thread+ { threadId :: Int+ -- ^ Unique identifier for the thread.+ --+ , threadName :: Text+ -- ^ The name of the thread.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultThread :: Thread+defaultThread+ = Thread+ { threadId = 0+ , threadName = "<main>"+ }+----------------------------------------------------------------------------+instance ToJSON Thread where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+instance FromJSON Thread where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+defaultCapabilities :: Capabilities+defaultCapabilities = capabilities+ where+ capabilities = Capabilities+ { supportsConfigurationDoneRequest = False+ , supportsFunctionBreakpoints = False+ , supportsConditionalBreakpoints = False+ , supportsHitConditionalBreakpoints = False+ , supportsEvaluateForHovers = False+ , exceptionBreakpointFilters = []+ , supportsStepBack = False+ , supportsSetVariable = False+ , supportsRestartFrame = False+ , supportsGotoTargetsRequest = False+ , supportsStepInTargetsRequest = False+ , supportsCompletionsRequest = False+ , completionTriggerCharacters = []+ , supportsModulesRequest = False+ , additionalModuleColumns = []+ , supportedChecksumAlgorithms = []+ , supportsRestartRequest = False+ , supportsExceptionOptions = False+ , supportsValueFormattingOptions = False+ , supportsExceptionInfoRequest = False+ , supportTerminateDebuggee = False+ , supportSuspendDebuggee = False+ , supportsDelayedStackTraceLoading = False+ , supportsLoadedSourcesRequest = False+ , supportsLogPoints = False+ , supportsTerminateThreadsRequest = False+ , supportsSetExpression = False+ , supportsTerminateRequest = False+ , supportsDataBreakpoints = False+ , supportsReadMemoryRequest = False+ , supportsWriteMemoryRequest = False+ , supportsDisassembleRequest = False+ , supportsCancelRequest = False+ , supportsBreakpointLocationsRequest = False+ , supportsClipboardContext = False+ , supportsSteppingGranularity = False+ , supportsInstructionBreakpoints = False+ , supportsExceptionFilterOptions = False+ , supportsSingleThreadExecutionRequests = False+ }+----------------------------------------------------------------------------+data Capabilities+ = Capabilities+ { supportsConfigurationDoneRequest :: Bool+ -- ^ The debug adapter supports the `configurationDone` request.+ --+ , supportsFunctionBreakpoints :: Bool+ -- ^ The debug adapter supports function breakpoints.+ --+ , supportsConditionalBreakpoints :: Bool+ -- ^ The debug adapter supports conditional breakpoints.+ --+ , supportsHitConditionalBreakpoints :: Bool+ -- ^ The debug adapter supports breakpoints that break execution after a+ -- specified number of hits.+ --+ , supportsEvaluateForHovers :: Bool+ -- ^ The debug adapter supports a (side effect free) `evaluate` request for data+ -- hovers.+ --+ , exceptionBreakpointFilters :: [ExceptionBreakpointsFilter]+ -- ^ Available exception filter options for the `setExceptionBreakpoints`+ -- ^ request.+ --+ , supportsStepBack :: Bool+ -- ^ The debug adapter supports stepping back via the `stepBack` and+ -- ^ `reverseContinue` requests.+ --+ , supportsSetVariable :: Bool+ -- ^ The debug adapter supports setting a variable to a value.+ --+ , supportsRestartFrame :: Bool+ -- ^ The debug adapter supports restarting a frame.+ --+ , supportsGotoTargetsRequest :: Bool+ -- ^ The debug adapter supports the `gotoTargets` request.+ --+ , supportsStepInTargetsRequest :: Bool+ -- ^ The debug adapter supports the `stepInTargets` request.+ --+ , supportsCompletionsRequest :: Bool+ -- ^ The debug adapter supports the `completions` request.+ --+ , completionTriggerCharacters :: [Text]+ -- ^ The set of characters that should trigger completion in a REPL. If not+ -- ^ specified, the UI should assume the `.` character.+ --+ , supportsModulesRequest :: Bool+ -- ^ The debug adapter supports the `modules` request.+ --+ , additionalModuleColumns :: [ColumnDescriptor]+ -- ^ The set of additional module information exposed by the debug adapter.+ --+ , supportedChecksumAlgorithms :: [ChecksumAlgorithm]+ -- ^ Checksum algorithms supported by the debug adapter.+ --+ , supportsRestartRequest :: Bool+ -- ^ The debug adapter , supports the `restart` request. In this case a client+ -- ^ should not implement `restart` by terminating and relaunching the adapter+ -- ^ but by calling the `restart` request.+ --+ , supportsExceptionOptions :: Bool+ -- ^ The debug adapter , supports `exceptionOptions` on the+ -- ^ `setExceptionBreakpoints` request.+ --+ , supportsValueFormattingOptions :: Bool+ -- ^ The debug adapter , supports a `format` attribute on the `stackTrace`,+ -- ^ `variables`, and `evaluate` requests.+ --+ , supportsExceptionInfoRequest :: Bool+ -- ^ The debug adapter , supports the `exceptionInfo` request.+ --+ , supportTerminateDebuggee :: Bool+ -- ^ The debug adapter , supports the `terminateDebuggee` attribute on the `disconnect` request.+ --+ , supportSuspendDebuggee :: Bool+ -- ^ The debug adapter , supports the `suspendDebuggee` attribute on the `disconnect` request.+ --+ , supportsDelayedStackTraceLoading :: Bool+ -- ^ The debug adapter , supports the delayed loading of parts of the stack, which+ -- ^ requires that both the `startFrame` and `levels` arguments and the+ -- ^ `totalFrames` result of the `stackTrace` request are supported.+ --+ , supportsLoadedSourcesRequest :: Bool+ -- ^ The debug adapter , supports the `loadedSources` request.+ --+ , supportsLogPoints :: Bool+ -- ^ The debug adapter , supports log points by interpreting the `logMessage`+ -- ^ attribute of the `SourceBreakpoint`.+ --+ , supportsTerminateThreadsRequest :: Bool+ -- ^ The debug adapter , supports the `terminateThreads` request.+ --+ , supportsSetExpression :: Bool+ -- ^ The debug adapter , supports the `setExpression` request.+ --+ , supportsTerminateRequest :: Bool+ -- ^ The debug adapter , supports the `terminate` request.+ --+ , supportsDataBreakpoints :: Bool+ -- ^ The debug adapter , supports data breakpoints.+ --+ , supportsReadMemoryRequest :: Bool+ -- ^ The debug adapter , supports the `readMemory` request.+ --+ , supportsWriteMemoryRequest :: Bool+ -- ^ The debug adapter , supports the `writeMemory` request.+ --+ , supportsDisassembleRequest :: Bool+ -- ^ The debug adapter , supports the `disassemble` request.+ --+ , supportsCancelRequest :: Bool+ -- ^ The debug adapter , supports the `cancel` request.+ --+ , supportsBreakpointLocationsRequest :: Bool+ -- ^ The debug adapter , supports the `breakpointLocations` request.+ --+ , supportsClipboardContext :: Bool+ -- ^ The debug adapter , supports the `clipboard` context value in the `evaluate`+ -- request.+ --+ , supportsSteppingGranularity :: Bool+ -- ^ The debug adapter , supports stepping granularities (argument `granularity`)+ -- for the stepping requests.+ --+ , supportsInstructionBreakpoints :: Bool+ -- ^ The debug adapter , supports adding breakpoints based on instruction+ -- references.+ --+ , supportsExceptionFilterOptions :: Bool+ -- ^ The debug adapter , supports `filterOptions` as an argument on the+ -- `setExceptionBreakpoints` request.+ --+ , supportsSingleThreadExecutionRequests :: Bool+ -- ^ The debug adapter , supports the `singleThread` property on the execution+ -- requests (`continue`, `next`, `stepIn`, `stepOut`, `reverseContinue`,+ -- `stepBack`).+ --+ } deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)+----------------------------------------------------------------------------+data EventType+ = EventTypeInitialized+ | EventTypeStopped+ | EventTypeContinued+ | EventTypeExited+ | EventTypeTerminated+ | EventTypeThread+ | EventTypeOutput+ | EventTypeBreakpoint+ | EventTypeModule+ | EventTypeLoadedSource+ | EventTypeProcess+ | EventTypeCapabilities+ | EventTypeProgressStart+ | EventTypeProgressUpdate+ | EventTypeProgressEnd+ | EventTypeInvalidated+ | EventTypeMemory+ deriving stock (Show, Eq, Read, Generic)+----------------------------------------------------------------------------+instance ToJSON EventType where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data Command+ = CommandCancel+ | CommandRunInTerminal+ | CommandStartDebugging+ | CommandInitialize+ | CommandConfigurationDone+ | CommandLaunch+ | CommandAttach+ | CommandRestart+ | CommandDisconnect+ | CommandTerminate+ | CommandBreakpointLocations+ | CommandSetBreakpoints+ | CommandSetFunctionBreakpoints+ | CommandSetExceptionBreakpoints+ | CommandDataBreakpointInfo+ | CommandSetDataBreakpoints+ | CommandSetInstructionBreakpoints+ | CommandContinue+ | CommandNext+ | CommandStepIn+ | CommandStepOut+ | CommandStepBack+ | CommandReverseContinue+ | CommandRestartFrame+ | CommandGoTo+ | CommandPause+ | CommandStackTrace+ | CommandScopes+ | CommandVariables+ | CommandSetVariable+ | CommandSource+ | CommandThreads+ | CommandTerminateThreads+ | CommandModules+ | CommandLoadedSources+ | CommandEvaluate+ | CommandSetExpression+ | CommandStepInTargets+ | CommandGoToTargets+ | CommandCompletions+ | CommandExceptionInfo+ | CommandReadMemory+ | CommandWriteMemory+ | CommandDisassemble+ | CustomCommand Text+ deriving stock (Show, Eq, Read, Generic)+----------------------------------------------------------------------------+instance FromJSON Command where+ parseJSON = withText name $ \command ->+ case readMaybe (name <> capitalize (T.unpack command)) of+ Just cmd ->+ pure cmd+ Nothing ->+ pure (CustomCommand command)+ where+ name = show (typeRep (Proxy @Command))+----------------------------------------------------------------------------+instance ToJSON Command where+ toJSON (CustomCommand x) = toJSON x+ toJSON cmd = genericToJSONWithModifier cmd+----------------------------------------------------------------------------+data ErrorMessage+ = ErrorMessageCancelled+ | ErrorMessageNotStopped+ | ErrorMessage Text+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance IsString ErrorMessage where+ fromString = ErrorMessage . T.pack+----------------------------------------------------------------------------+instance ToJSON ErrorMessage where+ toJSON (ErrorMessage e) = toJSON e+ toJSON msg = genericToJSONWithModifier msg+----------------------------------------------------------------------------+data BreakpointLocation+ = BreakpointLocation+ { breakpointLocationLine :: Int+ -- ^+ -- Start line of breakpoint location.+ --+ , breakpointLocationColumn :: Maybe Int+ -- ^+ -- The start position of a breakpoint location. Position is measured in UTF-16+ -- code units and the client capability `columnsStartAt1` determines whether+ -- it is 0- or 1-based.+ --+ , breakpointLocationEndLine :: Maybe Int+ -- ^+ -- The end line of breakpoint location if the location covers a range.+ --+ , breakpointLocationEndColumn :: Maybe Int+ -- ^+ -- The end position of a breakpoint location (if the location covers a range).+ -- Position is measured in UTF-16 code units and the client capability+ -- `columnsStartAt1` determines whether it is 0- or 1-based.+ --+ } deriving stock (Eq, Show, Generic)+----------------------------------------------------------------------------+defaultBreakpointLocation :: BreakpointLocation+defaultBreakpointLocation+ = BreakpointLocation+ { breakpointLocationLine = 0+ , breakpointLocationColumn = Nothing+ , breakpointLocationEndLine = Nothing+ , breakpointLocationEndColumn = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON BreakpointLocation where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ContinueResponse+ = ContinueResponse+ { continueResponseAllThreadsContinued :: Bool+ -- ^+ -- The value true (or a missing property) signals to the client that all+ -- threads have been resumed. The value false indicates that not all threads+ -- were resumed.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ContinueResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+-- | On error (whenever success is false), the body can provide more details.+newtype ErrorResponse+ = ErrorResponse+ { errorResponseError :: Maybe Message+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ErrorResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data Message+ = Message+ { messageId :: Int+ -- ^+ -- Unique (within a debug adapter implementation) identifier for the message.+ -- The purpose of these error IDs is to help extension authors that have the+ -- requirement that every user visible error message needs a corresponding+ -- error number, so that users or customer support can find information about+ -- the specific error more easily.+ --+ , messageFormat :: Text+ -- ^+ -- A format string for the message. Embedded variables have the form `{name}`.+ -- If variable name starts with an underscore character, the variable does not+ -- contain user data (PII) and can be safely used for telemetry purposes.+ --+ , messageVariables :: Maybe (H.HashMap Text Text)+ -- ^+ -- An object used as a dictionary for looking up the variables in the format+ -- string.+ --+ , messageSendTelemetry :: Maybe Bool+ -- ^+ -- If true send to telemetry.+ --+ , messageShowUser :: Maybe Bool+ -- ^+ -- If true show user.+ --+ , messageUrl :: Maybe Text+ -- ^+ -- A url where additional information about this message can be found.+ --+ , messageUrlLabel :: Maybe Text+ -- ^+ -- A label that is presented to the user as the UI for opening the url.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultMessage :: Message+defaultMessage+ = Message+ { messageId = 0+ , messageFormat = mempty+ , messageVariables = Nothing+ , messageSendTelemetry = Nothing+ , messageShowUser = Nothing+ , messageUrl = Nothing+ , messageUrlLabel = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON Message where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data RunInTerminalResponse+ = RunInTerminalResponse+ { runInTerminalResponseProcessId :: Maybe Int+ -- ^+ -- The process ID. The value should be less than or equal to 2147483647+ -- (2^31-1).+ --+ , runInTerminalResponseShellProcessId :: Maybe Int+ -- ^+ -- The process ID of the terminal shell. The value should be less than or+ -- equal to 2147483647 (2^31-1).+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON RunInTerminalResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ModulesResponse+ = ModulesResponse+ { modulesResponseModules :: [Module]+ -- ^+ -- All modules or range of modules.+ --+ , modulesResponseTotalModules :: Maybe Int+ -- ^+ -- The total number of modules available.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ModulesResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data Module+ = Module+ { moduleId :: Either Text Int+ -- ^+ -- Unique identifier for the module.+ --+ , moduleName :: Text+ -- ^+ -- A name of the module.+ --+ , modulePath :: Maybe Text+ -- ^+ -- Logical full path to the module. The exact definition is implementation+ -- defined, but usually this would be a full path to the on-disk file for the+ -- module.+ --+ , moduleIsOptimized :: Maybe Bool+ -- ^+ -- True if the module is optimized.+ --+ , moduleIsUserCode :: Maybe Bool+ -- ^+ -- True if the module is considered 'user code' by a debugger that supports+ -- 'Just My Code'.+ --+ , moduleVersion :: Maybe Text+ -- ^+ -- Version of Module.+ --+ , moduleSymbolStatus :: Maybe Text+ -- ^+ -- User-understandable description of if symbols were found for the module+ -- (ex: 'Symbols Loaded', 'Symbols not found', etc.)+ --+ , moduleSymbolFilePath :: Maybe Text+ -- ^+ -- Logical full path to the symbol file. The exact definition is+ -- implementation defined.+ --+ , moduleDateTimeStamp :: Maybe Text+ -- ^+ -- Module created or modified, encoded as a RFC 3339 timestamp.+ --+ , moduleAddressRange :: Maybe Text+ -- ^+ -- Address range covered by this module.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON Module where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+defaultModule :: Module+defaultModule+ = Module+ { moduleId = Right 0+ , moduleName = mempty+ , modulePath = mempty+ , moduleIsOptimized = Nothing+ , moduleIsUserCode = Nothing+ , moduleVersion = Nothing+ , moduleSymbolStatus = Nothing+ , moduleSymbolFilePath = Nothing+ , moduleDateTimeStamp = Nothing+ , moduleAddressRange = Nothing+ }+----------------------------------------------------------------------------+data DataBreakpointInfoResponse+ = DataBreakpointInfoResponse+ { dataBreakpointInfoResponseDataId :: Maybe Text+ -- ^+ -- An identifier for the data on which a data breakpoint can be registered+ -- with the `setDataBreakpoints` request or null if no data breakpoint is+ -- available.+ --+ , dataBreakpointInfoResponseDescription :: Text+ -- ^+ -- UI string that describes on what data the breakpoint is set on or why a+ -- data breakpoint is not available.+ --+ , dataBreakpointInfoResponseDescriptionAccessTypes :: [DataBreakpointAccessType]+ -- ^+ -- Attribute lists the available access types for a potential data+ -- breakpoint. A UI client could surface this information.+ --+ , dataBreakpointInfoResponseDescriptionCanPersist :: Maybe Bool+ -- ^+ -- Attribute indicates that a potential data breakpoint could be persisted+ -- across sessions.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON DataBreakpointInfoResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+-- | This enumeration defines all possible access types for data breakpoints.+-- Values: ‘read’, ‘write’, ‘readWrite’+data DataBreakpointAccessType+ = DataBreakpointAccessTypeRead+ | DataBreakpointAccessTypeWrite+ | DataBreakpointAccessTypeReadWrite+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON DataBreakpointAccessType where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+-- | type DataBreakpointAccessType = 'read' | 'write' | 'readWrite';+instance ToJSON DataBreakpointAccessType where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data StackTraceResponse+ = StackTraceResponse+ { stackFrames :: [StackFrame]+ -- ^+ -- The frames of the stack frame. If the array has length zero, there are no+ -- stack frames available.+ -- This means that there is no location information available.+ --+ , totalFrames :: Maybe Int+ -- ^+ -- The total number of frames available in the stack. If omitted or if+ -- `totalFrames` is larger than the available frames, a client is expected+ -- to request frames until a request returns less frames than requested+ -- (which indicates the end of the stack). Returning monotonically+ -- increasing `totalFrames` values for subsequent requests can be used to+ -- enforce paging in the client.+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON StackTraceResponse where+ toJSON StackTraceResponse {..}+ = object+ [ "stackFrames" .= stackFrames+ , "totalFrames" .= totalFrames+ ]+----------------------------------------------------------------------------+newtype ScopesResponse+ = ScopesResponse+ { scopes :: [Scope]+ -- ^+ -- The scopes of the stack frame. If the array has length zero, there are no+ -- scopes available.+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON ScopesResponse where+ toJSON ScopesResponse {..}+ = object+ [ "scopes" .= scopes+ ]+----------------------------------------------------------------------------+data Scope+ = Scope+ { scopeName :: Text+ -- ^+ -- Name of the scope such as 'Arguments', 'Locals', or 'Registers'. This+ -- string is shown in the UI as is and can be translated.+ --+ , scopePresentationHint :: Maybe ScopePresentationHint+ -- ^+ -- A hint for how to present this scope in the UI. If this attribute is+ -- missing, the scope is shown with a generic UI.+ -- Values:+ -- 'arguments': Scope contains method arguments.+ -- 'locals': Scope contains local variables.+ -- 'registers': Scope contains registers. Only a single `registers` scope+ -- should be returned from a `scopes` request.+ -- etc.+ --+ , scopeVariablesReference :: Int+ -- ^+ -- The variables of this scope can be retrieved by passing the value of+ -- `variablesReference` to the `variables` request as long as execution+ -- remains suspended. See 'Lifetime of Object References' in the Overview+ -- section for details.+ --+ , scopeNamedVariables :: Maybe Int+ -- ^+ -- The number of named variables in this scope.+ -- The client can use this information to present the variables in a paged UI+ -- and fetch them in chunks.+ --+ , scopeIndexedVariables :: Maybe Int+ -- ^+ -- The number of indexed variables in this scope.+ -- The client can use this information to present the variables in a paged UI+ -- and fetch them in chunks.+ --+ , scopeExpensive :: Bool+ -- ^+ -- If true, the number of variables in this scope is large or expensive to+ -- retrieve.+ --+ , scopeSource :: Maybe Source+ -- ^+ -- The source for this scope.+ --+ , scopeLine :: Maybe Int+ -- ^+ -- The start line of the range covered by this scope.+ --+ , scopeColumn :: Maybe Int+ -- ^+ -- Start position of the range covered by the scope. It is measured in UTF-16+ -- code units and the client capability `columnsStartAt1` determines whether+ -- it is 0- or 1-based.+ --+ , scopeEndLine :: Maybe Int+ -- ^+ -- The end line of the range covered by this scope.+ --+ , scopeEndColumn :: Maybe Int+ -- ^+ -- End position of the range covered by the scope. It is measured in UTF-16+ -- code units and the client capability `columnsStartAt1` determines whether+ -- it is 0- or 1-based.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultScope :: Scope+defaultScope+ = Scope+ { scopeName = mempty+ , scopePresentationHint = Nothing+ , scopeVariablesReference = 0+ , scopeNamedVariables = Nothing+ , scopeIndexedVariables = Nothing+ , scopeExpensive = False+ , scopeSource = Nothing+ , scopeLine = Nothing+ , scopeColumn = Nothing+ , scopeEndLine = Nothing+ , scopeEndColumn = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON Scope where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ScopePresentationHint+ = ScopePresentationHintArguments+ | ScopePresentationHintLocals+ | ScopePresentationHintRegisters+ | ScopePresentationHint Text+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ScopePresentationHint where+ toJSON (ScopePresentationHint hint) = toJSON hint+ toJSON hint = genericToJSONWithModifier hint+----------------------------------------------------------------------------+data VariablesResponse+ = VariablesResponse+ { variables :: [Variable]+ -- ^+ -- All (or a range) of variables for the given variable reference.+ --+ } deriving stock (Show, Eq, Generic)+ deriving anyclass ToJSON+----------------------------------------------------------------------------+data Variable+ = Variable+ { variableName :: Text+ -- ^+ -- The variable's name.+ --+ , variableValue :: Text+ -- ^+ -- The variable's value.+ -- This can be a multi-line text, e.g. for a function the body of a function.+ -- For structured variables (which do not have a simple value), it is+ -- recommended to provide a one-line representation of the structured object.+ -- This helps to identify the structured object in the collapsed state when+ -- its children are not yet visible.+ -- An empty string can be used if no value should be shown in the UI.+ --+ , variableType :: Maybe Text+ -- ^+ -- The type of the variable's value. Typically shown in the UI when hovering+ -- over the value.+ -- This attribute should only be returned by a debug adapter if the+ -- corresponding capability `supportsVariableType` is true.+ --+ , variablePresentationHint :: Maybe VariablePresentationHint+ -- ^+ -- Properties of a variable that can be used to determine how to render the+ -- variable in the UI.+ --+ , variableEvaluateName :: Maybe Text+ -- ^+ -- The evaluatable name of this variable which can be passed to the `evaluate`+ -- request to fetch the variable's value.+ --+ , variableVariablesReference :: Int+ -- ^+ -- If `variablesReference` is > 0, the variable is structured and its children+ -- can be retrieved by passing `variablesReference` to the `variables` request+ -- as long as execution remains suspended. See 'Lifetime of Object References'+ -- in the Overview section for details.+ --+ , variableNamedVariables :: Maybe Int+ -- ^+ -- The number of named child variables.+ -- The client can use this information to present the children in a paged UI+ -- and fetch them in chunks.+ --+ , variableIndexedVariables :: Maybe Int+ -- ^+ -- The number of indexed child variables.+ -- The client can use this information to present the children in a paged UI+ -- and fetch them in chunks.+ --+ , variableMemoryReference :: Maybe Text+ -- ^+ -- The memory reference for the variable if the variable represents executable+ -- code, such as a function pointer.+ -- This attribute is only required if the corresponding capability+ -- `supportsMemoryReferences` is true.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultVariable :: Variable+defaultVariable+ = Variable+ { variableName = mempty+ , variableValue = mempty+ , variableType = Nothing+ , variablePresentationHint = Nothing+ , variableEvaluateName = Nothing+ , variableVariablesReference = 0+ , variableNamedVariables = Nothing+ , variableIndexedVariables = Nothing+ , variableMemoryReference = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON Variable where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data VariablePresentationHint+ = VariablePresentationHint+ { variablePresentationHintKind :: Maybe PresentationHintKind+ -- ^+ -- The kind of variable. Before introducing additional values, try to use the+ -- listed values.+ -- Values:+ -- 'property': Indicates that the object is a property.+ -- 'method': Indicates that the object is a method.+ -- 'class': Indicates that the object is a class.+ -- 'data': Indicates that the object is data.+ -- 'event': Indicates that the object is an event.+ -- 'baseClass': Indicates that the object is a base class.+ -- 'innerClass': Indicates that the object is an inner class.+ -- 'interface': Indicates that the object is an interface.+ -- 'mostDerivedClass': Indicates that the object is the most derived class.+ -- 'virtual': Indicates that the object is virtual, that means it is a+ -- synthetic object introduced by the adapter for rendering purposes, e.g. an+ -- index range for large arrays.+ -- 'dataBreakpoint': Deprecated: Indicates that a data breakpoint is+ -- registered for the object. The `hasDataBreakpoint` attribute should+ -- generally be used instead.+ -- etc.+ --+ , variablePresentationHintAttributes :: Maybe [PresentationHintAttributes]+ -- ^+ -- Set of attributes represented as an array of strings. Before introducing+ -- additional values, try to use the listed values.+ -- Values:+ -- 'static': Indicates that the object is static.+ -- 'constant': Indicates that the object is a constant.+ -- 'readOnly': Indicates that the object is read only.+ -- 'rawText': Indicates that the object is a raw string.+ -- 'hasObjectId': Indicates that the object can have an Object ID created for+ -- it.+ -- 'canHaveObjectId': Indicates that the object has an Object ID associated+ -- with it.+ -- 'hasSideEffects': Indicates that the evaluation had side effects.+ -- 'hasDataBreakpoint': Indicates that the object has its value tracked by a+ -- data breakpoint.+ -- etc.+ --+ , variablePresentationHintVisibility :: Maybe PresentationHintVisibility+ -- ^+ -- Visibility of variable. Before introducing additional values, try to use+ -- the listed values.+ -- Values: 'public', 'private', 'protected', 'internal', 'final', etc.+ --+ , variablePresentationHintLazy :: Maybe Bool+ -- ^+ -- If true, clients can present the variable with a UI that supports a+ -- specific gesture to trigger its evaluation.+ -- This mechanism can be used for properties that require executing code when+ -- retrieving their value and where the code execution can be expensive and/or+ -- produce side-effects. A typical example are properties based on a getter+ -- function.+ -- Please note that in addition to the `lazy` flag, the variable's+ -- `variablesReference` is expected to refer to a variable that will provide+ -- the value through another `variable` request.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultVariablePresentationHint :: VariablePresentationHint+defaultVariablePresentationHint+ = VariablePresentationHint+ { variablePresentationHintKind = Nothing+ , variablePresentationHintAttributes = Nothing+ , variablePresentationHintVisibility = Nothing+ , variablePresentationHintLazy = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON VariablePresentationHint where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data PresentationHintVisibility+ = PresentationHintVisibilityPublic+ | PresentationHintVisibilityPrivate+ | PresentationHintVisibilityProtected+ | PresentationHintVisibilityInternal+ | PresentationHintVisibilityFinal+ | PresentationHintVisibility String+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+-- | ?: 'public' | 'private' | 'protected' | 'internal' | 'final' | string;+instance ToJSON PresentationHintVisibility where+ toJSON (PresentationHintVisibility hint) = toJSON hint+ toJSON hint = genericToJSONWithModifier hint+----------------------------------------------------------------------------+data PresentationHintAttributes+ = PresentationHintAttributesStatic+ | PresentationHintAttributesConstant+ | PresentationHintAttributesReadOnly+ | PresentationHintAttributesRawText+ | PresentationHintAttributesHasObjectId+ | PresentationHintAttributesCanHaveObjectId+ | PresentationHintAttributesHasSideEffects+ | PresentationHintAttributesHasDataBreakpoint+ | PresentationHintAttributes String+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+-- | attributes?: ('static' | 'constant' | 'readOnly' | 'rawText' | 'hasObjectId'+-- 'canHaveObjectId' | 'hasSideEffects' | 'hasDataBreakpoint' | string)[];+instance ToJSON PresentationHintAttributes where+ toJSON (PresentationHintAttributes x) = toJSON x+ toJSON hint = genericToJSONWithModifier hint+----------------------------------------------------------------------------+data PresentationHintKind+ = PresentationHintKindProperty+ | PresentationHintKindMethod+ | PresentationHintKindClass+ | PresentationHintKindData+ | PresentationHintKindEvent+ | PresentationHintKindBaseClass+ | PresentationHintKindInnerClass+ | PresentationHintKindInterface+ | PresentationHintKindMostDerivedClass+ | PresentationHintKindVirtual+ | PresentationHintKindDataBreakpoint+ | PresentationHintKind Text+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON PresentationHintKind where+ toJSON (PresentationHintKind x) = toJSON x+ toJSON kind = genericToJSONWithModifier kind+----------------------------------------------------------------------------+data SetVariableResponse+ = SetVariableResponse+ { setVariableResponseValue :: Text+ -- ^+ -- The new value of the variable.+ --+ , setVariableResponseType :: Maybe Text+ -- ^+ -- The type of the new value. Typically shown in the UI when hovering over+ -- the value.+ --+ , setVariableResponseReference :: Maybe Int+ -- ^+ -- If `variablesReference` is > 0, the new value is structured and its+ -- children can be retrieved by passing `variablesReference` to the+ -- `variables` request as long as execution remains suspended. See 'Lifetime+ -- of Object References' in the Overview section for details.+ --+ , setVariableResponseNamedVariables :: Maybe Int+ -- ^+ -- The number of named child variables.+ -- The client can use this information to present the variables in a paged+ -- UI and fetch them in chunks.+ -- The value should be less than or equal to 2147483647 (2^31-1).+ --++ , setVariableResponseIndexedVariables :: Maybe Int+ -- ^+ -- The number of indexed child variables.+ -- The client can use this information to present the variables in a paged+ -- UI and fetch them in chunks.+ -- The value should be less than or equal to 2147483647 (2^31-1).+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON SetVariableResponse where+ toJSON SetVariableResponse {..}+ = object+ [ "value" .= setVariableResponseValue+ , "type" .= setVariableResponseType+ , "reference" .= setVariableResponseReference+ , "variables" .= setVariableResponseNamedVariables+ , "indexedVariables" .= setVariableResponseIndexedVariables+ ]+----------------------------------------------------------------------------+data SourceResponse+ = SourceResponse+ { sourceResponseContent :: Text+ -- ^+ -- Content of the source reference.+ --+ , sourceResponseMimeType :: Maybe Text+ -- ^+ -- Content type (MIME type) of the source.+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON SourceResponse where+ toJSON SourceResponse {..}+ = object+ [ "content" .= sourceResponseContent+ , "mimeType" .= sourceResponseMimeType+ ]+----------------------------------------------------------------------------+newtype ThreadsResponse+ = ThreadsResponse+ { threads :: [Thread]+ -- ^+ -- All threads.+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON ThreadsResponse where+ toJSON (ThreadsResponse ts)+ = object+ [ "threads" .= ts+ ]+----------------------------------------------------------------------------+data LoadedSourcesResponse+ = LoadedSourcesResponse+ { loadedSourcesResponseSources :: [Source]+ -- ^+ -- Set of loaded sources.+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON LoadedSourcesResponse where+ toJSON LoadedSourcesResponse {..}+ = object+ [ "sources" .= loadedSourcesResponseSources+ ]+----------------------------------------------------------------------------+data EvaluateResponse+ = EvaluateResponse+ { evaluateResponseResult :: Text+ -- ^+ -- The result of the evaluate request.+ --+ , evaluateResponseType :: Text+ -- ^+ -- The type of the evaluate result.+ -- This attribute should only be returned by a debug adapter if the+ -- corresponding capability `supportsVariableType` is true.+ --+ , evaluateResponsePresentationHint :: Maybe VariablePresentationHint+ -- ^+ -- Properties of an evaluate result that can be used to determine how to+ -- render the result in the UI.+ --+ , evaluateResponseVariablesReference :: Int+ -- ^+ -- If `variablesReference` is > 0, the evaluate result is structured and its+ -- children can be retrieved by passing `variablesReference` to the+ -- `variables` request as long as execution remains suspended. See 'Lifetime+ -- of Object References' in the Overview section for details.+ --+ , evaluateResponseNamedVariables :: Maybe Int+ -- ^+ -- The number of named child variables.+ -- The client can use this information to present the variables in a paged+ -- UI and fetch them in chunks.+ -- The value should be less than or equal to 2147483647 (2^31-1).+ --+ , evaluateResponseIndexedVariables :: Maybe Int+ -- ^+ -- The number of indexed child variables.+ -- The client can use this information to present the variables in a paged+ -- UI and fetch them in chunks.+ -- The value should be less than or equal to 2147483647 (2^31-1).+ --+ , evaluateResponseMemoryReference :: Maybe Text+ -- ^+ -- A memory reference to a location appropriate for this result.+ -- For pointer type eval results, this is generally a reference to the+ -- memory address contained in the pointer.+ -- This attribute should be returned by a debug adapter if corresponding+ -- capability `supportsMemoryReferences` is true.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON EvaluateResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data SetExpressionResponse+ = SetExpressionResponse+ { setExpressionResponseValue :: Text+ -- ^+ -- The new value of the expression.+ --+ , setExpressionResponseType :: Maybe Text+ -- ^+ -- The type of the value.+ -- This attribute should only be returned by a debug adapter if the+ -- corresponding capability `supportsVariableType` is true.+ --+ , setExpressionResponsePresentationHint :: Maybe VariablePresentationHint+ -- ^+ -- Properties of a value that can be used to determine how to render the+ -- result in the UI.+ --+ , setExpressionResponseVariablesReference:: Maybe Int+ -- ^+ -- If `variablesReference` is > 0, the evaluate result is structured and its+ -- children can be retrieved by passing `variablesReference` to the+ -- `variables` request as long as execution remains suspended. See 'Lifetime+ -- of Object References' in the Overview section for details.+ --+ , setExpressionResponseNamedVariables:: Maybe Int+ -- ^+ -- The number of named child variables.+ -- The client can use this information to present the variables in a paged+ -- UI and fetch them in chunks.+ -- The value should be less than or equal to 2147483647 (2^31-1).+ --+ , setExpressionResponseIndexedVariables:: Maybe Int+ -- ^+ -- The number of indexed child variables.+ -- The client can use this information to present the variables in a paged+ -- UI and fetch them in chunks.+ -- The value should be less than or equal to 2147483647 (2^31-1).+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON SetExpressionResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data StepInTargetsResponse+ = StepInTargetsResponse+ { stepInTargetsResponseTargets :: [StepInTarget]+ -- ^+ -- The possible step-in targets of the specified source location.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON StepInTargetsResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data StepInTarget+ = StepInTarget+ { stepInTargetId :: Int+ -- ^+ -- Unique identifier for a step-in target.+ --+ , stepInTargetLabel :: Text+ -- ^+ -- The name of the step-in target (shown in the UI).+ --+ , stepInTargetLine :: Maybe Int+ -- ^+ -- The line of the step-in target.+ --+ , stepInTargetColumn :: Maybe Int+ -- ^+ -- Start position of the range covered by the step in target. It is measured+ -- in UTF-16 code units and the client capability `columnsStartAt1` determines+ -- whether it is 0- or 1-based.+ --+ , stepInTargetEndLine :: Maybe Int+ -- ^+ -- The end line of the range covered by the step-in target.+ --+ , stepInTargetEndColumn :: Maybe Int+ -- ^ End position of the range covered by the step in target. It is measured in+ -- UTF-16 code units and the client capability `columnsStartAt1` determines+ -- whether it is 0- or 1-based.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultStepInTarget :: StepInTarget+defaultStepInTarget+ = StepInTarget+ { stepInTargetId = 0+ , stepInTargetLabel = mempty+ , stepInTargetLine = Nothing+ , stepInTargetColumn = Nothing+ , stepInTargetEndLine = Nothing+ , stepInTargetEndColumn = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON StepInTarget where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data GotoTargetsResponse+ = GotoTargetsResponse+ { goToTargetsResponseTargets :: [GotoTarget]+ -- ^+ -- The possible goto targets of the specified location.+ --+ } 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).+ --+ , gotoTargetLine :: Int+ -- ^+ -- The line of the gotoTarget target.+ --+ , gotoTargetColumn :: Maybe Int+ -- ^+ -- The column of the gotoTarget target.+ --+ , gotoTargetEndLine :: Maybe 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)+----------------------------------------------------------------------------+defaultGotoTarget :: GotoTarget+defaultGotoTarget+ = GotoTarget+ { gotoTargetId = 0+ , gotoTargetLabel = mempty+ , gotoTargetLine = 0+ , gotoTargetColumn = Nothing+ , gotoTargetEndLine = Nothing+ , gotoTargetEndColumn = Nothing+ , gotoTargetInstructionPointerReference = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON GotoTarget where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data CompletionsResponse+ = CompletionsResponse+ { completionResponseTargets :: [CompletionItem]+ -- ^+ -- The possible completions for .+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON CompletionsResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data CompletionItem+ = CompletionItem+ { completionItemLabel :: String+ -- ^+ -- The label of this completion item. By default this is also the text that is+ -- inserted when selecting this completion.+ --+ , completionItemText :: Maybe String+ -- ^+ -- If text is returned and not an empty string, then it is inserted instead of+ -- the label.+ --+ , completionItemSortText :: Maybe String+ -- ^+ -- A string that should be used when comparing this item with other items. If+ -- not returned or an empty string, the `label` is used instead.+ --+ , completionItemDetail :: Maybe String+ -- ^+ -- A human-readable string with additional information about this item, like+ -- type or symbol information.+ --+ , completionItemType :: Maybe CompletionItemType+ -- ^+ -- The item's type. Typically the client uses this information to render the+ -- item in the UI with an icon.+ --+ , completionItemTypeStart :: Maybe Int+ -- ^+ -- Start position (within the `text` attribute of the `completions` request)+ -- where the completion text is added. The position is measured in UTF-16 code+ -- units and the client capability `columnsStartAt1` determines whether it is+ -- 0- or 1-based. If the start position is omitted the text is added at the+ -- location specified by the `column` attribute of the `completions` request.+ --+ , completionItemTypeLength :: Maybe Int+ -- ^+ -- Length determines how many characters are overwritten by the completion+ -- text and it is measured in UTF-16 code units. If missing the value 0 is+ -- assumed which results in the completion text being inserted.+ --+ , completionItemTypeSelectionStart :: Maybe Int+ -- ^+ -- Determines the start of the new selection after the text has been inserted+ -- (or replaced). `selectionStart` is measured in UTF-16 code units and must+ -- be in the range 0 and length of the completion text. If omitted the+ -- selection starts at the end of the completion text.+ --+ , completionItemTypeSelectionLength :: Maybe Int+ -- ^+ -- Determines the length of the new selection after the text has been inserted+ -- (or replaced) and it is measured in UTF-16 code units. The selection can+ -- not extend beyond the bounds of the completion text. If omitted the length+ -- is assumed to be 0.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultCompletionItem :: CompletionItem+defaultCompletionItem+ = CompletionItem+ { completionItemLabel = mempty+ , completionItemText = Nothing+ , completionItemSortText = Nothing+ , completionItemDetail = Nothing+ , completionItemType = Nothing+ , completionItemTypeStart = Nothing+ , completionItemTypeLength = Nothing+ , completionItemTypeSelectionStart = Nothing+ , completionItemTypeSelectionLength = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON CompletionItem where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+instance ToJSON CompletionItemType where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ExceptionInfoResponse+ = ExceptionInfoResponse+ { exceptionInfoResponseId :: Text+ -- ^+ -- ID of the exception that was thrown.+ --+ , exceptionInfoDescriptionId :: Maybe Text+ -- ^+ -- Descriptive text for the exception.+ --+ , exceptionInfoBreakMode :: ExceptionBreakMode+ -- ^+ -- Mode that caused the exception notification to be raised.+ --+ , exceptionInfoReponseDetails :: Maybe ExceptionDetails+ -- ^+ -- Detailed information about the exception.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+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+ { exceptionDetailsMessage :: Maybe 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 :: Maybe [ExceptionDetails]+ -- ^+ -- Details of the exception contained by this exception, if any.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultExceptionDetails :: ExceptionDetails+defaultExceptionDetails+ = ExceptionDetails+ { exceptionDetailsMessage = Nothing+ , exceptionDetailstypeName = Nothing+ , exceptionDetailsFullTypeName = Nothing+ , exceptionDetailsEvaluateName = Nothing+ , exceptionDetailsStackTrace = Nothing+ , exceptionDetailsInnerException = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON ExceptionDetails where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ReadMemoryResponse+ = ReadMemoryResponse+ { readMemoryResponseBody :: Int+ -- ^+ -- The address of the first byte of data returned.+ -- Treated as a hex value if prefixed with `0x`, or as a decimal value+ -- otherwise.+ --+ , readMemoryResponseAddress :: Text+ -- ^+ -- The number of unreadable bytes encountered after the last successfully+ -- read byte.+ -- This can be used to determine the number of bytes that should be skipped+ -- before a subsequent `readMemory` request succeeds.+ --+ , readMemoryResponseUnreadableBytes:: Maybe Int+ -- ^+ -- The bytes read from memory, encoded using base64. If the decoded length+ -- of `data` is less than the requested `count` in the original `readMemory`+ -- request, and `unreadableBytes` is zero or omitted, then the client should+ -- assume it's reached the end of readable memory.+ --+ , readMemoryResponseData :: Maybe Text+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ReadMemoryResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data WriteMemoryResponse+ = WriteMemoryResponse+ { 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+ -- negative.+ --+ , writeMemoryResponseBytesWritten :: Maybe Int+ -- ^+ -- Property that should be returned when `allowPartial` is true to indicate+ -- the number of bytes starting from address that were successfully written.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON WriteMemoryResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data DisassembleResponse+ = DisassembleResponse+ { disassembleResponseInstructions :: [DisassembledInstruction]+ -- ^+ -- The list of disassembled instructions.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON DisassembleResponse where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data DisassembledInstruction+ = DisassembledInstruction+ { disassembledInstructionAddress :: Text+ -- ^+ -- The address of the instruction. Treated as a hex value if prefixed with+ -- `0x`, or as a decimal value otherwise.+ , disassembledInstructionInstructionBytes :: Maybe Text+ -- ^+ -- Raw bytes representing the instruction and its operands, in an+ -- implementation-defined format.+ , disassembledInstructionInstruction :: Text+ -- ^+ -- Text representing the instruction and its operands, in an+ -- implementation-defined format.+ --+ , disassembledInstructionSymbol :: Maybe Text+ -- ^+ -- Name of the symbol that corresponds with the location of this instruction,+ -- if any.+ --+ , disassembledInstructionLocation :: Maybe Source+ -- ^+ -- Source location that corresponds to this instruction, if any.+ -- Should always be set (if available) on the first instruction returned,+ -- but can be omitted afterwards if this instruction maps to the same source+ -- file as the previous instruction.+ --+ , disassembledInstructionLine :: Maybe Int+ -- ^+ -- The line within the source location that corresponds to this instruction,+ -- if any.+ --+ , disassembledInstructionColumn :: Maybe Int+ -- ^+ -- The column within the line that corresponds to this instruction, if any.+ --+ , disassembledInstructionEndLine :: Maybe Int+ -- ^+ -- The end line of the range that corresponds to this instruction, if any.+ --+ , disassembledInstructionEndColumn :: Maybe Int+ -- ^+ -- The end column of the range that corresponds to this instruction, if any.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultDisassembledInstruction :: DisassembledInstruction+defaultDisassembledInstruction+ = DisassembledInstruction+ { disassembledInstructionAddress = mempty+ , disassembledInstructionInstructionBytes = Nothing+ , disassembledInstructionInstruction = mempty+ , disassembledInstructionSymbol = Nothing+ , disassembledInstructionLocation = Nothing+ , disassembledInstructionLine = Nothing+ , disassembledInstructionColumn = Nothing+ , disassembledInstructionEndLine = Nothing+ , disassembledInstructionEndColumn = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON DisassembledInstruction where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data StoppedEventReason+ = StoppedEventReasonStep+ | StoppedEventReasonBreakpoint+ | StoppedEventReasonException+ | StoppedEventReasonPause+ | StoppedEventReasonEntry+ | StoppedEventReasonGoto+ | StoppedEventReasonFunctionBreakpoint+ | StoppedEventReasonDataBreakpoint+ | StoppedEventReasonInstructionBreakpoint+ deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON StoppedEventReason where+ toJSON StoppedEventReasonStep = "step"+ toJSON StoppedEventReasonBreakpoint = "breakpoint"+ toJSON StoppedEventReasonException = "exception"+ toJSON StoppedEventReasonPause = "pause"+ toJSON StoppedEventReasonEntry = "entry"+ toJSON StoppedEventReasonGoto = "goto"+ toJSON StoppedEventReasonFunctionBreakpoint = "function breakpoint"+ toJSON StoppedEventReasonDataBreakpoint = "data breakpoint"+ toJSON StoppedEventReasonInstructionBreakpoint = "instruction breakpoint"+----------------------------------------------------------------------------+data StoppedEvent+ = StoppedEvent+ { stoppedEventReason :: StoppedEventReason+ -- ^+ -- The reason for the event.+ -- For backward compatibility this string is shown in the UI if the+ -- `description` attribute is missing (but it must not be translated).+ -- Values: 'step', 'breakpoint', 'exception', 'pause', 'entry', 'goto',+ -- 'function breakpoint', 'data breakpoint', 'instruction breakpoint', etc.+ --+ , stoppedEventDescription :: Maybe Text+ -- ^+ -- The full reason for the event, e.g. 'Paused on exception'. This string is+ -- shown in the UI as is and can be translated.+ --+ , stoppedEventThreadId :: Maybe Int+ -- ^+ -- The thread which was stopped.+ --+ , stoppedEventPreserveFocusHint :: Bool+ -- ^+ -- A value of true hints to the client that this event should not change the+ -- focus.+ --+ , stoppedEventText :: Maybe Text+ -- ^+ -- Additional information. E.g. if reason is `exception`, text contains the+ -- exception name. This string is shown in the UI.+ --+ , stoppedEventAllThreadsStopped :: Bool+ -- ^+ -- If `allThreadsStopped` is true, a debug adapter can announce that all+ -- threads have stopped.+ -- - The client should use this information to enable that all threads can+ -- be expanded to access their stacktraces.+ -- - If the attribute is missing or false, only the thread with the given+ -- `threadId` can be expanded.+ --+ , stoppedEventHitBreakpointIds :: [Int]+ -- ^+ -- Ids of the breakpoints that triggered the event. In most cases there is+ -- only a single breakpoint but here are some examples for multiple+ -- breakpoints:+ -- - Different types of breakpoints map to the same location.+ -- - Multiple source breakpoints get collapsed to the same instruction by+ -- the compiler/runtime.+ -- - Multiple function breakpoints with different function names map to the+ -- same location.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON StoppedEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ContinuedEvent+ = ContinuedEvent+ { continuedEventThreadId :: Int+ -- ^+ -- The thread which was continued.+ --+ , continuedEventAllThreadsContinued :: Bool+ -- ^+ -- If `allThreadsContinued` is true, a debug adapter can announce that all+ -- threads have continued.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ContinuedEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ExitedEvent+ = ExitedEvent+ { exitedEventExitCode :: Int+ -- ^+ -- The exit code returned from the debuggee.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ExitedEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data TerminatedEvent+ = TerminatedEvent+ { terminatedEventRestart :: Bool+ -- ^+ -- A debug adapter may set `restart` to true (or to an arbitrary object) to+ -- request that the client restarts the session.+ -- The value is not interpreted by the client and passed unmodified as an+ -- attribute `__restart` to the `launch` and `attach` requests.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON TerminatedEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ThreadEvent+ = ThreadEvent+ { threadEventReason :: ThreadEventReason+ -- ^+ -- The reason for the event.+ -- Values: 'started', 'exited', etc.+ --+ , threadEventThreadId :: Int+ -- ^+ -- The identifier of the thread.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ThreadEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ThreadEventReason+ = ThreadEventReasonStarted+ | ThreadEventReasonExited+ | ThreadEventReason Text+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ThreadEventReason where+ toJSON (ThreadEventReason reason) = toJSON reason+ toJSON reason = genericToJSONWithModifier reason+----------------------------------------------------------------------------+data OutputEventCategory+ = Console+ | Important+ | Stdout+ | Stderr+ | Telemetry+ | OutputEventCategory Text+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON OutputEventCategory where+ toJSON (OutputEventCategory category) = toJSON category+ toJSON category = genericToJSONWithModifier category+----------------------------------------------------------------------------+data EventGroup+ = EventGroupStart+ | EventGroupStartCollapsed+ | EventGroupEnd+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON EventGroup where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data OutputEvent+ = OutputEvent+ { outputEventCategory :: Maybe OutputEventCategory+ -- ^+ -- The output category. If not specified or if the category is not+ -- understood by the client, `console` is assumed.+ -- Values:+ -- 'console': Show the output in the client's default message UI, e.g. a+ -- 'debug console'. This category should only be used for informational+ -- output from the debugger (as opposed to the debuggee).+ -- 'important': A hint for the client to show the output in the client's UI+ -- for important and highly visible information, e.g. as a popup+ -- notification. This category should only be used for important messages+ -- from the debugger (as opposed to the debuggee). Since this category value+ -- is a hint, clients might ignore the hint and assume the `console`+ -- category.+ -- 'stdout': Show the output as normal program output from the debuggee.+ -- 'stderr': Show the output as error program output from the debuggee.+ -- 'telemetry': Send the output to telemetry instead of showing it to the+ -- user.+ -- etc.+ --+ , outputEventOutput :: Text+ -- ^+ -- The output to report.+ --+ , outputEventGroup :: Maybe EventGroup+ -- ^+ -- Support for keeping an output log organized by grouping related messages.+ -- Values:+ -- 'start': Start a new group in expanded mode. Subsequent output events are+ -- members of the group and should be shown indented.+ -- The `output` attribute becomes the name of the group and is not indented.+ -- 'startCollapsed': Start a new group in collapsed mode. Subsequent output+ -- events are members of the group and should be shown indented (as soon as+ -- the group is expanded).+ -- The `output` attribute becomes the name of the group and is not indented.+ -- 'end': End the current group and decrease the indentation of subsequent+ -- output events.+ -- A non-empty `output` attribute is shown as the unindented end of the+ -- group.+ --+ , outputEventVariablesReference :: Maybe Int+ -- ^+ -- If an attribute `variablesReference` exists and its value is > 0, the+ -- output contains objects which can be retrieved by passing+ -- `variablesReference` to the `variables` request as long as execution+ -- remains suspended. See 'Lifetime of Object References' in the Overview+ -- section for details.+ --+ , outputEventSource :: Maybe Source+ -- ^+ -- The source location where the output was produced.+ --+ , outputEventLine :: Maybe Int+ -- ^+ -- The source location's line where the output was produced.+ --+ , outputEventColumn :: Maybe Int+ -- ^+ -- The position in `line` where the output was produced. It is measured in+ -- UTF-16 code units and the client capability `columnsStartAt1` determines+ -- whether it is 0- or 1-based.+ --+ , outputEventData :: Maybe Value+ -- ^+ -- Additional data to report. For the `telemetry` category the data is sent+ -- to telemetry, for the other categories the data is shown in JSON format.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON OutputEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data BreakpointEvent+ = BreakpointEvent+ { breakpointEventReason :: EventReason+ -- ^+ -- The reason for the event.+ -- Values: 'changed', 'new', 'removed', etc.+ --+ , breakpointEvevntBreakpoint :: Breakpoint+ -- ^+ -- The `id` attribute is used to find the target breakpoint, the other+ -- attributes are used as the new values.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON BreakpointEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data EventReason+ = EventReasonNew+ | EventReasonChanged+ | EventReasonRemoved+ | EventReason Text+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON EventReason where+ toJSON (EventReason reason) = toJSON reason+ toJSON reason = genericToJSONWithModifier reason+----------------------------------------------------------------------------+data ModuleEvent+ = ModuleEvent+ { moduleEventReason :: EventReason+ -- ^+ -- The reason for the event.+ -- Values: 'new', 'changed', 'removed'+ --+ , moduleEventModule :: Module+ -- ^+ -- The new, changed, or removed module. In case of `removed` only the module+ -- id is used.+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON ModuleEvent where+ toJSON ModuleEvent{..} =+ object+ [ "reason" .= moduleEventReason+ , "module" .= moduleEventModule+ ]+----------------------------------------------------------------------------+data LoadedSourceEvent+ = LoadedSourceEvent+ { loadedSourceEventReason :: EventReason+ -- ^+ -- The reason for the event.+ -- Values: 'new', 'changed', 'removed'+ --+ , loadedSourceSource :: Source+ -- ^+ -- The new, changed, or removed source.+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance ToJSON LoadedSourceEvent where+ toJSON LoadedSourceEvent{..}+ = object+ [ "reason" .= loadedSourceEventReason+ , "source" .= loadedSourceSource+ ]+----------------------------------------------------------------------------+data ProcessEvent+ = ProcessEvent+ { processEventName :: Text+ -- ^+ -- The logical name of the process. This is usually the full path to+ -- process's executable file. Example: /home/example/myproj/program.js.+ --+ , processEventSystemProcessId :: Maybe Int+ -- ^+ -- The system process id of the debugged process. This property is missing+ -- for non-system processes.+ --+ , processEventIsLocalProcess :: Bool+ -- ^+ -- If true, the process is running on the same computer as the debug+ -- adapter.+ --+ , processEventStartMethod :: Maybe StartMethod+ -- ^+ -- Describes how the debug engine started debugging this process.+ -- Values:+ -- 'launch': Process was launched under the debugger.+ -- 'attach': Debugger attached to an existing process.+ -- 'attachForSuspendedLaunch': A project launcher component has launched a+ -- new process in a suspended state and then asked the debugger to attach.+ --+ , processEventPointerSize :: Maybe Int+ -- ^+ -- The size of a pointer or address for this process, in bits. This value+ -- may be used by clients when formatting addresses for display.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ProcessEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data StartMethod+ = StartMethodLaunch+ | StartMethodAttach+ | StartMethodAttachForSuspendedLaunch+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON StartMethod where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data CapabilitiesEvent+ = CapabilitiesEvent+ { capabilities :: Capabilities+ -- ^+ -- The set of updated capabilities.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON CapabilitiesEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ProgressStartEvent+ = ProgressStartEvent+ { progressStartEventProgressId :: Text+ -- ^+ -- An ID that can be used in subsequent `progressUpdate` and `progressEnd`+ -- events to make them refer to the same progress reporting.+ -- IDs must be unique within a debug session.+ --+ , progressStartEventTitle :: Text+ -- ^+ -- Short title of the progress reporting. Shown in the UI to describe the+ -- long running operation.+ --+ , progressStartEventRequestId :: Maybe Int+ -- ^+ -- The request ID that this progress report is related to. If specified a+ -- debug adapter is expected to emit progress events for the long running+ -- request until the request has been either completed or cancelled.+ -- If the request ID is omitted, the progress report is assumed to be+ -- related to some general activity of the debug adapter.+ --+ , progressStartEventCancellable :: Bool+ -- ^+ -- If true, the request that reports progress may be cancelled with a+ -- `cancel` request.+ -- So this property basically controls whether the client should use UX that+ -- supports cancellation.+ -- Clients that don't support cancellation are allowed to ignore the+ -- setting.+ --+ , progressStartEventMessage :: Maybe Text+ -- ^+ -- More detailed progress message.+ --+ , progressStartEventPercentage :: Maybe Int+ -- ^+ -- Progress percentage to display (value range: 0 to 100). If omitted no+ -- percentage is shown.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ProgressStartEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ProgressUpdateEvent+ = ProgressUpdateEvent+ { progressUpdateEventProgressId :: Text+ -- ^+ -- The ID that was introduced in the initial `progressStart` event.+ --+ , progressUpdateEventMessage :: Maybe Text+ -- ^+ -- More detailed progress message. If omitted, the previous message (if any)+ -- is used.+ --+ , progressUpdateEventPercentage :: Maybe Int+ -- ^+ -- Progress percentage to display (value range: 0 to 100). If omitted no+ -- percentage is shown.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ProgressUpdateEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ProgressEndEvent+ = ProgressEndEvent+ { progressEndEventProgressId :: Text+ -- ^+ -- The ID that was introduced in the initial `ProgressStartEvent`.+ --+ , progressEndEventMessage :: Maybe Text+ -- ^+ -- More detailed progress message. If omitted, the previous message (if any)+ -- is used.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ProgressEndEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data InvalidatedEvent+ = InvalidatedEvent+ { invalidatedEventAreas :: [InvalidatedAreas]+ -- ^+ -- Set of logical areas that got invalidated. This property has a hint+ -- characteristic: a client can only be expected to make a 'best effort' in+ -- honoring the areas but there are no guarantees. If this property is+ -- missing, empty, or if values are not understood, the client should assume+ -- a single value `all`.+ --+ , invalidatedEventThreadId :: Maybe Int+ -- ^+ -- If specified, the client only needs to refetch data related to this+ -- thread.+ --+ , invalidatedEventStackFrameId :: Maybe Int+ -- ^+ -- If specified, the client only needs to refetch data related to this stack+ -- frame (and the `threadId` is ignored).+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON InvalidatedEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+-- | Logical areas that can be invalidated by the invalidated event. Values:+-- <https://microsoft.github.io/debug-adapter-protocol/specification#Types_InvalidatedAreas>+--+data InvalidatedAreas+ = InvalidatedAreasAll+ | InvalidatedAreasStacks+ | InvalidatedAreasThreads+ | InvalidatedAreasVariables+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON InvalidatedAreas where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data MemoryEvent+ = MemoryEvent+ { memoryEventMemoryReference :: Text+ -- ^+ -- Memory reference of a memory range that has been updated.+ --+ , memoryEventOffset :: Int+ -- ^+ -- Starting offset in bytes where memory has been updated. Can be negative.+ --+ , memoryEventCount :: Int+ -- ^+ -- Number of bytes updated.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON MemoryEvent where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data CancelArguments+ = CancelArguments+ { cancelArgumentsRequestId :: Maybe Int+ -- ^+ -- The ID (attribute `seq`) of the request to cancel. If missing no request is+ -- cancelled.+ -- Both a `requestId` and a `progressId` can be specified in one request.+ --+ , cancelArgumentsProgressId :: Maybe Text+ -- ^+ -- The ID (attribute `progressId`) of the progress to cancel. If missing no+ -- progress is cancelled.+ -- Both a `requestId` and a `progressId` can be specified in one request.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON CancelArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data RunInTerminalRequestArgumentsKind+ = RunInTerminalRequestArgumentsKindIntegrated+ | RunInTerminalRequestArgumentsKindExternal+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON RunInTerminalRequestArgumentsKind where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data RunInTerminalRequestArguments+ = RunInTerminalRequestArguments+ { runInTerminalRequestArgumentsKind :: Maybe RunInTerminalRequestArgumentsKind+ -- ^+ -- What kind of terminal to launch. Defaults to `integrated` if not specified.+ -- Values: 'integrated', 'external'+ --+ , runInTerminalRequestArgumentsTitle :: Maybe Text+ -- ^+ -- Title of the terminal.+ --+ , runInTerminalRequestArgumentsCwd :: Text+ -- ^+ -- Working directory for the command. For non-empty, valid paths this+ -- typically results in execution of a change directory command.+ --+ , runInTerminalRequestArgumentsArgs :: [Text]+ -- ^+ -- List of arguments. The first argument is the command to run.+ --+ -- .:? "foo" .!= mempty+ , runInTerminalRequestArgumentsEnv :: Maybe (H.HashMap Text Text)+ -- ^+ -- Environment key-value pairs that are added to or removed from the default+ -- environment.+ --+ , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell :: Bool+ -- ^+ -- This property should only be set if the corresponding capability+ -- `supportsArgsCanBeInterpretedByShell` is true. If the client uses an+ -- intermediary shell to launch the application, then the client must not+ -- attempt to escape characters with special meanings for the shell. The user+ -- is fully responsible for escaping as needed and that arguments using+ -- special characters may not be portable across shells.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON RunInTerminalRequestArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data StartDebuggingRequestArgumentsConfiguration+ = StartDebuggingRequestArgumentsConfigurationLaunch+ | StartDebuggingRequestArgumentsConfigurationAttach+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON StartDebuggingRequestArgumentsConfiguration where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data StartDebuggingRequestArguments+ = StartDebuggingRequestArguments+ { startDebuggingRequestArgumentsConfiguration :: H.HashMap Text Value+ -- ^+ -- Arguments passed to the new debug session. The arguments must only contain+ -- properties understood by the `launch` or `attach` requests of the debug+ -- adapter and they must not contain any client-specific properties (e.g.+ -- `type`) or client-specific features (e.g. substitutable 'variables').+ --+ , startDebuggingRequestArgumentsConfigurationRequest :: StartDebuggingRequestArgumentsConfiguration+ -- ^+ -- Indicates whether the new debug session should be started with a `launch`+ -- or `attach` request.+ -- Values: 'launch', 'attach'+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON StartDebuggingRequestArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data PathFormat+ = Path+ | URI+ | PathFormat Text+ deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance FromJSON PathFormat where+ parseJSON = withText "PathFormat" $ \txt ->+ pure $ case txt of+ "path" -> Path+ "uri" -> URI+ _ -> PathFormat txt+----------------------------------------------------------------------------+data InitializeRequestArguments+ = InitializeRequestArguments+ { clientID :: Maybe Text+ -- ^+ -- The ID of the client using this adapter.+ --+ , clientName :: Maybe Text+ -- ^+ -- The human-readable name of the client using this adapter.+ --+ , adapterID :: Text+ -- ^+ -- The ID of the debug adapter.+ --+ , locale :: Maybe Text+ -- ^+ -- The ISO-639 locale of the client using this adapter, e.g. en-US or de-CH.+ --+ , linesStartAt1 :: Bool+ -- ^+ -- If true all line numbers are 1-based (default).+ --+ , columnsStartAt1 :: Bool+ -- ^+ -- If true all column numbers are 1-based (default).+ --+ , pathFormat :: Maybe PathFormat+ -- ^+ -- Determines in what format paths are specified. The default is `path`, which+ -- is the native format.+ -- Values: 'path', 'uri', etc.+ --+ , supportsVariableType :: Bool+ -- ^+ -- Client supports the `type` attribute for variables.+ --+ , supportsVariablePaging :: Bool+ -- ^+ -- Client supports the paging of variables.+ --+ , supportsRunInTerminalRequest :: Bool+ -- ^+ -- Client supports the `runInTerminal` request.+ --+ , supportsMemoryReferences :: Bool+ -- ^+ -- Client supports memory references.+ --+ , supportsProgressReporting :: Bool+ -- ^+ -- Client supports progress reporting.+ --+ , supportsInvalidatedEvent :: Bool+ -- ^+ -- Client supports the `invalidated` event.+ --+ , supportsMemoryEvent :: Bool+ -- ^+ -- Client supports the `memory` event.+ --+ , supportsArgsCanBeInterpretedByShell :: Bool+ -- ^+ -- Client supports the `argsCanBeInterpretedByShell` attribute on the+ -- `runInTerminal` request.+ --+ , supportsStartDebuggingRequest :: Bool+ -- ^+ -- Client supports the `startDebugging` request.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON InitializeRequestArguments where+ parseJSON = genericParseJSON defaultOptions+----------------------------------------------------------------------------+data LaunchRequestArguments+ = LaunchRequestArguments+ { launchRequestArgumentsNoDebug :: Bool+ -- ^+ -- If true, the launch request should launch the program without enabling+ -- debugging.+ --+ , launchRequestArgumentsRestart :: Maybe Value+ -- ^+ -- Arbitrary data from the previous, restarted session.+ -- The data is sent as the `restart` attribute of the `terminated` event.+ -- The client should leave the data intact.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON LaunchRequestArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data AttachRequestArguments+ = AttachRequestArguments+ { attachRequestArgumentsRestart :: Maybe Value+ -- ^+ -- Arbitrary data from the previous, restarted session.+ -- The data is sent as the `restart` attribute of the `terminated` event.+ -- The client should leave the data intact.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON AttachRequestArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data RestartArguments+ = RestartArguments+ { restartArgumentsArguments :: Maybe (Either LaunchRequestArguments AttachRequestArguments)+ -- ^+ -- The latest version of the `launch` or `attach` configuration.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON RestartArguments where+ 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.+ --+ , 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.+ --+ , 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.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON DisconnectArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data TerminateArguments+ = TerminateArguments+ { terminateArgumentsRestart :: Bool+ -- ^+ -- A value of true indicates that this `terminate` request is part of a+ -- restart sequence.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON TerminateArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data BreakpointLocationsArguments+ = BreakpointLocationsArguments+ { breakpointLocationsArgumentsSource :: Source+ -- ^+ -- The source location of the breakpoints; either `source.path` or+ -- `source.reference` must be specified.+ --+ , breakpointLocationsArgumentsLine :: Int+ -- ^+ -- Start line of range to search possible breakpoint locations in. If only the+ -- line is specified, the request returns all possible locations in that line.+ --+ , breakpointLocationsArgumentsColumn :: Maybe Int+ -- ^+ -- Start position within `line` to search possible breakpoint locations in. It+ -- is measured in UTF-16 code units and the client capability+ -- `columnsStartAt1` determines whether it is 0- or 1-based. If no column is+ -- given, the first position in the start line is assumed.+ --+ , breakpointLocationsArgumentsEndLine :: Maybe Int+ -- ^+ -- End line of range to search possible breakpoint locations in. If no end+ -- line is given, then the end line is assumed to be the start line.+ --+ , breakpointLocationsArgumentsEndColumn :: Maybe Int+ -- ^+ -- End position within `endLine` to search possible breakpoint locations in.+ -- It is measured in UTF-16 code units and the client capability+ -- `columnsStartAt1` determines whether it is 0- or 1-based. If no end column+ -- is given, the last position in the end line is assumed.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON BreakpointLocationsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SetBreakpointsArguments+ = SetBreakpointsArguments+ { setBreakpointsArgumentsSource :: Source+ -- ^+ -- The source location of the breakpoints; either `source.path` or+ -- `source.sourceReference` must be specified.+ --+ , setBreakpointsArgumentsBreakpoints :: Maybe [SourceBreakpoint]+ -- ^+ -- The code locations of the breakpoints.+ --+ , setBreakpointsArgumentsLines :: Maybe [Int]+ -- ^+ -- Deprecated: The code locations of the breakpoints.+ --+ , setBreakpointsArgumentsSourceModified :: Bool+ -- ^+ -- A value of true indicates that the underlying source has been modified+ -- which results in new breakpoint locations.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SetBreakpointsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SourceBreakpoint+ = SourceBreakpoint+ { sourceBreakpointLine :: Int+ -- ^+ -- The source line of the breakpoint or logpoint.+ --+ , sourceBreakpointColumn :: Maybe Int+ -- ^+ -- Start position within source line of the breakpoint or logpoint. It is+ -- measured in UTF-16 code units and the client capability `columnsStartAt1`+ -- determines whether it is 0- or 1-based.+ --+ , sourceBreakpointCondition :: Maybe Text+ -- ^+ -- The expression for conditional breakpoints.+ -- It is only honored by a debug adapter if the corresponding capability+ -- `supportsConditionalBreakpoints` is true.+ --+ , sourceBreakpointHitCondition :: Maybe Text+ -- ^+ -- The expression that controls how many hits of the breakpoint are ignored.+ -- The debug adapter is expected to interpret the expression as needed.+ -- The attribute is only honored by a debug adapter if the corresponding+ -- capability `supportsHitConditionalBreakpoints` is true.+ -- If both this property and `condition` are specified, `hitCondition` should+ -- be evaluated only if the `condition` is met, and the debug adapter should+ -- stop only if both conditions are met.+ --+ , sourceBreakpointLogMessage :: Maybe Text+ -- ^+ -- If this attribute exists and is non-empty, the debug adapter must not+ -- 'break' (stop)+ -- but log the message instead. Expressions within `{}` are interpolated.+ -- The attribute is only honored by a debug adapter if the corresponding+ -- capability `supportsLogPoints` is true.+ -- If either `hitCondition` or `condition` is specified, then the message+ -- should only be logged if those conditions are met.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultSourceBreakpoint :: SourceBreakpoint+defaultSourceBreakpoint+ = SourceBreakpoint+ { sourceBreakpointLine = 0+ , sourceBreakpointColumn = Nothing+ , sourceBreakpointCondition = Nothing+ , sourceBreakpointHitCondition = Nothing+ , sourceBreakpointLogMessage = Nothing+ }+----------------------------------------------------------------------------+instance FromJSON SourceBreakpoint where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SetFunctionBreakpointsArguments+ = SetFunctionBreakpointsArguments+ { setFunctionBreakpointsArgumentsBreakpoints :: [FunctionBreakpoint]+ -- ^+ -- The function names of the breakpoints.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SetFunctionBreakpointsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data FunctionBreakpoint+ = FunctionBreakpoint+ { functionBreakpointName :: Maybe Text+ -- ^+ -- The name of the function.+ --+ , functionBreakpointCondition :: Maybe Text+ -- ^+ -- An expression for conditional breakpoints.+ -- It is only honored by a debug adapter if the corresponding capability+ -- `supportsConditionalBreakpoints` is true.+ --+ , functionBreakpointHitCondition :: Maybe Text+ -- ^+ -- An expression that controls how many hits of the breakpoint are ignored.+ -- The debug adapter is expected to interpret the expression as needed.+ -- The attribute is only honored by a debug adapter if the corresponding+ -- capability `supportsHitConditionalBreakpoints` is true.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultFunctionBreakpoint :: FunctionBreakpoint+defaultFunctionBreakpoint+ = FunctionBreakpoint+ { functionBreakpointName = Nothing+ , functionBreakpointCondition = Nothing+ , functionBreakpointHitCondition = Nothing+ }+----------------------------------------------------------------------------+instance FromJSON FunctionBreakpoint where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SetExceptionBreakpointsArguments+ = SetExceptionBreakpointsArguments+ { setExceptionBreakpointsArgumentsFilters :: [Text]+ -- ^+ -- Set of exception filters specified by their ID. The set of all possible+ -- exception filters is defined by the `exceptionBreakpointFilters`+ -- capability. The `filter` and `filterOptions` sets are additive.+ --+ , setExceptionBreakpointsArgumentsFilterOptions :: Maybe ExceptionFilterOptions -- .!=+ -- ^+ -- Set of exception filters and their options. The set of all possible+ -- exception filters is defined by the `exceptionBreakpointFilters`+ -- capability. This attribute is only honored by a debug adapter if the+ -- corresponding capability `supportsExceptionFilterOptions` is true. The+ -- `filter` and `filterOptions` sets are additive.+ --+ , setExceptionBreakpointsArgumentsExceptionOptions :: Maybe ExceptionOptions+ -- ^+ -- Configuration options for selected exceptions.+ -- The attribute is only honored by a debug adapter if the corresponding+ -- capability `supportsExceptionOptions` is true.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SetExceptionBreakpointsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ExceptionFilterOptions+ = ExceptionFilterOptions+ { exceptionFilterOptionsFilterId :: String+ -- ^ ID of an exception filter returned by the `exceptionBreakpointFilters`+ -- capability.+ , exceptionFilterOptionsCondition :: Maybe String+ -- ^ An expression for conditional exceptions.+ -- The exception breaks into the debugger if the result of the condition is+ -- true.+ } deriving stock (Show, Eq, Generic)+---------------------------------------------------------------------------+instance FromJSON ExceptionFilterOptions where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ExceptionOptions+ = ExceptionOptions+ { exceptionOptionsPath :: Maybe [ExceptionPathSegment]+ -- ^+ -- A path that selects a single or multiple exceptions in a tree. If `path` is+ -- missing, the whole tree is selected.+ -- By convention the first segment of the path is a category that is used to+ -- group exceptions in the UI.+ --+ , exceptionOptionsBreakMode :: ExceptionBreakMode+ -- ^+ -- Condition when a thrown exception should result in a break.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON ExceptionOptions where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data DataBreakpointInfoArguments+ = DataBreakpointInfoArguments+ { dataBreakpointInfoArgumentsVariablesReference :: Maybe Int+ -- ^+ -- Reference to the variable container if the data breakpoint is requested for+ -- a child of the container. The `variablesReference` must have been obtained+ -- in the current suspended state. See 'Lifetime of Object References' in the+ -- Overview section for details.+ --+ , dataBreakpointInfoArgumentsName :: Text+ -- ^+ -- The name of the variable's child to obtain data breakpoint information for.+ -- If `variablesReference` isn't specified, this can be an expression.+ --+ , dataBreakpointInfoArgumentsFrameId :: Maybe Int+ -- ^+ -- When `name` is an expression, evaluate it in the scope of this stack frame.+ -- If not specified, the expression is evaluated in the global scope. When+ -- `variablesReference` is specified, this property has no effect.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON DataBreakpointInfoArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SetDataBreakpointsArguments+ = SetDataBreakpointsArguments+ { setDataBreakpointsArgumentsBreakpoints :: [DataBreakpoint]+ -- ^+ -- The contents of this array replaces all existing data breakpoints. An empty+ -- array clears all data breakpoints.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SetDataBreakpointsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data DataBreakpoint+ = DataBreakpoint+ { dataBreakpointDataId :: Text+ -- ^+ -- An id representing the data. This id is returned from the+ -- `dataBreakpointInfo` request.+ --+ , dataBreakpointAccessType :: Maybe DataBreakpointAccessType+ -- ^+ -- The access type of the data.+ --+ , condition :: Maybe Text+ -- ^+ -- An expression for conditional breakpoints.+ --+ , hitCondition :: Maybe Text+ -- ^+ -- An expression that controls how many hits of the breakpoint are ignored.+ -- The debug adapter is expected to interpret the expression as needed.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON DataBreakpoint where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SetInstructionBreakpointsArguments+ = SetInstructionBreakpointsArguments+ { breakpoints :: [InstructionBreakpoint]+ -- ^+ -- The instruction references of the breakpoints+ --+ } deriving (Show, Eq)+----------------------------------------------------------------------------+data InstructionBreakpoint+ = InstructionBreakpoint+ { instructionBreakpointInstructionReference :: Text+ -- ^+ -- The instruction reference of the breakpoint.+ -- This should be a memory or instruction pointer reference from an+ -- `EvaluateResponse`, `Variable`, `StackFrame`, `GotoTarget`, or+ -- `Breakpoint`.+ --+ , instructionBreakpointOffset :: Maybe Int+ -- ^+ -- The offset from the instruction reference.+ -- This can be negative.+ --+ , instructionBreakpointCondition :: Maybe Text+ -- ^+ -- An expression for conditional breakpoints.+ -- It is only honored by a debug adapter if the corresponding capability+ -- `supportsConditionalBreakpoints` is true.+ --+ , instructionBreakpointHitCondition :: Maybe Text+ -- ^+ -- An expression that controls how many hits of the breakpoint are ignored.+ -- The debug adapter is expected to interpret the expression as needed.+ -- The attribute is only honored by a debug adapter if the corresponding+ -- capability `supportsHitConditionalBreakpoints` is true.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON InstructionBreakpoint where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ContinueArguments+ = ContinueArguments+ { continueArgumentsThreadId :: Int+ -- ^+ -- Specifies the active thread. If the debug adapter supports single thread+ -- execution (see `supportsSingleThreadExecutionRequests`) and the argument+ -- `singleThread` is true, only the thread with this ID is resumed.+ --+ , continueArgumentsSingleThread :: Bool+ -- ^+ -- If this flag is true, execution is resumed only for the thread with given+ -- `threadId`.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON ContinueArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data NextArguments+ = NextArguments+ { nextArgumentsThreadId :: Int+ -- ^+ -- Specifies the thread for which to resume execution for one step (of the+ -- given granularity).+ --+ , nextArgumentsSingleThread :: Maybe Bool+ -- ^+ -- If this flag is true, all other suspended threads are not resumed.+ --+ , nextArgumentsGranularity :: Maybe SteppingGranularity+ -- ^+ -- Stepping granularity. If no granularity is specified, a granularity of+ -- `statement` is assumed.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON NextArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data StepInArguments+ = StepInArguments+ { stepInArgumentsThreadId :: Int+ -- ^+ -- Specifies the thread for which to resume execution for one step-into (of+ -- the given granularity).+ --+ , stepInArgumentsSingleThread :: Bool+ -- ^+ -- If this flag is true, all other suspended threads are not resumed.+ --+ , stepInArgumentsTargetId :: Maybe Int+ -- ^+ -- Id of the target to step into.+ --+ , stepInArgumentsGranularity :: Maybe SteppingGranularity+ -- ^+ -- Stepping granularity. If no granularity is specified, a granularity of+ -- `statement` is assumed.+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+data StepOutArguments+ = StepOutArguments+ { stepOutArgumentsThreadId :: Int+ -- ^+ -- Specifies the thread for which to resume execution for one step-out (of the+ -- given granularity).+ --+ , stepOutArgumentsSingleThread :: Bool+ -- ^+ -- If this flag is true, all other suspended threads are not resumed.+ --+ , stepOutArgumentsGranularity :: Maybe SteppingGranularity+ -- ^+ -- Stepping granularity. If no granularity is specified, a granularity of+ -- `statement` is assumed.+ --+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+data StepBackArguments+ = StepBackArguments+ { stepBackArgumentsThreadId :: Int+ -- ^+ -- Specifies the thread for which to resume execution for one step backwards+ -- (of the given granularity).+ --+ , stepBackArgumentsSingleThread :: Bool+ -- ^+ -- If this flag is true, all other suspended threads are not resumed.+ --+ , stepBackArgumentsGranularity :: Maybe SteppingGranularity+ -- ^+ -- Stepping granularity to step. If no granularity is specified, a granularity+ -- of `statement` is assumed.+ } deriving stock (Show, Eq)+----------------------------------------------------------------------------+data SteppingGranularity+ = SteppingGranularityStatement+ | SteppingGranularityLine+ | SteppingGranularityInstruction+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SteppingGranularity where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ReverseContinueArguments+ = ReverseContinueArguments+ { reverseContinueArgumentsThreadId :: Int+ -- ^+ -- Specifies the active thread. If the debug adapter supports single thread+ -- execution (see `supportsSingleThreadExecutionRequests`) and the+ -- `singleThread` argument is true, only the thread with this ID is resumed.+ --+ , reverseContinueArgumentsSingleThread :: Bool+ -- ^+ -- If this flag is true, backward execution is resumed only for the thread+ -- with given `threadId`.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON ReverseContinueArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data RestartFrameArguments+ = RestartFrameArguments+ { restartFrameArgumentsFrameId :: Int+ -- ^+ -- Restart 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 RestartFrameArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data GotoArguments+ = GotoArguments+ { gotoArgumentsThreadId :: Int+ -- ^+ -- Set the goto target for this thread.+ --+ , gotoArgumentsTargetId :: Int+ -- ^+ -- The location where the debuggee will continue to run.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON GotoArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data PauseArguments+ = PauseArguments+ { pauseArgumentsThreadId :: Int+ -- ^+ -- Pause execution for this thread.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON PauseArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data StackTraceArguments+ = StackTraceArguments+ { stackTraceArgumentsThreadId :: Int+ -- ^+ -- Retrieve the stacktrace for this thread.+ --+ , stackTraceArgumentsStartFrame :: Maybe Int+ -- ^+ -- The index of the first frame to return; if omitted frames start at 0.+ --+ , stackTraceArgumentsLevels :: Maybe Int+ -- ^+ -- The maximum number of frames to return. If levels is not specified or 0,+ -- all frames are returned.+ --+ , stackTraceArgumentsFormat :: Maybe StackFrameFormat+ -- ^+ -- Specifies details on how to format the stack frames.+ -- The attribute is only honored by a debug adapter if the corresponding+ -- capability `supportsValueFormattingOptions` is true.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON StackTraceArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data StackFrameFormat+ = StackFrameFormat+ { stackFrameFormatParameters :: Maybe Bool+ -- ^+ -- Displays parameters for the stack frame.+ --+ , stackFrameFormatParameterTypes :: Maybe Bool+ -- ^+ -- Displays the types of parameters for the stack frame.+ --+ , stackFrameFormatParameterNames :: Maybe Bool+ -- ^+ -- Displays the names of parameters for the stack frame.+ --+ , stackFrameFormatParameterValues :: Maybe Bool+ -- ^+ -- Displays the values of parameters for the stack frame.+ --+ , stackFrameFormatLine :: Maybe Bool+ -- ^+ -- Displays the line number of the stack frame.+ --+ , stackFrameFormatModule :: Maybe Bool+ -- ^+ -- Displays the module of the stack frame.+ --+ , stackFrameFormatIncludeAll :: Maybe Bool+ -- ^+ -- Includes all stack frames, including those the debug adapter might+ -- otherwise hide.+ --+ , stackFrameFormatHex :: Maybe Bool+ -- ^+ -- Display the value in hex.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultStackFrameFormat :: StackFrameFormat+defaultStackFrameFormat+ = StackFrameFormat+ { stackFrameFormatParameters = Nothing+ , stackFrameFormatParameterTypes = Nothing+ , stackFrameFormatParameterNames = Nothing+ , stackFrameFormatParameterValues = Nothing+ , stackFrameFormatLine = Nothing+ , stackFrameFormatModule = Nothing+ , stackFrameFormatIncludeAll = Nothing+ , stackFrameFormatHex = Nothing+ }+----------------------------------------------------------------------------+instance FromJSON StackFrameFormat where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+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.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON ScopesArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data VariablesFilter+ = VariablesFilterIndexed+ | VariablesFilterNamed+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON VariablesFilter where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data VariablesArguments+ = VariablesArguments+ { variablesArgumentsVariablesReference :: Int+ -- ^+ -- The variable for which to retrieve its children. The `variablesReference`+ -- must have been obtained in the current suspended state. See 'Lifetime of+ -- Object References' in the Overview section for details.+ --+ , variablesArgumentsFilter :: Maybe VariablesFilter+ -- ^+ -- Filter to limit the child variables to either named or indexed. If omitted,+ -- both types are fetched.+ -- Values: 'indexed', 'named'+ --+ , variablesArgumentsStart :: Maybe Int+ -- ^+ -- The index of the first variable to return; if omitted children start at 0.+ --+ , variablesArgumentsCount :: Maybe Int+ -- ^+ -- The number of variables to return. If count is missing or 0, all variables+ -- are returned.+ --+ , variablesArgumentsFormat :: Maybe ValueFormat+ -- ^+ -- Specifies details on how to format the Variable values.+ -- The attribute is only honored by a debug adapter if the corresponding+ -- capability `supportsValueFormattingOptions` is true.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON VariablesArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ValueFormat+ = ValueFormat+ { valueFormatHex :: Maybe Bool+ -- ^+ -- Display the value in hex.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultValueFormat :: ValueFormat+defaultValueFormat+ = ValueFormat+ { valueFormatHex = Nothing+ }+----------------------------------------------------------------------------+instance FromJSON ValueFormat where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SetVariableArguments+ = SetVariableArguments+ { setVariableArgumentsVariablesReference :: Int+ -- ^+ -- The reference of the variable container. The `variablesReference` must have+ -- been obtained in the current suspended state. See 'Lifetime of Object+ -- References' in the Overview section for details.+ --+ , setVariableArgumentsName :: Text+ -- ^+ -- The name of the variable in the container.+ --+ , setVariableArgumentsValue :: Text+ -- ^+ -- The value of the variable.+ --+ , setVariableArgumentsFormat :: Maybe ValueFormat+ -- ^+ -- Specifies details on how to format the response value.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SetVariableArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SourceArguments+ = SourceArguments+ { sourceArgumentsSource :: Maybe Source+ -- ^+ -- Specifies the source content to load. Either `source.path` or+ -- `source.sourceReference` must be specified.+ --+ , sourceArgumentsSourceReference :: Int+ -- ^+ -- The reference to the source. This is the same as `source.sourceReference`.+ -- This is provided for backward compatibility since old clients do not+ -- understand the `source` attribute.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SourceArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+newtype TerminateThreadsArguments+ = TerminateThreadsArguments+ { terminateThreadsArgumentsThreadIds :: [Int]+ -- ^+ -- Ids of threads to be terminated.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON TerminateThreadsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ModulesArguments+ = ModulesArguments+ { modulesArgumentsStartModule :: Maybe Int+ -- ^+ -- The index of the first module to return; if omitted modules start at 0.+ --+ , modulesArgumentsModuleCount :: Maybe Int+ -- ^+ -- The number of modules to return. If `moduleCount` is not specified or 0,+ -- all modules are returned.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+data LoadedSourcesArguments = LoadedSourcesArguments+ deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance FromJSON LoadedSourcesArguments where+ parseJSON _ = pure LoadedSourcesArguments+----------------------------------------------------------------------------+data EvaluateArgumentsContext+ = EvaluateArgumentsContextWatch+ | EvaluateArgumentsContextRepl+ | EvaluateArgumentsContextHover+ | EvaluateArgumentsContextClipboard+ | EvaluateArgumentsContextVariable+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON EvaluateArgumentsContext where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+instance FromJSON EvaluateArgumentsContext where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data EvaluateArguments+ = EvaluateArguments+ { evaluateArgumentsExpression :: Text+ -- ^+ -- The expression to evaluate.+ --+ , evaluateArgumentsFrameId:: Maybe Int+ -- ^+ -- Evaluate the expression in the scope of this stack frame. If not specified,+ -- the expression is evaluated in the global scope.+ --+ , evaluateArgumentsContext :: Maybe EvaluateArgumentsContext+ -- ^+ -- The context in which the evaluate request is used.+ -- Values:+ -- 'watch': evaluate is called from a watch view context.+ -- 'repl': evaluate is called from a REPL context.+ -- 'hover': evaluate is called to generate the debug hover contents.+ -- This value should only be used if the corresponding capability+ -- `supportsEvaluateForHovers` is true.+ -- 'clipboard': evaluate is called to generate clipboard contents.+ -- This value should only be used if the corresponding capability+ -- `supportsClipboardContext` is true.+ -- 'variables': evaluate is called from a variables view context.+ -- etc.+ --+ , evaluateArgumentsFormat :: Maybe ValueFormat+ -- ^+ -- Specifies details on how to format the result.+ -- The attribute is only honored by a debug adapter if the corresponding+ -- capability `supportsValueFormattingOptions` is true.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON EvaluateArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data SetExpressionArguments+ = SetExpressionArguments+ { setExpressionArgumentsExpression :: Text+ -- ^+ -- The l-value expression to assign to.+ --+ , setExpressionArgumentsValue :: Text+ -- ^+ -- The value expression to assign to the l-value expression.+ --+ , setExpressionArgumentsFrameId :: Maybe Int+ -- ^+ -- Evaluate the expressions in the scope of this stack frame. If not+ -- specified, the expressions are evaluated in the global scope.+ --+ , setExpressionArgumentsFormat :: Maybe ValueFormat+ -- ^+ -- Specifies how the resulting value should be formatted.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON SetExpressionArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data StepInTargetsArguments+ = StepInTargetsArguments+ { stepInTargetsArgumentsFrameId :: Int+ -- ^+ -- The stack frame for which to retrieve the possible step-in targets.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON StepInTargetsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data GotoTargetsArguments+ = GotoTargetsArguments+ { gotoTargetsArgumentsSource :: Source+ -- ^+ -- The source location for which the goto targets are determined.+ --+ , gotoTargetsArgumentsLine :: Int+ -- ^+ -- The line location for which the goto targets are determined.+ --+ , gotoTargetsArgumentsColumn :: Maybe Int+ -- ^+ -- The position within `line` for which the goto targets are determined. It is+ -- measured in UTF-16 code units and the client capability `columnsStartAt1`+ -- determines whether it is 0- or 1-based.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON GotoTargetsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data CompletionsArguments+ = CompletionsArguments+ { completionsArgumentsFrameId :: Maybe Int+ -- ^+ -- Returns completions in the scope of this stack frame. If not specified, the+ -- completions are returned for the global scope.+ --+ , completionsArgumentsText :: Text+ -- ^+ -- One or more source lines. Typically this is the text users have typed into+ -- the debug console before they asked for completion.+ --+ , completionsArgumentsColumn :: Int+ -- ^+ -- The position within `text` for which to determine the completion proposals.+ -- It is measured in UTF-16 code units and the client capability+ -- `columnsStartAt1` determines whether it is 0- or 1-based.+ --+ , completionsArgumentsLine :: Maybe Int+ -- ^+ -- A line for which to determine the completion proposals. If missing the+ -- first line of the text is assumed.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON CompletionsArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ExceptionInfoArguments+ = ExceptionInfoArguments+ { exceptionInfoArgumentsThreadId :: Int+ -- ^+ -- Thread for which exception information should be retrieved.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON ExceptionInfoArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ReadMemoryArguments+ = ReadMemoryArguments+ { readMemoryArgumentsmemoryReference :: Text+ -- ^+ -- Memory reference to the base location from which data should be read.+ --+ , readMemoryArgumentsOffset :: Maybe Int+ -- ^+ -- Offset (in bytes) to be applied to the reference location before reading+ -- data. Can be negative.+ --+ , readMemoryArgumentsCount :: Int+ -- ^+ -- Number of bytes to read at the specified location and offset.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON ReadMemoryArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data WriteMemoryArguments+ = WriteMemoryArguments+ { writeMemoryMemoryReference :: Text+ -- ^+ -- Memory reference to the base location to which data should be written.+ --+ , writeMemoryArgumentsOffset :: Maybe Int+ -- ^+ -- Offset (in bytes) to be applied to the reference location before writing+ -- data. Can be negative.+ --+ , writeMemoryArgumentsAllowPartial :: Bool+ -- ^+ -- Property to control partial writes. If true, the debug adapter should+ -- attempt to write memory even if the entire memory region is not writable.+ -- In such a case the debug adapter should stop after hitting the first byte+ -- of memory that cannot be written and return the number of bytes written in+ -- the response via the `offset` and `bytesWritten` properties.+ -- If false or missing, a debug adapter should attempt to verify the region is+ -- writable before writing, and fail the response if it is not.+ --+ , writeMemoryArgumentsData :: Text+ -- ^+ -- Bytes to write, encoded using base64.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON WriteMemoryArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data DisassembleArguments+ = DisassembleArguments+ { disassembleArgumentsMemoryReference :: Text+ -- ^+ -- Memory reference to the base location containing the instructions to+ -- disassemble.+ --+ , disassembleArgumentsOffset :: Maybe Int+ -- ^+ -- Offset (in bytes) to be applied to the reference location before+ -- disassembling. Can be negative.+ --+ , disassembleArgumentsInstructionOffset :: Maybe Int+ -- ^+ -- Offset (in instructions) to be applied after the byte offset (if any)+ -- before disassembling. Can be negative.+ --+ , disassembleArgumentsInstructionCount :: Int+ -- ^+ -- Number of instructions to disassemble starting at the specified location+ -- and offset.+ -- An adapter must return exactly this number of instructions - any+ -- unavailable instructions should be replaced with an implementation-defined+ -- 'invalid instruction' value.+ --+ , disassembleArgumentsResolveSymbols :: Bool+ -- ^+ -- If true, the adapter should attempt to resolve memory addresses and other+ -- values to symbolic names.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON DisassembleArguments where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+-- | A ColumnDescriptor specifies what module attribute to show in a column of the modules view, how to format it,+-- and what the column’s label should be.+-- It is only used if the underlying UI actually supports this level of customization.+--+data ColumnDescriptor+ = ColumnDescriptor+ { columnDescriptorAttributeName :: String+ -- ^+ -- Name of the attribute rendered in this column.+ --+ , columnDescriptorLabel :: String+ -- ^+ -- Header UI label of column.+ --+ , columnDescriptorFormat :: Maybe String+ -- ^+ -- Format to use for the rendered values in this column. TBD how the format+ -- strings looks like.+ --+ , columnDescriptorType :: Maybe ColumnDescriptorType+ -- ^+ -- Datatype of values in this column. Defaults to `string` if not specified.+ -- Values: 'string', 'number', 'boolean', 'unixTimestampUTC'+ --+ , columnDescriptorWidth :: Maybe Int+ -- ^+ -- Width of this column in characters (hint only).+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultColumnDescriptor :: ColumnDescriptor+defaultColumnDescriptor+ = ColumnDescriptor+ { columnDescriptorAttributeName = mempty+ , columnDescriptorLabel = mempty+ , columnDescriptorFormat = Nothing+ , columnDescriptorType = Nothing+ , columnDescriptorWidth = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON ColumnDescriptor where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ColumnDescriptorType+ = ColumnDescriptorTypeString+ | ColumnDescriptorTypeInt+ | ColumnDescriptorTypeBool+ | ColumnDescriptorTypeUTCTime UTCTime+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ColumnDescriptorType where+ toJSON (ColumnDescriptorTypeUTCTime utcTime) = toJSON utcTime+ toJSON typ = genericToJSONWithModifier typ+----------------------------------------------------------------------------+-- | An ExceptionPathSegment represents a segment in a path that is used to match leafs or nodes in a tree of exceptions.+-- If a segment consists of more than one name, it matches the names provided if negate is false or missing, or it matches anything except the names provided if negate is true.+--+data ExceptionPathSegment+ = ExceptionPathSegment+ { exceptionPathSegmentNegate :: Maybe Bool+ , exceptionPathSegmentNames :: [String]+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance FromJSON ExceptionPathSegment where+ parseJSON = genericParseJSONWithModifier+----------------------------------------------------------------------------+data ModulesViewDescriptor+ = ModulesViewDescriptor+ { modulesViewDescriptorColumns :: [ColumnDescriptor]+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+instance ToJSON ModulesViewDescriptor where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+defaultModulesViewDescriptor :: ModulesViewDescriptor+defaultModulesViewDescriptor+ = ModulesViewDescriptor+ { modulesViewDescriptorColumns = []+ }+----------------------------------------------------------------------------+data CompletionItemType+ = CompletionItemTypeMethod+ | CompletionItemTypeFunction+ | CompletionItemTypeConstructor+ | CompletionItemTypeField+ | CompletionItemTypeVariable+ | CompletionItemTypeClass+ | CompletionItemTypeInterface+ | CompletionItemTypeModule+ | CompletionItemTypeProperty+ | CompletionItemTypeUnit+ | CompletionItemTypeValue+ | CompletionItemTypeEnum+ | CompletionItemTypeKeyword+ | CompletionItemTypeSnippet+ | CompletionItemTypeText+ | CompletionItemTypeColor+ | CompletionItemTypeFile+ | CompletionItemTypeReference+ | CompletionItemTypeCustomcolor+ deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+-- | An ExceptionBreakpointsFilter is shown in the UI as an filter option for configuring how exceptions are dealt with.+data ExceptionBreakpointsFilter+ = ExceptionBreakpointsFilter+ { exceptionBreakpointsFilterFilter :: Text+ -- ^+ -- The internal ID of the filter option. This value is passed to the+ -- `setExceptionBreakpoints` request.+ --+ , exceptionBreakpointsFilterLabel :: Text+ -- ^+ -- The name of the filter option. This is shown in the UI.+ --+ , 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.+ --+ , exceptionBreakpointsFilterDefault :: Maybe Bool+ -- ^+ -- Initial value of the filter option. If not specified a value false is+ -- assumed.+ --+ , exceptionBreakpointsFilterSupportsCondition :: Maybe Bool+ -- ^+ -- Controls whether a condition can be specified for this filter option. If+ -- false or missing, a condition can not be set.+ --+ , 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.+ --+ } deriving stock (Show, Eq, Generic)+----------------------------------------------------------------------------+defaultExceptionBreakpointsFilter :: ExceptionBreakpointsFilter+defaultExceptionBreakpointsFilter+ = ExceptionBreakpointsFilter+ { exceptionBreakpointsFilterFilter = mempty+ , exceptionBreakpointsFilterLabel = mempty+ , exceptionBreakpointsFilterDescription = Nothing+ , exceptionBreakpointsFilterDefault = Nothing+ , exceptionBreakpointsFilterSupportsCondition = Nothing+ , exceptionBreakpointsFilterConditionDescription = Nothing+ }+----------------------------------------------------------------------------+instance ToJSON ExceptionBreakpointsFilter where+ toJSON = genericToJSONWithModifier+----------------------------------------------------------------------------+data ConfigurationDoneArguments = ConfigurationDoneArguments+ deriving stock (Show, Eq)+----------------------------------------------------------------------------+instance FromJSON ConfigurationDoneArguments where+ parseJSON _ = pure ConfigurationDoneArguments+----------------------------------------------------------------------------+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)
+ src/DAP/Utils.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+----------------------------------------------------------------------------+-- |+-- Module : DAP.Utils+-- Copyright : (C) 2023 David M. Johnson+-- License : BSD3-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+----------------------------------------------------------------------------+module DAP.Utils where+----------------------------------------------------------------------------+import GHC.Generics (Generic, Rep)+import Data.Aeson ( ToJSON, Value, fieldLabelModifier+ , genericToJSON, genericParseJSON, fieldLabelModifier+ , defaultOptions, GToJSON, GFromJSON, Zero+ , constructorTagModifier, sumEncoding+ , SumEncoding(UntaggedValue), omitNothingFields+ )+import Data.Aeson.Types ( Parser )+import Data.Aeson.Encode.Pretty ( encodePretty )+import Data.ByteString ( ByteString )+import Data.Char ( isLower, toLower, toUpper )+import Data.Proxy (Proxy(Proxy))+import Data.Typeable ( Typeable, typeRep )+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Char8 as BS+----------------------------------------------------------------------------+-- | Encodes DAP protocol message appropriately+-- >+encodeBaseProtocolMessage :: ToJSON a => a -> ByteString+encodeBaseProtocolMessage msg =+ mconcat+ [ "Content-Length: " <> BS.pack (show (BS.length bytes)) <> "\r\n\r\n"+ , bytes+ ] where+ bytes = BL8.toStrict (encodePretty msg)+----------------------------------------------------------------------------+-- | Capitalization helper function+-- >>> capitalize "fooBar"+-- >>> "FooBar"+capitalize :: String -> String+capitalize [] = []+capitalize (x:xs)+ | isLower x = toUpper x : xs+ | otherwise = x : xs+----------------------------------------------------------------------------+-- | Lower cases a word+-- >>> toLowerCase "FooBar"+-- >>> "fooBar"+toLowerCase :: String -> String+toLowerCase [] = []+toLowerCase (x:xs) = toLower x : xs+----------------------------------------------------------------------------+-- | Used as a fieldLabelModifier when generating aeson parsers+-- >>> modifier (Proxy @Int) "intThing"+-- >>> String "thing"+modifier+ :: Typeable a+ => proxy a+ -> String+ -> String+modifier proxy+ = toLowerCase+ . drop (length (getName proxy))+----------------------------------------------------------------------------+-- | Used as a fieldLabelModifier when generating aeson parsers+-- >>> getName (Proxy @Int)+-- >>> "Int"+getName+ :: Typeable a+ => proxy a+ -> String+getName proxy = show (typeRep proxy)+----------------------------------------------------------------------------+-- | Used as a fieldLabelModifier when generating aeson parsers+-- >>> getName (Proxy @Int)+-- >>> "Int"+genericToJSONWithModifier+ :: forall a . (Generic a, GToJSON Zero (Rep a), Typeable a)+ => a -> Value+genericToJSONWithModifier+ = genericToJSON defaultOptions+ { fieldLabelModifier = modifier (Proxy @a)+ , constructorTagModifier = modifier (Proxy @a)+ , sumEncoding = UntaggedValue+ , omitNothingFields = True+ }+----------------------------------------------------------------------------+-- | Used as a fieldLabelModifier when generating aeson parsers+-- >>> getName (Proxy @Int)+-- >>> "Int"+genericParseJSONWithModifier+ :: forall a . (Generic a, GFromJSON Zero (Rep a), Typeable a)+ => Value+ -> Parser a+genericParseJSONWithModifier+ = genericParseJSON defaultOptions+ { fieldLabelModifier = modifier (Proxy @a)+ , constructorTagModifier = modifier (Proxy @a)+ , sumEncoding = UntaggedValue+ , omitNothingFields = True+ }+----------------------------------------------------------------------------+-- | Log formatting util+withBraces :: BL8.ByteString -> BL8.ByteString+withBraces x = "[" <> x <> "]"+----------------------------------------------------------------------------
+ test/Main.hs view
@@ -0,0 +1,193 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main+-- Copyright : (C) 2023 haskell-debugger+-- License : BSD3-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+----------------------------------------------------------------------------+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+----------------------------------------------------------------------------+module Main+ ( main+ ) where+----------------------------------------------------------------------------+import Control.Monad+import Control.Concurrent+import qualified Data.HashMap.Strict as H+import Data.Aeson.Encode.Pretty+import Data.Aeson.Types+import Data.Aeson.KeyMap+import Control.Concurrent.Async+import Control.Exception+import qualified Data.ByteString.Lazy.Char8 as BL8 ( hPutStrLn )+import Network.Simple.TCP hiding (send)+import Network.Socket (socketToHandle)+import System.IO+import Data.String.Conversions+import Test.Hspec+----------------------------------------------------------------------------+import DAP.Utils+import DAP.Types+import DAP.Event+import DAP.Server+import DAP.Response+----------------------------------------------------------------------------+main :: IO ()+main = withServer $+ hspec $ do+ describe "Should connect to the mock DAP server from a client" $ do++ it "Should increment sequence number properly" $ do+ withNewClient $ \h -> do+ send h+ [ "command" .= ("initialize" :: String)+ , "seq" .= (1 :: Int)+ , "type" .= ("request" :: String)+ ]+ shouldReceive h+ [ "seq" .= (2 :: Int)+ , "request_seq" .= (1 :: Int)+ ]++ it "Should connect / disconnect 100 clients" $ do+ replicateM_ 100 $+ withNewClient $ \h -> do+ send h+ [ "command" .= ("initialize" :: String)+ , "seq" .= (1 :: Int)+ , "type" .= ("request" :: String)+ ]+ shouldReceive h+ [ "seq" .= (2 :: Int)+ , "request_seq" .= (1 :: Int)+ ]++ it "Should perform req/resp. for initialize and receive initialized event" $ do+ withNewClient $ \h -> do+ send h+ [ "command" .= ("initialize" :: String)+ , "seq" .= (1 :: Int)+ , "type" .= ("request" :: String)+ ]+ shouldReceive h+ [ "seq" .= (2 :: Int)+ , "request_seq" .= (1 :: Int)+ , "command" .= ("initialize" :: String)+ , "type" .= ("response" :: String)+ ]+ shouldReceive h+ [ "type" .= ("event" :: String)+ , "event" .= ("initialized" :: String)+ ]++ it "Should receive configuration done and stop event" $ do+ withNewClient $ \h -> do+ send h+ [ "command" .= ("configurationDone" :: String)+ , "seq" .= (100 :: Int)+ , "type" .= ("request" :: String)+ ]+ shouldReceive h+ [ "seq" .= (101 :: Int)+ , "request_seq" .= (100 :: Int)+ , "command" .= ("configurationDone" :: String)+ , "type" .= ("response" :: String)+ ]+ shouldReceive h+ [ "type" .= ("event" :: String)+ , "event" .= ("stopped" :: String)+ ]++-- | Mock server communication, used in test runner+--+mockServerTalk+ :: Command+ -> Adaptor app ()+mockServerTalk CommandInitialize = do+ sendInitializeResponse+ sendInitializedEvent+mockServerTalk CommandConfigurationDone = do+ sendConfigurationDoneResponse+ sendStoppedEvent defaultStoppedEvent+mockServerTalk _ = pure ()++-- | Sample port shared amongst client and server+--+testPort :: Int+testPort = 8001++-- | Sample host shared amongst client and server+--+testHost :: String+testHost = "localhost"++-- | Runs server in a thread, 'withAsync' ensures cleanup.+--+withServer :: IO () -> IO ()+withServer test = withAsync server (const test)+ where+ server = runDAPServer config mockServerTalk+ sc = defaultCapabilities+ { supportsConfigurationDoneRequest = True+ , supportsHitConditionalBreakpoints = True+ , supportsModulesRequest = True+ , additionalModuleColumns = [ defaultColumnDescriptor+ { columnDescriptorAttributeName = "Extra"+ , columnDescriptorLabel = "Label"+ }+ ]+ , supportsValueFormattingOptions = True+ , supportTerminateDebuggee = True+ , supportsLoadedSourcesRequest = True+ }+ config = ServerConfig+ { host = testHost+ , port = testPort+ , serverCapabilities = sc+ , debugLogging = False+ }++-- | Spawns a new mock client that connects to the mock server.+--+withNewClient :: (Handle -> IO ()) -> IO ()+withNewClient continue = flip catch exceptionHandler $+ connect testHost (show testPort) $ \(socket, _) -> do+ h <- socketToHandle socket ReadWriteMode+ hSetNewlineMode h NewlineMode { inputNL = CRLF, outputNL = CRLF }+ continue h `finally` hClose h+ where+ exceptionHandler :: SomeException -> IO ()+ exceptionHandler _ = do+ threadDelay 100+ putStrLn "Retrying connection..."+ withNewClient continue++-- | Helper to send JSON payloads to the server+--+send :: Handle -> [Pair] -> IO ()+send h message+ = BL8.hPutStrLn h+ $ cs (encodeBaseProtocolMessage (object message))++-- | Helper to receive JSON payloads to the client+-- checks if 'Handle' returns a subset expected payload+--+shouldReceive+ :: Handle+ -- ^ Handle to receive bytes from+ -> [Pair]+ -- ^ Subset of JSON values that should be present in the payload+ -> IO ()+shouldReceive h expected = do+ case object expected of+ Object ex ->+ readPayload h >>= \case+ Left e -> fail e+ Right actual+ | toHashMapText ex `H.isSubmapOf` toHashMapText actual -> pure ()+ | otherwise -> encodePretty actual `shouldBe` encodePretty ex+ _ -> fail "Invalid JSON"