Skip to content

Commit 90146ef

Browse files
csabahruskacsabahruska
authored
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)