From 31aa35ed8649299de181d2b16690ee68d9098e5a Mon Sep 17 00:00:00 2001
From: Csaba Hruska <csaba.hruska@gmail.com>
Date: Wed, 27 Sep 2023 11:31:04 +0200
Subject: [PATCH] add getSourceLinks custom request ; generate distinct
variable references for each stack frame ; attach source location info for
'code' variables
---
dap-estgi-server/dap-estgi-server.cabal | 2 +
dap-estgi-server/src/CustomCommands.hs | 43 ++++++++
dap-estgi-server/src/Main.hs | 137 ++++++++++++++++++------
3 files changed, 151 insertions(+), 31 deletions(-)
create mode 100644 dap-estgi-server/src/CustomCommands.hs
diff --git a/dap-estgi-server/dap-estgi-server.cabal b/dap-estgi-server/dap-estgi-server.cabal
index c1030b4..2141f13 100644
--- a/dap-estgi-server/dap-estgi-server.cabal
+++ b/dap-estgi-server/dap-estgi-server.cabal
@@ -17,6 +17,8 @@ extra-source-files:
CHANGELOG.md
executable dap-estgi
+ other-modules:
+ CustomCommands
main-is:
Main.hs
ghc-options:
diff --git a/dap-estgi-server/src/CustomCommands.hs b/dap-estgi-server/src/CustomCommands.hs
new file mode 100644
index 0000000..3cab19c
--- /dev/null
+++ b/dap-estgi-server/src/CustomCommands.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveGeneric #-}
+module CustomCommands where
+
+import GHC.Generics ( Generic )
+
+import Data.Text
+import Data.Aeson
+import DAP.Utils
+
+data GetSourceLinksArguments
+ = GetSourceLinksArguments
+ { getSourceLinksArgumentsPath :: Text
+ } deriving stock (Show, Eq, Generic)
+
+instance FromJSON GetSourceLinksArguments where
+ parseJSON = genericParseJSONWithModifier
+
+------------
+
+data GetSourceLinksResponse
+ = GetSourceLinksResponse
+ { getSourceLinksResponseSourceLinks :: [SourceLink]
+ } deriving stock (Show, Eq, Generic)
+----------------------------------------------------------------------------
+instance ToJSON GetSourceLinksResponse where
+ toJSON = genericToJSONWithModifier
+----------------------------------------------------------------------------
+data SourceLink
+ = SourceLink
+ { sourceLinkSourceLine :: Int
+ , sourceLinkSourceColumn :: Int
+ , sourceLinkSourceEndLine :: Int
+ , sourceLinkSourceEndColumn :: Int
+ , sourceLinkTargetLine :: Int
+ , sourceLinkTargetColumn :: Int
+ , sourceLinkTargetEndLine :: Int
+ , sourceLinkTargetEndColumn :: Int
+ , sourceLinkTargetPath :: Text
+ } deriving stock (Show, Eq, Generic)
+----------------------------------------------------------------------------
+instance ToJSON SourceLink where
+ toJSON = genericToJSONWithModifier
diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs
index 8f20377..a0d0a01 100644
--- a/dap-estgi-server/src/Main.hs
+++ b/dap-estgi-server/src/Main.hs
@@ -39,6 +39,7 @@ import Control.Monad.State.Strict ( gets )
import Control.Monad
import Control.Monad.State.Strict ( gets )
import Data.Aeson ( Value(Null), FromJSON )
+import qualified Data.Aeson as Aeson
import Data.IntMap.Strict ( IntMap )
import qualified Data.IntMap.Strict as IntMap
import Data.Bimap ( Bimap )
@@ -50,7 +51,7 @@ import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Lazy as LazyText
import Data.Typeable ( typeOf )
-import Data.Maybe ( fromMaybe )
+import Data.Maybe ( fromMaybe, maybeToList )
import Data.List ( sortOn )
import GHC.Generics ( Generic )
import System.Environment ( lookupEnv )
@@ -80,6 +81,8 @@ import qualified Text.Pretty.Simple as PP
----------------------------------------------------------------------------
import DAP hiding (send)
----------------------------------------------------------------------------
+import CustomCommands
+----------------------------------------------------------------------------
-- | DAP entry point
-- Extracts configuration information from the environment
-- Opens a listen socket on a port (defaulting to '4711')
@@ -316,6 +319,47 @@ talk CommandLoadedSources = do
srcSet <- getsApp sourceCodeSet
mapM (getSourceFromSourceRefDescriptor . SourceRef_SourceFileInFullpak) $ filter shouldInclude $ Set.toList srcSet
+----------------------------------------------------------------------------
+talk (CustomCommand "getSourceLinks") = do
+ GetSourceLinksArguments {..} <- getArguments
+ ESTG {..} <- getDebugSession
+ sourceLinks <- case Bimap.lookup getSourceLinksArgumentsPath dapSourceNameMap of
+ Just srcDesc@(SourceRef_SourceFileInFullpak ExtStg{}) -> do
+ source <- getSourceFromSourceRefDescriptor srcDesc
+ let Just sourceRef = sourceSourceReference source
+ (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef
+ let hsTickishLocMap = M.unionsWith mappend [M.singleton stgPoint [tickish] | (stgPoint, tickish) <- hsSrcLocs]
+ -- collect tickish locations
+ estgLocMap = M.unionsWith mappend
+ [ M.singleton stgPoint [range]
+ | (SP_Tickish stgPoint, range) <- locations
+ ]
+ liftIO $ do
+ print hsTickishLocMap
+ print estgLocMap
+ pure $
+ [ SourceLink
+ { sourceLinkSourceLine = estgStartLine
+ , sourceLinkSourceColumn = estgStartCol
+ , sourceLinkSourceEndLine = estgEndLine
+ , sourceLinkSourceEndColumn = estgEndCol
+ , sourceLinkTargetLine = srcSpanSLine
+ , sourceLinkTargetColumn = srcSpanSCol
+ , sourceLinkTargetEndLine = srcSpanELine
+ , sourceLinkTargetEndColumn = srcSpanECol
+ , sourceLinkTargetPath = cs $ getSourceName hsCodeDesc
+ }
+ | (stgPoint, hsTickishList) <- M.toList hsTickishLocMap
+ , estgLocList <- maybeToList $ M.lookup stgPoint estgLocMap
+ , (((estgStartLine, estgStartCol),(estgEndLine, estgEndCol)), SourceNote{..}) <- zip estgLocList hsTickishList
+ , let RealSrcSpan'{..} = sourceSpan
+ , hsCodeDesc <- maybeToList $ Bimap.lookup srcSpanFile haskellSrcPathMap
+ ]
+ _ -> pure []
+ sendSuccesfulResponse . setBody $ GetSourceLinksResponse
+ { getSourceLinksResponseSourceLinks = sourceLinks
+ }
+
----------------------------------------------------------------------------
talk CommandModules = do
sendModulesResponse (ModulesResponse [] Nothing)
@@ -572,12 +616,12 @@ talk CommandVariables = do
Just VariablesRef_StackFrameVariables{} -> do
variables <- getVariables variablesArgumentsVariablesReference
sendVariablesResponse (VariablesResponse variables)
- Just (VariablesRef_HeapObject addr) -> do
+ Just (VariablesRef_HeapObject frameIdDesc addr) -> do
stgState <- getStgState
ho <- case IntMap.lookup addr $ ssHeap stgState of
Nothing -> sendError (ErrorMessage (T.pack $ "Unknown heap object: " ++ show addr)) Nothing
Just v -> pure v
- variables <- getVariablesForHeapObject stgState ho
+ variables <- getVariablesForHeapObject stgState frameIdDesc ho
-- detect and annotate loops
let markLoop v
| variableVariablesReference v == 0
@@ -587,6 +631,8 @@ talk CommandVariables = do
| otherwise
= v {variableName = variableName v <> " <also-shown-in-ancestor>"}
sendVariablesResponse (VariablesResponse $ map markLoop variables)
+ Nothing -> do
+ sendVariablesResponse (VariablesResponse [])
----------------------------------------------------------------------------
talk CommandNext = do
NextArguments {..} <- getArguments
@@ -789,12 +835,12 @@ generateScopesForTopStackFrame frameIdDesc closureId env = do
varList <- forM (M.toList env) $ \(Id (Binder{..}), (_, atom)) -> do
let BinderId u = binderId
displayName = if binderScope == ModulePublic then cs binderName else cs (show u)
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
pure defaultVariable
{ variableName = displayName
, variableValue = cs variableValue
, variableType = Just (cs variableType)
- , variableEvaluateName = Just $ displayName <> " evaluate"
+ -- , variableEvaluateName = Just $ displayName <> " evaluate"
, variableVariablesReference = varsRef
}
setVariables scopeVarablesRef varList
@@ -821,10 +867,27 @@ getHeapObjectSummary = \case
ApStack{} -> "ApStack"
RaiseException{} -> "RaiseException"
-getVariablesForHeapObject :: StgState -> HeapObject -> Adaptor ESTG [Variable]
-getVariablesForHeapObject stgState = \case
+getStgSourceLocJSON :: Id -> Adaptor ESTG (Maybe Text)
+getStgSourceLocJSON i = do
+ (mSource, startL, startC, endL, endC) <- getSourceAndPositionForStgPoint i (SP_Binding i)
+ let mkPosObject line column = Aeson.object
+ [ ("line", Aeson.Number $ fromIntegral line)
+ , ("column", Aeson.Number $ fromIntegral column)
+ ]
+ srcLocJson = do
+ Source{..} <- mSource
+ path <- sourcePath
+ pure . cs . Aeson.encode $ Aeson.object
+ [ ("path", Aeson.String path)
+ , ("start", mkPosObject startL startC)
+ , ("end", mkPosObject endL endC)
+ ]
+ pure srcLocJson
+
+getVariablesForHeapObject :: StgState -> DapFrameIdDescriptor -> HeapObject -> Adaptor ESTG [Variable]
+getVariablesForHeapObject stgState frameIdDesc = \case
Con{..} -> forM (zip [0..] hoConArgs) $ \(idx, atom) -> do
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
pure defaultVariable
{ variableName = cs $ "arg" ++ show idx
, variableValue = cs variableValue
@@ -832,9 +895,11 @@ getVariablesForHeapObject stgState = \case
, variableVariablesReference = varsRef
}
Closure{..} -> do
+ srcLocJson <- getStgSourceLocJSON hoName
let bodyVar = defaultVariable
{ variableName = "code"
, variableValue = cs $ show hoName
+ , variableEvaluateName = srcLocJson
}
{-
TODO:
@@ -843,7 +908,7 @@ getVariablesForHeapObject stgState = \case
show missing-args-count / is thunk?
-}
argVarList <- forM (zip [0..] hoCloArgs) $ \(idx, atom) -> do
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
pure defaultVariable
{ variableName = cs $ "arg" ++ show idx
, variableValue = cs variableValue
@@ -851,19 +916,28 @@ getVariablesForHeapObject stgState = \case
, variableVariablesReference = varsRef
}
envVarList <- forM (M.toList hoEnv) $ \(Id (Binder{..}), (_, atom)) -> do
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
let BinderId u = binderId
displayName = if binderScope == ModulePublic then cs binderName else cs (show u)
pure defaultVariable
{ variableName = displayName
, variableValue = cs variableValue
, variableType = Just (cs variableType)
- , variableEvaluateName = Just $ displayName <> " evaluate"
+ -- , variableEvaluateName = Just $ displayName <> " evaluate"
, variableVariablesReference = varsRef
}
pure $ bodyVar : argVarList ++ envVarList
BlackHole{..} -> do
- (ownerVarType, ownerVarValue, ownerVarsRef) <- getAtomTypeAndValueM stgState $ ThreadId hoBHOwnerThreadId
+ (ownerVarType, ownerVarValue, ownerVarsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ ThreadId hoBHOwnerThreadId
+ bodyVar <- case hoBHOriginalThunk of
+ Closure{..} -> do
+ srcLocJson <- getStgSourceLocJSON hoName
+ pure . pure $ defaultVariable
+ { variableName = "code"
+ , variableValue = cs $ show hoName
+ , variableEvaluateName = cs <$> srcLocJson
+ }
+ _ -> pure []
let onwerVar = defaultVariable
{ variableName = "owner thread id"
, variableValue = cs ownerVarValue
@@ -872,17 +946,17 @@ getVariablesForHeapObject stgState = \case
}
queueVarList <- forM hoBHWaitQueue $ \tid -> do
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState $ ThreadId tid
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ ThreadId tid
pure defaultVariable
{ variableName = "waiting thread id"
, variableValue = cs variableValue
, variableType = Just (cs variableType)
, variableVariablesReference = varsRef
}
- pure $ onwerVar : queueVarList
+ pure $ bodyVar ++ onwerVar : queueVarList
ApStack{..} -> do
resultVarList <- forM hoResult $ \atom -> do
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
pure defaultVariable
{ variableName = "latest result"
, variableValue = cs variableValue
@@ -892,7 +966,7 @@ getVariablesForHeapObject stgState = \case
-- TODO: hoStack
pure resultVarList
RaiseException ex -> do
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState ex
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc ex
pure $ pure defaultVariable
{ variableName = "exception"
, variableValue = cs variableValue
@@ -914,14 +988,14 @@ generateScopes frameIdDesc stackCont@(CaseOf _ closureId env _ _ _) = do
varList <- forM (M.toList env) $ \(Id (Binder{..}), (_, atom)) -> do
-- DMJ: for now everything is local.
-- Inspect StaticOrigin to put things top-level, or as arguments, where applicable
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
let BinderId u = binderId
displayName = if binderScope == ModulePublic then cs binderName else cs (show u)
pure defaultVariable
{ variableName = displayName
, variableValue = cs variableValue
, variableType = Just (cs variableType)
- , variableEvaluateName = Just $ displayName <> " evaluate"
+ -- , variableEvaluateName = Just $ displayName <> " evaluate"
, variableVariablesReference = varsRef
}
setVariables scopeVarablesRef varList
@@ -940,7 +1014,7 @@ generateScopes frameIdDesc stackCont@(CaseOf _ closureId env _ _ _) = do
generateScopes frameIdDesc stackCont@(Update addr) = do
scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
stgState <- getStgState
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState $ HeapPtr addr
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ HeapPtr addr
setVariables scopeVarablesRef
[ defaultVariable
{ variableName = "Thunk Address"
@@ -960,7 +1034,7 @@ generateScopes frameIdDesc stackCont@(Apply atoms) = do
scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
stgState <- getStgState
varList <- forM atoms $ \atom -> do
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
pure defaultVariable
{ variableName = "Closure argument"
, variableValue = cs variableValue
@@ -978,7 +1052,7 @@ generateScopes frameIdDesc stackCont@(Apply atoms) = do
generateScopes frameIdDesc stackCont@(Catch atom blockAsync interruptible) = do
scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
stgState <- getStgState
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
setVariables scopeVarablesRef
[ defaultVariable
{ variableName = "Exception Handler"
@@ -1050,7 +1124,7 @@ generateScopes frameIdDesc stackCont@(RunScheduler reason) = do
generateScopes frameIdDesc stackCont@(Atomically atom) = do
scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
stgState <- getStgState
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
setVariables scopeVarablesRef
[ defaultVariable
{ variableName = "STM action"
@@ -1069,8 +1143,8 @@ generateScopes frameIdDesc stackCont@(Atomically atom) = do
generateScopes frameIdDesc stackCont@(CatchRetry primaryAction alternativeAction isRunningAlternative _tlog) = do
scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
stgState <- getStgState
- (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState primaryAction
- (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState alternativeAction
+ (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState frameIdDesc primaryAction
+ (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState frameIdDesc alternativeAction
setVariables scopeVarablesRef
[ defaultVariable
{ variableName = "First STM action"
@@ -1101,8 +1175,8 @@ generateScopes frameIdDesc stackCont@(CatchRetry primaryAction alternativeAction
generateScopes frameIdDesc (CatchSTM action handler) = do
scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
stgState <- getStgState
- (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState action
- (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState handler
+ (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState frameIdDesc action
+ (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState frameIdDesc handler
setVariables scopeVarablesRef
[ defaultVariable
{ variableName = "STM action"
@@ -1136,7 +1210,7 @@ generateScopes frameIdDesc stackCont@DataToTagOp = do
generateScopes frameIdDesc stackCont@(RaiseOp atom) = do
scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
stgState <- getStgState
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
setVariables scopeVarablesRef
[ defaultVariable
{ variableName = "RaiseOp"
@@ -1155,7 +1229,7 @@ generateScopes frameIdDesc stackCont@(RaiseOp atom) = do
generateScopes frameIdDesc stackCont@(KeepAlive atom) = do
scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
stgState <- getStgState
- (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom
+ (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom
setVariables scopeVarablesRef
[ defaultVariable
{ variableName = "Managed Object"
@@ -1233,13 +1307,14 @@ showPrimRep rep = show rep
getAtomTypeAndValueM
:: StgState
+ -> DapFrameIdDescriptor
-> Atom
-> Adaptor ESTG (String, String, Int)
-getAtomTypeAndValueM ss@StgState{..} = \case
+getAtomTypeAndValueM ss@StgState{..} frameIdDesc = \case
HeapPtr addr
| Just o <- IntMap.lookup addr ssHeap
-> do
- varsRef <- getVariablesRef $ VariablesRef_HeapObject addr
+ varsRef <- getVariablesRef $ VariablesRef_HeapObject frameIdDesc addr
pure ("HeapPtr", show addr ++ " " ++ getHeapObjectSummary o ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o), varsRef)
atom
| (t, v) <- getAtomTypeAndValue ss atom
@@ -1348,7 +1423,7 @@ data DapFrameIdDescriptor
data DapVariablesRefDescriptor
= VariablesRef_StackFrameVariables DapFrameIdDescriptor
- | VariablesRef_HeapObject Int
+ | VariablesRef_HeapObject DapFrameIdDescriptor Int
deriving (Show, Eq, Ord)
data SourceCodeDescriptor