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 90146ef

Browse files
Ir navigation and graph visualization (#21)
* add getSourceLinks custom request ; generate distinct variable references for each stack frame ; attach source location info for 'code' variables * split into multiple modules * remove unnecessary resource handling abstraction: DapSourceRefDescriptor * remove hardcoded filepaths, generate call graph * code cleanup * show value graph event now supports call graphs and heap graphs also * adjust atom visualization to be more descriptive * fix scope name * work in progress value inspector * update dependencies * remove dead code * remove unused channels
1 parent 2b1d14e commit 90146ef

File tree

16 files changed

+1769
-1167
lines changed

16 files changed

+1769
-1167
lines changed

‎dap-estgi-server/dap-estgi-server.cabal

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,21 @@ extra-source-files:
1717
CHANGELOG.md
1818

1919
executable dap-estgi
20+
other-modules:
21+
Inspect.Stack
22+
Inspect.Value
23+
Inspect.Value.Atom
24+
Inspect.Value.HeapObject
25+
Inspect.Value.StackContinuation
26+
CustomCommands
27+
GraphProtocol.Commands
28+
GraphProtocol.Server
29+
Graph
30+
Breakpoints
31+
DapBase
32+
SourceCode
33+
SourceLocation
34+
2035
main-is:
2136
Main.hs
2237
ghc-options:
@@ -45,6 +60,7 @@ executable dap-estgi
4560
, zip
4661
, bimap
4762
, pretty-simple
63+
, network-simple
4864
hs-source-dirs:
4965
src
5066
default-language:

‎dap-estgi-server/src/Breakpoints.hs

Lines changed: 162 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,162 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
module Breakpoints where
5+
6+
import Text.Read ( readMaybe )
7+
import Data.Maybe ( fromMaybe, maybeToList )
8+
import Data.List ( sortOn )
9+
import Control.Monad
10+
import Data.String.Conversions (cs)
11+
import qualified Data.Text as T
12+
import qualified Data.Bimap as Bimap
13+
import qualified Data.IntSet as IntSet
14+
import qualified Data.Map.Strict as Map
15+
import qualified Stg.Interpreter.Base as Stg
16+
import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint)
17+
import Stg.Syntax hiding (sourceName, Scope)
18+
import Stg.IRLocation
19+
20+
import DAP
21+
import DapBase
22+
import SourceCode
23+
24+
----------------------------------------------------------------------------
25+
-- | Clears the currently known breakpoint set
26+
clearBreakpoints :: Adaptor ESTG ()
27+
clearBreakpoints = do
28+
updateDebugSession $ \estg -> estg {breakpointMap = mempty}
29+
30+
----------------------------------------------------------------------------
31+
-- | Adds new BreakpointId for a givent StgPoint
32+
addNewBreakpoint :: Stg.Breakpoint -> Adaptor ESTG BreakpointId
33+
addNewBreakpoint breakpoint = do
34+
bkpId <- getFreshBreakpointId
35+
updateDebugSession $ \estg@ESTG{..} -> estg {breakpointMap = Map.insertWith mappend breakpoint (IntSet.singleton bkpId) breakpointMap}
36+
pure bkpId
37+
38+
commandSetBreakpoints :: Adaptor ESTG ()
39+
commandSetBreakpoints = do
40+
SetBreakpointsArguments {..} <- getArguments
41+
maybeSourceRef <- getValidSourceRefFromSource setBreakpointsArgumentsSource
42+
43+
-- the input SourceRef might be a remain of a previous DAP session, update it with the new valid one
44+
let refUpdatedSource = setBreakpointsArgumentsSource { sourceSourceReference = maybeSourceRef }
45+
46+
clearBreakpoints
47+
{-
48+
supports placing breakpoint on:
49+
- Haskell
50+
- ExtStg
51+
-}
52+
ESTG {..} <- getDebugSession
53+
case (setBreakpointsArgumentsBreakpoints, maybeSourceRef, maybeSourceRef >>= flip Bimap.lookupR dapSourceRefMap) of
54+
-- HINT: breakpoint on Haskell
55+
(Just sourceBreakpoints, Just sourceRef, Just hsCodeDesc@(Haskell pkg mod))
56+
| Just extStgSourceRef <- Bimap.lookup (ExtStg pkg mod) dapSourceRefMap
57+
, Just hsSourceFilePath <- Bimap.lookupR hsCodeDesc haskellSrcPathMap
58+
-> do
59+
(_sourceCodeText, _locations, hsSrcLocs) <- getSourceFromFullPak extStgSourceRef
60+
breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do
61+
-- filter all relevant ranges
62+
{-
63+
SP_RhsClosureExpr
64+
-}
65+
let onlySupported = \case
66+
SP_RhsClosureExpr{} -> True
67+
_ -> True -- TODO
68+
let relevantLocations = filter (onlySupported . fst . fst) $ case sourceBreakpointColumn of
69+
Nothing ->
70+
[ (p, spanSize)
71+
| p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs
72+
, srcSpanFile == hsSourceFilePath
73+
, srcSpanSLine <= sourceBreakpointLine
74+
, srcSpanELine >= sourceBreakpointLine
75+
, let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol)
76+
]
77+
Just col ->
78+
[ (p, spanSize)
79+
| p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs
80+
, srcSpanFile == hsSourceFilePath
81+
, srcSpanSLine <= sourceBreakpointLine
82+
, srcSpanELine >= sourceBreakpointLine
83+
, srcSpanSCol <= col
84+
, srcSpanECol >= col
85+
, let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol)
86+
]
87+
debugMessage . cs . unlines $ "relevant haskell locations:" : map show relevantLocations
88+
-- use the first location found
89+
-- HINT: locations are sorted according the span size, small spans are preferred more
90+
case map fst . take 1 $ sortOn snd relevantLocations of
91+
(stgPoint@(SP_RhsClosureExpr _closureName), SourceNote RealSrcSpan'{..} _) : _ -> do
92+
let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int
93+
sendAndWait (CmdAddBreakpoint (BkpStgPoint stgPoint) hitCount)
94+
bkpId <- addNewBreakpoint $ BkpStgPoint stgPoint
95+
pure $ defaultBreakpoint
96+
{ breakpointVerified = True
97+
, breakpointSource = Just refUpdatedSource
98+
, breakpointLine = Just srcSpanSLine
99+
, breakpointColumn = Just srcSpanSCol
100+
, breakpointEndLine = Just srcSpanELine
101+
, breakpointEndColumn = Just srcSpanECol
102+
, breakpointId = Just bkpId
103+
}
104+
_ ->
105+
pure $ defaultBreakpoint
106+
{ breakpointVerified = False
107+
, breakpointSource = Just refUpdatedSource
108+
, breakpointMessage = Just "no hs code found"
109+
}
110+
sendSetBreakpointsResponse breakpoints
111+
112+
-- HINT: breakpoint on ExtStg
113+
(Just sourceBreakpoints, Just sourceRef, Just ExtStg{}) -> do
114+
(_sourceCodeText, locations, _hsSrcLocs) <- getSourceFromFullPak sourceRef
115+
breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do
116+
-- filter all relevant ranges
117+
{-
118+
SP_RhsClosureExpr
119+
-}
120+
let onlySupported = \case
121+
SP_RhsClosureExpr{} -> True
122+
_ -> False
123+
let relevantLocations = filter (onlySupported . fst) $ case sourceBreakpointColumn of
124+
Nothing ->
125+
[ p
126+
| p@(_,((startRow, startCol), (endRow, endCol))) <- locations
127+
, startRow <= sourceBreakpointLine
128+
, endRow >= sourceBreakpointLine
129+
]
130+
Just col ->
131+
[ p
132+
| p@(_,((startRow, startCol), (endRow, endCol))) <- locations
133+
, startRow <= sourceBreakpointLine
134+
, endRow >= sourceBreakpointLine
135+
, startCol <= col
136+
, endCol >= col
137+
]
138+
debugMessage . cs $ "relevantLocations: " ++ show relevantLocations
139+
-- use the first location found
140+
case sortOn snd relevantLocations of
141+
(stgPoint@(SP_RhsClosureExpr _closureName), ((startRow, startCol), (endRow, endCol))) : _ -> do
142+
let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int
143+
sendAndWait (CmdAddBreakpoint (BkpStgPoint stgPoint) hitCount)
144+
bkpId <- addNewBreakpoint $ BkpStgPoint stgPoint
145+
pure $ defaultBreakpoint
146+
{ breakpointVerified = True
147+
, breakpointSource = Just refUpdatedSource
148+
, breakpointLine = Just startRow
149+
, breakpointColumn = Just startCol
150+
, breakpointEndLine = Just endRow
151+
, breakpointEndColumn = Just endCol
152+
, breakpointId = Just bkpId
153+
}
154+
_ ->
155+
pure $ defaultBreakpoint
156+
{ breakpointVerified = False
157+
, breakpointSource = Just refUpdatedSource
158+
, breakpointMessage = Just "no code found"
159+
}
160+
sendSetBreakpointsResponse breakpoints
161+
v -> do
162+
sendSetBreakpointsResponse []

‎dap-estgi-server/src/CustomCommands.hs

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
module CustomCommands where
4+
5+
import GHC.Generics ( Generic )
6+
7+
import Data.Text
8+
import Data.Aeson
9+
import DAP.Utils
10+
11+
data GetSourceLinksArguments
12+
= GetSourceLinksArguments
13+
{ getSourceLinksArgumentsPath :: Text
14+
} deriving stock (Show, Eq, Generic)
15+
16+
instance FromJSON GetSourceLinksArguments where
17+
parseJSON = genericParseJSONWithModifier
18+
19+
------------
20+
21+
data GetSourceLinksResponse
22+
= GetSourceLinksResponse
23+
{ getSourceLinksResponseSourceLinks :: [SourceLink]
24+
} deriving stock (Show, Eq, Generic)
25+
----------------------------------------------------------------------------
26+
instance ToJSON GetSourceLinksResponse where
27+
toJSON = genericToJSONWithModifier
28+
----------------------------------------------------------------------------
29+
data SourceLink
30+
= SourceLink
31+
{ sourceLinkSourceLine :: Int
32+
, sourceLinkSourceColumn :: Int
33+
, sourceLinkSourceEndLine :: Int
34+
, sourceLinkSourceEndColumn :: Int
35+
, sourceLinkTargetLine :: Int
36+
, sourceLinkTargetColumn :: Int
37+
, sourceLinkTargetEndLine :: Int
38+
, sourceLinkTargetEndColumn :: Int
39+
, sourceLinkTargetPath :: Text
40+
} deriving stock (Show, Eq, Generic)
41+
----------------------------------------------------------------------------
42+
instance ToJSON SourceLink where
43+
toJSON = genericToJSONWithModifier
44+
45+
----------------------------------------------------------------------------
46+
data ShowVariableGraphStructureArguments
47+
= ShowVariableGraphStructureArguments
48+
{ showVariableGraphStructureArgumentsVariablesReference :: Int
49+
} deriving stock (Show, Eq, Generic)
50+
51+
instance FromJSON ShowVariableGraphStructureArguments where
52+
parseJSON = genericParseJSONWithModifier
53+
54+
----------------------------------------------------------------------------

0 commit comments

Comments
(0)

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