Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 435bd34

Browse files
intial breakpoint support ; for now only closure entries are supported
1 parent 738baa8 commit 435bd34

File tree

1 file changed

+78
-18
lines changed

1 file changed

+78
-18
lines changed

‎dap/exe/Main.hs

Lines changed: 78 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,6 @@
1919
----------------------------------------------------------------------------
2020
module Main (main) where
2121
----------------------------------------------------------------------------
22-
import Text.PrettyPrint.ANSI.Leijen (pretty, plain)
2322
import Codec.Archive.Zip (withArchive, unEntrySelector, getEntries)
2423
import qualified Data.Set as Set
2524
import Control.Arrow
@@ -36,6 +35,7 @@ import Data.Text ( Text )
3635
import qualified Data.Text as T
3736
import Data.Typeable ( typeOf )
3837
import Data.Maybe ( fromMaybe )
38+
import Data.List ( sortOn )
3939
import GHC.Generics ( Generic )
4040
import System.Environment ( lookupEnv )
4141
import System.FilePath ((</>), takeDirectory, takeExtension)
@@ -44,7 +44,8 @@ import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fr
4444
import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi
4545
----------------------------------------------------------------------------
4646
import Stg.Syntax hiding (sourceName, Scope)
47-
import Stg.Pretty ()
47+
import Stg.IRLocation
48+
import Stg.Pretty
4849
import Stg.Interpreter
4950
import Stg.Interpreter.Debug
5051
import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, getCurrentThreadState)
@@ -114,7 +115,7 @@ initESTG AttachArgs {..} = do
114115
frameRef <- liftIO (newIORef scopes')
115116
registerNewDebugSession __sessionId (ESTG dbgCmdI dbgOutO program)
116117
$ flip catch handleDebuggerExceptions
117-
$ do liftIO $ loadAndRunProgram True True program [] dbgChan DbgStepByStep False
118+
$ do liftIO $ loadAndRunProgram True True program [] dbgChan DbgStepByStep False defaultDebugSettings
118119
-- ^ doesn't seem to return here
119120
sendTerminatedEvent (TerminatedEvent False)
120121
sendExitedEvent (ExitedEvent 0)
@@ -160,6 +161,26 @@ talk CommandContinue = do
160161
ESTG {..} <- getDebugSession
161162
send CmdContinue
162163
sendContinueResponse (ContinueResponse True)
164+
165+
ESTG {..} <- getDebugSession
166+
_ <- liftIO $ Unagi.readChan outChan
167+
resetObjectLifetimes
168+
sendStoppedEvent defaultStoppedEvent
169+
{ stoppedEventReason = StoppedEventReasonBreakpoint
170+
, stoppedEventThreadId = Just 0
171+
}
172+
{-
173+
data StoppedEvent
174+
= StoppedEvent
175+
{ stoppedEventReason :: StoppedEventReason
176+
, stoppedEventDescription :: Maybe Text
177+
, stoppedEventThreadId :: Maybe Int
178+
, stoppedEventPreserveFocusHint :: Bool
179+
, stoppedEventText :: Maybe Text
180+
, stoppedEventAllThreadsStopped :: Bool
181+
, stoppedEventHitBreakpointIds :: [Int]
182+
-}
183+
163184
----------------------------------------------------------------------------
164185
talk CommandConfigurationDone = do
165186
sendConfigurationDoneResponse
@@ -301,16 +322,54 @@ talk CommandPause = sendPauseResponse
301322
-- }
302323
talk CommandSetBreakpoints = do
303324
SetBreakpointsArguments {..} <- getArguments
304-
let maybeName = sourceName setBreakpointsArgumentsSource
305-
case (setBreakpointsArgumentsBreakpoints, maybeName) of
306-
(Just [ SourceBreakpoint {..} ], Just name) -> do
307-
send (CmdAddBreakpoint (T.encodeUtf8 name) sourceBreakpointLine)
308-
sendSetBreakpointsResponse
309-
[ defaultBreakpoint { breakpointId = Just sourceBreakpointLine
310-
, breakpointSource = Just setBreakpointsArgumentsSource
311-
, breakpointVerified = True
312-
}
313-
]
325+
let maybeSourceRef = sourceSourceReference setBreakpointsArgumentsSource
326+
case (setBreakpointsArgumentsBreakpoints, maybeSourceRef) of
327+
(Just sourceBreakpoints, Just sourceRef) -> do
328+
(_sourceCodeText, locations) <- getSourceFromFullPak sourceRef
329+
breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do
330+
-- filter all relevant ranges
331+
{-
332+
SP_RhsClosureExpr
333+
-}
334+
let onlySupported = \case
335+
SP_RhsClosureExpr{} -> True
336+
_ -> False
337+
let relevantLocations = filter (onlySupported . fst) $ case sourceBreakpointColumn of
338+
Nothing ->
339+
[ p
340+
| p@(_,((startRow, startCol), (endRow, endCol))) <- locations
341+
, startRow <= sourceBreakpointLine
342+
, endRow >= sourceBreakpointLine
343+
]
344+
Just col ->
345+
[ p
346+
| p@(_,((startRow, startCol), (endRow, endCol))) <- locations
347+
, startRow <= sourceBreakpointLine
348+
, endRow >= sourceBreakpointLine
349+
, startCol <= col
350+
, endCol >= col
351+
]
352+
liftIO $ putStrLn $ "relevantLocations: " ++ show relevantLocations
353+
-- use the first location found
354+
case sortOn snd relevantLocations of
355+
(stgPoint@(SP_RhsClosureExpr closureName), ((startRow, startCol), (endRow, endCol))) : _ -> do
356+
let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int
357+
send (CmdAddBreakpoint closureName hitCount)
358+
pure $ defaultBreakpoint
359+
{ breakpointVerified = True
360+
, breakpointSource = Just setBreakpointsArgumentsSource
361+
, breakpointLine = Just startRow
362+
, breakpointColumn = Just startCol
363+
, breakpointEndLine = Just endRow
364+
, breakpointEndColumn = Just endCol
365+
}
366+
_ ->
367+
pure $ defaultBreakpoint
368+
{ breakpointVerified = False
369+
, breakpointSource = Just setBreakpointsArgumentsSource
370+
, breakpointMessage = Just "no code found"
371+
}
372+
sendSetBreakpointsResponse breakpoints
314373
_ ->
315374
sendSetBreakpointsResponse []
316375
----------------------------------------------------------------------------
@@ -338,7 +397,7 @@ talk CommandStackTrace = do
338397
----------------------------------------------------------------------------
339398
talk CommandSource = do
340399
SourceArguments {..} <- getArguments -- save path of fullpak in state
341-
source <- getSourceFromFullPak sourceArgumentsSourceReference
400+
(source, _locations) <- getSourceFromFullPak sourceArgumentsSourceReference
342401
sendSourceResponse (SourceResponse source Nothing)
343402
----------------------------------------------------------------------------
344403
talk CommandThreads = do
@@ -421,17 +480,18 @@ getModuleListFromFullPak = do
421480
]
422481
----------------------------------------------------------------------------
423482
-- | Retrieves list of modules from .fullpak file
424-
getSourceFromFullPak :: SourceId -> Adaptor ESTG Text
483+
getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)])
425484
getSourceFromFullPak sourceId = do
426485
sourcePath <- T.unpack <$> getSourcePathBySourceReferenceId sourceId
427486
ESTG {..} <- getDebugSession
428487
liftIO $
429488
if takeExtension sourcePath == ".stgbin"
430489
then do
431490
m <- readModpakL fullPakPath sourcePath decodeStgbin
432-
pure $ T.pack $ show $ plain (pretty m)
433-
else
434-
readModpakS fullPakPath sourcePath T.decodeUtf8
491+
pure . pShow $ pprModule m
492+
else do
493+
ir <- readModpakS fullPakPath sourcePath T.decodeUtf8
494+
pure (ir, [])
435495
----------------------------------------------------------------------------
436496
-- | Asynchronous call to Debugger, sends message, does not wait for response
437497
send

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /