feature: Add Reverse Requests support

Exposes 'sendRunInTerminalReverseRequest' helper too.

Author: alt-romes

src/DAP/Adaptor.hs

@@ -26,6 +26,9 @@ module DAP.Adaptor
   , sendErrorResponse
   -- * Events
   , sendSuccesfulEvent
+  -- * Reverse Requests
+  , sendReverseRequest
+  , sendRunInTerminalReverseRequest
   -- * Server
   , getServerCapabilities
   , withConnectionLock
@@ -293,6 +296,21 @@ sendEvent action = do
   writeToHandle address handle payload
   resetAdaptorStatePayload
 ----------------------------------------------------------------------------
+-- | Write reverse request to Handle
+sendReverseRequest
+  :: ReverseCommand
+  -> Adaptor app Request ()
+sendReverseRequest rcmd = send $ do
+  setField "type" MessageTypeRequest
+  setField "command" rcmd
+----------------------------------------------------------------------------
+-- | Send runInTerminal reverse request
+sendRunInTerminalReverseRequest :: RunInTerminalRequestArguments -> Adaptor app Request ()
+sendRunInTerminalReverseRequest args = do
+  setField "arguments" args
+  sendReverseRequest ReverseCommandRunInTerminal
+
+----------------------------------------------------------------------------
 -- | Writes payload to the given 'Handle' using the local connection lock
 ----------------------------------------------------------------------------
 writeToHandle

src/DAP/Types.hs

@@ -72,6 +72,8 @@ module DAP.Types
   , PathFormat                         (..)
     -- * Command
   , Command                            (..)
+    -- * Reverse Command
+  , ReverseCommand                     (..)
     -- * Event
   , EventType                          (..)
     -- ** Events
@@ -121,6 +123,7 @@ module DAP.Types
   , LoadedSourcesResponse              (..)
   , ModulesResponse                    (..)
   , ReadMemoryResponse                 (..)
+  , RunInTerminalResponse              (..)
   , ScopesResponse                     (..)
   , SetExpressionResponse              (..)
   , SetVariableResponse                (..)
@@ -153,6 +156,8 @@ module DAP.Types
   , RestartArguments                   (..)
   , RestartFrameArguments              (..)
   , ReverseContinueArguments           (..)
+  , RunInTerminalRequestArguments      (..)
+  , RunInTerminalRequestArgumentsKind  (..)
   , ScopesArguments                    (..)
   , SetBreakpointsArguments            (..)
   , SetDataBreakpointsArguments        (..)
@@ -172,7 +177,6 @@ module DAP.Types
   , ThreadsArguments                   (..)
   , VariablesArguments                 (..)
   , WriteMemoryArguments               (..)
-  , RunInTerminalResponse              (..)
     -- * defaults
   , defaultBreakpoint
   , defaultBreakpointLocation
@@ -894,8 +898,6 @@ instance ToJSON EventType where
 ----------------------------------------------------------------------------
 data Command
   = CommandCancel
-  | CommandRunInTerminal
-  | CommandStartDebugging
   | CommandInitialize
   | CommandConfigurationDone
   | CommandLaunch
@@ -954,6 +956,24 @@ instance ToJSON Command where
   toJSON (CustomCommand x) = toJSON x
   toJSON cmd = genericToJSONWithModifier cmd
 ----------------------------------------------------------------------------
+data ReverseCommand
+  = ReverseCommandRunInTerminal
+  | ReverseCommandStartDebugging
+  deriving stock (Show, Eq, Read, Generic)
+----------------------------------------------------------------------------
+instance FromJSON ReverseCommand where
+  parseJSON = withText name $ \command ->
+    case readMaybe (name <> capitalize (T.unpack command)) of
+      Just cmd ->
+        pure cmd
+      Nothing ->
+        fail $ "Unknown reverse command: " ++ show command
+    where
+      name = show (typeRep (Proxy @ReverseCommand))
+----------------------------------------------------------------------------
+instance ToJSON ReverseCommand where
+  toJSON cmd = genericToJSONWithModifier cmd
+----------------------------------------------------------------------------
 data ErrorMessage
   = ErrorMessageCancelled
   | ErrorMessageNotStopped
@@ -2688,6 +2708,9 @@ data RunInTerminalRequestArgumentsKind
   | RunInTerminalRequestArgumentsKindExternal
   deriving stock (Show, Eq, Generic)
 ----------------------------------------------------------------------------
+instance ToJSON RunInTerminalRequestArgumentsKind where
+  toJSON = genericToJSONWithModifier
+----------------------------------------------------------------------------
 instance FromJSON RunInTerminalRequestArgumentsKind where
   parseJSON = genericParseJSONWithModifier
 ----------------------------------------------------------------------------
@@ -2728,6 +2751,9 @@ data RunInTerminalRequestArguments
     --
   } deriving stock (Show, Eq, Generic)
 ----------------------------------------------------------------------------
+instance ToJSON RunInTerminalRequestArguments where
+  toJSON = genericToJSONWithModifier
+----------------------------------------------------------------------------
 instance FromJSON RunInTerminalRequestArguments where
   parseJSON = genericParseJSONWithModifier
 ----------------------------------------------------------------------------