Update registerDebugSession event handler thread to take callback

dap/exe/Main.hs

@@ -134,18 +134,17 @@ initESTG AttachArgs {..} = do
         , fullPakPath   = program
         , breakpointMap = mempty
         }
-  adaptorStateMVar <- gets adaptorStateMVar
   flip catch handleDebuggerExceptions
     $ registerNewDebugSession __sessionId estg
       (loadAndRunProgram True True program [] dbgChan DbgStepByStep False defaultDebugSettings)
-      (handleDebugEvents dbgChan adaptorStateMVar)
+      (handleDebugEvents dbgChan)
 
 ----------------------------------------------------------------------------
 -- | Debug Event Handler
-handleDebugEvents :: DebuggerChan -> MVar (AdaptorState ESTG) -> IO ()
-handleDebugEvents DebuggerChan{..} adaptorStateMVar = forever $ do
+handleDebugEvents :: DebuggerChan -> (Adaptor ESTG () -> IO ()) -> IO ()
+handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do
   dbgEvent <- liftIO (Unagi.readChan dbgAsyncEventOut)
-  runAdaptorWith adaptorStateMVar $ do
+  withAdaptor $ do
     ESTG {..} <- getDebugSession
     let sendEvent ev = sendSuccesfulEvent ev . setBody
     case dbgEvent of

dap/src/DAP/Adaptor.hs

@@ -73,15 +73,21 @@ module DAP.Adaptor
   -- * 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         ( ThreadId )
+import           Control.Concurrent.MVar    ( newMVar, newEmptyMVar, modifyMVar_
+                                            , takeMVar, putMVar, readMVar, 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       ( throwError )
-import           Control.Monad.State.Strict ( MonadIO(liftIO), gets, modify', put )
+import           Control.Monad.Except       ( runExceptT, throwError )
+import           Control.Monad.State        ( evalStateT, runStateT, execStateT, gets
+                                            , MonadIO(liftIO), gets, modify', put )
 import           Data.Aeson                 ( FromJSON, Result (..), fromJSON )
 import           Data.Maybe                 ( fromMaybe )
 import           Data.Aeson.Encode.Pretty   ( encodePretty )
@@ -183,18 +189,30 @@ registerNewDebugSession
   -> app
   -> IO ()
   -- ^ Action to run debugger (operates in a forked thread that gets killed when disconnect is set)
-  -> IO ()
+  -> ((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
+      <*> fork (outputEventSink (runAdaptorWith adaptorStateMVar))
   liftIO . atomically $ modifyTVar' store (H.insert k (debuggerThreadState, v))
   setDebugSessionId k
   logInfo $ BL8.pack $ "Registered new debug session: " <> unpack k
@@ -539,3 +557,18 @@ addSourcePathBySourceReferenceId path sourceId =
   modify' $ \s -> s
     { sourceReferencesMap = I.insert sourceId path (sourceReferencesMap s)
     }
+
+----------------------------------------------------------------------------
+-- | 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 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

dap/src/DAP/Server.hs

@@ -19,7 +19,6 @@
 ----------------------------------------------------------------------------
 module DAP.Server
   ( runDAPServer
-  , runAdaptorWith
   ) where
 ----------------------------------------------------------------------------
 import           Control.Concurrent.MVar    ( MVar )
@@ -132,21 +131,6 @@ serviceClient communicate adaptorStateMVar = do
   -- loop: serve the next request
   serviceClient communicate adaptorStateMVar
 
-----------------------------------------------------------------------------
--- | 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 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
-
 ----------------------------------------------------------------------------
 -- | Handle exceptions from client threads, parse and log accordingly
 exceptionHandler :: Handle -> SockAddr -> SomeException -> IO ()