Breakpoint support (#8)

* support serializable concurrency for Adaptor state monad

* allow application domain specific state updates

* update wpc dep

* implement async breakpoint and stopped event handling

* Update registerDebugSession event handler thread to take callback function. (#9)

- Relocate 'runAdaptorWith' to Adaptor.hs
- Add some comments for 'registerDebugSession'

---------

Co-authored-by: David Johnson <djohnson.m@gmail.com>

Author: csabahruska

dap/exe/Main.hs

@@ -25,28 +25,34 @@ import           Data.List
 import           Data.String.Conversions               (cs)
 import           Text.PrettyPrint.ANSI.Leijen          (pretty, plain)
 import           Codec.Archive.Zip                     (withArchive, unEntrySelector, getEntries)
+import           Data.IntSet                           ( IntSet )
+import qualified Data.IntSet                           as IntSet
 import qualified Data.Set                              as Set
 import           Control.Arrow
 import           Data.IORef
 import           Control.Exception                     hiding (catch)
 import           Control.Monad.IO.Class                (liftIO)
 import           Control.Exception.Lifted              (catch)
+import           Control.Monad.State.Strict            ( gets )
 import           Control.Monad
 import           Data.Aeson                            ( Value(Null), FromJSON )
 import qualified Data.IntMap.Strict                    as I
 import qualified Data.Map.Strict                       as M
+import           Data.Map.Strict                       ( Map )
 import qualified Data.Text.Encoding                    as T
 import           Data.Text                             ( Text )
 import qualified Data.Text                             as T
 import           Data.Typeable                         ( typeOf )
-import           Data.Maybe                            ( fromMaybe )
+import           Data.Maybe                            ( fromMaybe, catMaybes )
 import           Data.List                             ( sortOn )
 import           GHC.Generics                          ( Generic )
 import           System.Environment                    ( lookupEnv )
 import           System.FilePath                       ((</>), takeDirectory, takeExtension, dropExtension, splitFileName)
 import           Text.Read                             ( readMaybe )
 import qualified Data.ByteString.Lazy.Char8            as BL8 ( pack, unpack, fromStrict, toStrict )
 import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi
+import           Control.Concurrent.MVar               ( MVar )
+import qualified Control.Concurrent.MVar               as MVar
 ----------------------------------------------------------------------------
 import           Stg.Syntax                            hiding (sourceName, Scope)
 import           Stg.IRLocation
@@ -105,26 +111,62 @@ data AttachArgs
 -- | External STG Interpreter application internal state
 data ESTG
   = ESTG
-  { inChan :: Unagi.InChan DebugCommand
-  , outChan :: Unagi.OutChan DebugOutput
-  , fullPakPath :: String
+  { debuggerChan  :: DebuggerChan
+  , fullPakPath   :: String
+  , breakpointMap :: Map StgPoint IntSet
   }
 ----------------------------------------------------------------------------
 -- | Intialize ESTG interpreter
 ----------------------------------------------------------------------------
 initESTG :: AttachArgs -> Adaptor ESTG ()
 initESTG AttachArgs {..} = do
-  (dbgCmdI, dbgCmdO) <- liftIO (Unagi.newChan 100)
-  (dbgOutI, dbgOutO) <- liftIO (Unagi.newChan 100)
-  let dbgChan = DebuggerChan (dbgCmdO, dbgOutI)
+  (dbgAsyncI, dbgAsyncO) <- liftIO (Unagi.newChan 100)
+  dbgRequestMVar <- liftIO MVar.newEmptyMVar
+  dbgResponseMVar <- liftIO MVar.newEmptyMVar
+  let dbgChan = DebuggerChan
+        { dbgSyncRequest    = dbgRequestMVar
+        , dbgSyncResponse   = dbgResponseMVar
+        , dbgAsyncEventIn   = dbgAsyncI
+        , dbgAsyncEventOut  = dbgAsyncO
+        }
+      estg = ESTG
+        { debuggerChan  = dbgChan
+        , fullPakPath   = program
+        , breakpointMap = mempty
+        }
   flip catch handleDebuggerExceptions
-    $ registerNewDebugSession __sessionId (ESTG dbgCmdI dbgOutO program)
-      (liftIO $ loadAndRunProgram True True program [] dbgChan DbgStepByStep False defaultDebugSettings)
-      (pure ())
-      -- (forever $ do
-      --     message <- liftIO (Unagi.readChan dbgOutO)
-      --     -- logic goes here for conversion to 'OutputEvent'
-      --     sendOutputEvent defaultOutputEvent)
+    $ registerNewDebugSession __sessionId estg
+      (loadAndRunProgram True True program [] dbgChan DbgStepByStep False defaultDebugSettings)
+      (handleDebugEvents dbgChan)
+
+----------------------------------------------------------------------------
+-- | Debug Event Handler
+handleDebugEvents :: DebuggerChan -> (Adaptor ESTG () -> IO ()) -> IO ()
+handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do
+  dbgEvent <- liftIO (Unagi.readChan dbgAsyncEventOut)
+  withAdaptor $ do
+    ESTG {..} <- getDebugSession
+    let sendEvent ev = sendSuccesfulEvent ev . setBody
+    case dbgEvent of
+      DbgEventStopped -> do
+        resetObjectLifetimes
+        sendEvent EventTypeStopped $ object
+          [ "reason"             .= String "step"
+          , "allThreadsStopped"  .= True
+          ]
+
+      DbgEventHitBreakpoint bkpName -> do
+        resetObjectLifetimes
+        sendEvent EventTypeStopped . object $
+          [ "reason"             .= String "breakpoint"
+          , "allThreadsStopped"  .= True
+          ] ++
+          catMaybes
+            [ do
+                idSet <- M.lookup (SP_RhsClosureExpr bkpName) breakpointMap
+                Just ("hitBreakpointIds" .= idSet)
+            ]
+
 ----------------------------------------------------------------------------
 -- | Exception Handler
 handleDebuggerExceptions :: SomeException -> Adaptor ESTG ()
@@ -136,17 +178,6 @@ handleDebuggerExceptions e = do
   sendTerminatedEvent (TerminatedEvent False)
   sendExitedEvent (ExitedEvent 1)
 
-sendStop =
-  sendStoppedEvent $
-      StoppedEvent
-           StoppedEventReasonPause
-           (Just "paused")
-           (Just 0)
-           False
-           (Just "starting now?")
-           False
-           []
-
 pathToName path =
   case splitFileName (cs path) of
     (init -> moduleName, takeExtension -> ".ghccore") ->
@@ -156,6 +187,20 @@ pathToName path =
     (init -> moduleName, takeExtension -> ext) ->
       cs (moduleName <> ext)
 
+----------------------------------------------------------------------------
+-- | Clears the currently known breakpoint set
+clearBreakpoints :: Adaptor ESTG ()
+clearBreakpoints = do
+  updateDebugSession $ \estg -> estg {breakpointMap = mempty}
+
+----------------------------------------------------------------------------
+-- | Adds new BreakpointId for a givent StgPoint
+addNewBreakpoint :: StgPoint -> Adaptor ESTG BreakpointId
+addNewBreakpoint stgPoint = do
+  bkpId <- getNextBreakpointId
+  updateDebugSession $ \estg@ESTG{..} -> estg {breakpointMap = M.insertWith mappend stgPoint (IntSet.singleton bkpId) breakpointMap}
+  pure bkpId
+
 ----------------------------------------------------------------------------
 -- | Main function where requests are received and Events + Responses are returned.
 -- The core logic of communicating between the client <-> adaptor <-> debugger
@@ -173,32 +218,12 @@ talk CommandAttach = do
 ----------------------------------------------------------------------------
 talk CommandContinue = do
   ESTG {..} <- getDebugSession
-  send CmdContinue
+  sendAndWait CmdContinue
   sendContinueResponse (ContinueResponse True)
 
-  ESTG {..} <- getDebugSession
-  _ <- liftIO $ Unagi.readChan outChan
-  resetObjectLifetimes
-  sendStoppedEvent defaultStoppedEvent
-    { stoppedEventReason = StoppedEventReasonBreakpoint
-    , stoppedEventThreadId = Just 0
-    }
-{-
-data StoppedEvent
-  = StoppedEvent
-  { stoppedEventReason :: StoppedEventReason
-  , stoppedEventDescription :: Maybe Text
-  , stoppedEventThreadId :: Maybe Int
-  , stoppedEventPreserveFocusHint :: Bool
-  , stoppedEventText :: Maybe Text
-  , stoppedEventAllThreadsStopped :: Bool
-  , stoppedEventHitBreakpointIds :: [Int]
--}
-
 ----------------------------------------------------------------------------
 talk CommandConfigurationDone = do
   sendConfigurationDoneResponse
-  sendStop
 ----------------------------------------------------------------------------
 talk CommandDisconnect = do
   destroyDebugSession
@@ -326,6 +351,7 @@ talk CommandPause = sendPauseResponse
 talk CommandSetBreakpoints = do
   SetBreakpointsArguments {..} <- getArguments
   let maybeSourceRef = sourceSourceReference setBreakpointsArgumentsSource
+  clearBreakpoints
   case (setBreakpointsArgumentsBreakpoints, maybeSourceRef) of
     (Just sourceBreakpoints, Just sourceRef) -> do
       (_sourceCodeText, locations) <- getSourceFromFullPak sourceRef
@@ -357,14 +383,16 @@ talk CommandSetBreakpoints = do
         case sortOn snd relevantLocations of
           (stgPoint@(SP_RhsClosureExpr closureName), ((startRow, startCol), (endRow, endCol))) : _ -> do
             let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int
-            send (CmdAddBreakpoint closureName hitCount)
+            sendAndWait (CmdAddBreakpoint closureName hitCount)
+            bkpId <- addNewBreakpoint stgPoint
             pure $ defaultBreakpoint
               { breakpointVerified  = True
               , breakpointSource    = Just setBreakpointsArgumentsSource
               , breakpointLine      = Just startRow
               , breakpointColumn    = Just startCol
               , breakpointEndLine   = Just endRow
               , breakpointEndColumn = Just endCol
+              , breakpointId        = Just bkpId
               }
           _ ->
             pure $ defaultBreakpoint
@@ -429,12 +457,7 @@ talk CommandVariables = do
 talk CommandNext = do
   NextArguments {..} <- getArguments
   sendAndWait CmdStep
-  resetObjectLifetimes
-  sendStoppedEvent defaultStoppedEvent
-    { stoppedEventReason   = StoppedEventReasonStep
-    , stoppedEventText     = Just "Stepping..."
-    , stoppedEventThreadId = Just 0
-    }
+  pure ()
 ----------------------------------------------------------------------------
 talk CommandBreakpointLocations       = sendBreakpointLocationsResponse []
 talk CommandSetDataBreakpoints        = sendSetDataBreakpointsResponse []
@@ -508,21 +531,14 @@ getSourceFromFullPak sourceId = do
         ir <- readModpakS fullPakPath sourcePath T.decodeUtf8
         pure (ir, [])
 ----------------------------------------------------------------------------
--- | Asynchronous call to Debugger, sends message, does not wait for response
-send
-  :: DebugCommand
-  -> Adaptor ESTG ()
-send cmd = do
-  ESTG {..} <- getDebugSession
-  liftIO (Unagi.writeChan inChan cmd)
-----------------------------------------------------------------------------
 -- | Synchronous call to Debugger, sends message and waits for response
 sendAndWait :: DebugCommand -> Adaptor ESTG DebugOutput
 sendAndWait cmd = do
   ESTG {..} <- getDebugSession
+  let DebuggerChan{..} = debuggerChan
   liftIO $ do
-    Unagi.writeChan inChan cmd
-    Unagi.readChan outChan
+    MVar.putMVar dbgSyncRequest cmd
+    MVar.takeMVar dbgSyncResponse
 ----------------------------------------------------------------------------
 -- | Receive Thread Report
 -- Fails if anything but 'DbgOutThreadReport' is returned

dap/src/DAP/Adaptor.hs

@@ -33,6 +33,7 @@ module DAP.Adaptor
   , getRequestSeqNum
   -- * Debug Session
   , registerNewDebugSession
+  , updateDebugSession
   , getDebugSession
   , getDebugSessionId
   , destroyDebugSession
@@ -63,28 +64,38 @@ module DAP.Adaptor
   , setCurrentVariableId
   , getCurrentVariableId
   , getNextVariableId
+  -- * Breakpoint handling
+  , getNextBreakpointId
   -- * Source handling
   , getNextSourceReferenceId
   , getSourcePathBySourceReferenceId
   , addSourcePathBySourceReferenceId
   -- * 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 )
 import           Data.Aeson.Types           ( object, Key, KeyValue((.=)), ToJSON )
 import qualified Data.IntMap.Strict         as I
 import           Data.IntMap.Strict         (IntMap)
+import qualified Data.IntSet                as IntSet
+import           Data.IntSet                (IntSet)
 import           Data.Text                  ( unpack, Text, pack )
 import           Network.Socket             ( SockAddr )
 import           System.IO                  ( Handle )
@@ -171,24 +182,42 @@ setDebugSessionId session = modify' $ \s -> s { sessionId = Just session }
 registerNewDebugSession
   :: SessionId
   -> app
-  -> Adaptor app ()
+  -> IO ()
   -- ^ Action to run debugger (operates in a forked thread that gets killed when disconnect is set)
-  -> Adaptor app ()
+  -> ((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
-  debuggerThreadState <-
+  adaptorStateMVar <- gets adaptorStateMVar
+  debuggerThreadState <- liftIO $
     DebuggerThreadState
-      <$> fork (resetAdaptorStatePayload >> debuggerExecution)
-      <*> fork (resetAdaptorStatePayload >> outputEventSink)
+      <$> 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
@@ -494,6 +523,11 @@ getNextVariableId = do
   modify' $ \s -> s { currentVariableId = currentVariableId s + 1 }
   gets currentVariableId
 
+getNextBreakpointId :: Adaptor app BreakpointId
+getNextBreakpointId = do
+  modify' $ \s -> s { currentBreakpointId = currentBreakpointId s + 1 }
+  gets currentBreakpointId
+
 getNextSourceReferenceId :: Adaptor app SourceId
 getNextSourceReferenceId = do
   modify' $ \s -> s { currentSourceReferenceId = currentSourceReferenceId s + 1 }
@@ -517,3 +551,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 (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