App capability setup, fixes, improvements (#13)

* update estg deps

* remove application specific dap capability setup code from the library

* put dap capability setup code to application ; add dummy code for hover support (via evaluate requet) ; fix reset object lifetimes - it should not be called in threads request ; make ext stg syntax highlighed (workaround)

* fix: disable placeholder code to make vscode extension compile

Author: csabahruska

dap-extension/src/extension.ts

@@ -26,7 +26,7 @@ export function activate(context: vscode.ExtensionContext) {
 		// The code you place here will be executed every time your command is executed
 		// Display a message box to the user
 		vscode.debug.activeDebugSession?.customRequest('garbageCollect');
-                window.showInformationMessage('Running garbage collection...');
+                //window.showInformationMessage('Running garbage collection...');
 	}));
 
 	runDebugger (context, new MockDebugAdapterServerDescriptorFactory());

dap/exe/Main.hs

@@ -88,10 +88,24 @@ getConfig = do
   let
     hostDefault = "127.0.0.1"
     portDefault = 4711
+    capabilities = defaultCapabilities
+      { supportsConfigurationDoneRequest      = True
+      , supportsHitConditionalBreakpoints     = True
+      , supportsEvaluateForHovers             = False
+      , supportsModulesRequest                = True
+      , additionalModuleColumns               = [ defaultColumnDescriptor
+                                                  { columnDescriptorAttributeName = "Extra"
+                                                  , columnDescriptorLabel = "Label"
+                                                  }
+                                                ]
+      , supportsValueFormattingOptions        = True
+      , supportTerminateDebuggee              = True
+      , supportsLoadedSourcesRequest          = True
+      }
   ServerConfig
     <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST"
     <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT"
-    <*> pure defaultCapabilities
+    <*> pure capabilities
     <*> pure True
 ----------------------------------------------------------------------------
 -- | VSCode arguments are custom for attach
@@ -211,15 +225,6 @@ handleDebuggerExceptions e = do
   sendTerminatedEvent (TerminatedEvent False)
   sendExitedEvent (ExitedEvent 1)
 
-pathToName path =
-  case splitFileName (cs path) of
-    (init -> moduleName, takeExtension -> ".ghccore") ->
-      cs (moduleName <> ".core")
-    (init -> moduleName, takeExtension -> ".stgbin") ->
-      cs (moduleName <> ".stg")
-    (init -> moduleName, takeExtension -> ext) ->
-      cs (moduleName <> ext)
-
 ----------------------------------------------------------------------------
 -- | Clears the currently known breakpoint set
 clearBreakpoints :: Adaptor ESTG ()
@@ -431,7 +436,6 @@ talk CommandSource = do
   sendSourceResponse (SourceResponse source Nothing)
 ----------------------------------------------------------------------------
 talk CommandThreads = do
-  resetObjectLifetimes
   allThreads <- IntMap.toList . ssThreads <$> getStgState
   sendThreadsResponse
     [ Thread
@@ -481,6 +485,18 @@ talk CommandSetExceptionBreakpoints   = sendSetExceptionBreakpointsResponse []
 talk CommandSetFunctionBreakpoints    = sendSetFunctionBreakpointsResponse []
 talk CommandSetInstructionBreakpoints = sendSetInstructionBreakpointsResponse []
 ----------------------------------------------------------------------------
+talk CommandEvaluate = do
+  EvaluateArguments {..} <- getArguments
+  sendEvaluateResponse EvaluateResponse
+    { evaluateResponseResult  = "evaluated value for " <> evaluateArgumentsExpression
+    , evaluateResponseType    = "evaluated type for " <> evaluateArgumentsExpression
+    , evaluateResponsePresentationHint    = Nothing
+    , evaluateResponseVariablesReference  = 1
+    , evaluateResponseNamedVariables      = Just 1
+    , evaluateResponseIndexedVariables    = Nothing
+    , evaluateResponseMemoryReference     = Nothing
+    }
+----------------------------------------------------------------------------
 talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd)
 ----------------------------------------------------------------------------
 
@@ -620,13 +636,15 @@ generateScopesForTopStackFrame frameIdDesc closureId env = do
   scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc
   setVariables scopeVarablesRef
     [ defaultVariable
-      { variableName  = cs binderName <> (if binderScope == ModulePublic then "" else cs ('_' : show u))
+      { variableName  = displayName
       , variableValue = cs variableValue
       , variableType  = Just (cs variableType)
+      , variableEvaluateName = Just $ displayName <> " evaluate"
       }
     | (Id (Binder{..}), (_, atom)) <- M.toList env
     , let (variableType, variableValue) = getAtomTypeAndValue atom
           BinderId u = binderId
+          displayName = if binderScope == ModulePublic then cs binderName else cs (show u)
     ]
   pure
     [ defaultScope
@@ -656,13 +674,15 @@ generateScopes frameIdDesc stackCont@(CaseOf _ closureId env _ _ _) = do
     -- DMJ: for now everything is local.
     -- Inspect StaticOrigin to put things top-level, or as arguments, where applicable
     [ defaultVariable
-      { variableName  = cs binderName <> (if binderScope == ModulePublic then "" else cs ('_' : show u))
+      { variableName  = displayName
       , variableValue = cs variableValue
       , variableType  = Just (cs variableType)
+      , variableEvaluateName = Just $ displayName <> " evaluate"
       }
     | (Id (Binder{..}), (_, atom)) <- M.toList env
     , let (variableType, variableValue) = getAtomTypeAndValue atom
           BinderId u = binderId
+          displayName = if binderScope == ModulePublic then cs binderName else cs (show u)
     ]
   pure
     [ defaultScope
@@ -1101,7 +1121,7 @@ getSourceName qualifiedModuleName = \case
   GhcStg    -> cs qualifiedModuleName <> ".ghcstg"
   Cmm       -> cs qualifiedModuleName <> ".cmm"
   Asm       -> cs qualifiedModuleName <> ".s"
-  ExtStg    -> cs qualifiedModuleName <> ".stgbin"
+  ExtStg    -> cs qualifiedModuleName <> ".stgbin.hs"
   FFICStub  -> cs qualifiedModuleName <> "_stub.c"
   FFIHStub  -> cs qualifiedModuleName <> "_stub.h"
   ForeignC  -> cs qualifiedModuleName

dap/src/DAP/Types.hs

@@ -685,10 +685,10 @@ defaultCapabilities :: Capabilities
 defaultCapabilities = capabilities
   where
     capabilities = Capabilities
-      { supportsConfigurationDoneRequest      = True
+      { supportsConfigurationDoneRequest      = False
       , supportsFunctionBreakpoints           = False
       , supportsConditionalBreakpoints        = False
-      , supportsHitConditionalBreakpoints     = True
+      , supportsHitConditionalBreakpoints     = False
       , supportsEvaluateForHovers             = False
       , exceptionBreakpointFilters            = []
       , supportsStepBack                      = False
@@ -698,21 +698,17 @@ defaultCapabilities = capabilities
       , supportsStepInTargetsRequest          = False
       , supportsCompletionsRequest            = False
       , completionTriggerCharacters           = []
-      , supportsModulesRequest                = True
-      , additionalModuleColumns               = [ defaultColumnDescriptor
-                                                  { columnDescriptorAttributeName = "Extra"
-                                                  , columnDescriptorLabel = "Label"
-                                                  }
-                                                ]
+      , supportsModulesRequest                = False
+      , additionalModuleColumns               = []
       , supportedChecksumAlgorithms           = []
       , supportsRestartRequest                = False
       , supportsExceptionOptions              = False
-      , supportsValueFormattingOptions        = True
+      , supportsValueFormattingOptions        = False
       , supportsExceptionInfoRequest          = False
-      , supportTerminateDebuggee              = True
+      , supportTerminateDebuggee              = False
       , supportSuspendDebuggee                = False
       , supportsDelayedStackTraceLoading      = False
-      , supportsLoadedSourcesRequest          = True
+      , supportsLoadedSourcesRequest          = False
       , supportsLogPoints                     = False
       , supportsTerminateThreadsRequest       = False
       , supportsSetExpression                 = False

dap/stack.yaml

@@ -12,7 +12,7 @@ extra-deps:
     commit: ac9616b94cb8c4a9e07188d19979a6225ebd5a10
 
   - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project
-    commit: d1bfe40f3b30dfb6059f51272a77633e81b499c8
+    commit: 8a854a42a3e48a43aa471e5db244ea04eeb1474b
     subdirs:
       - external-stg
       - external-stg-syntax

dap/test/Main.hs

@@ -134,10 +134,23 @@ withServer :: IO () -> IO ()
 withServer test = withAsync server (const test)
   where
     server = runDAPServer config mockServerTalk
+    capabilities = defaultCapabilities
+      { supportsConfigurationDoneRequest      = True
+      , supportsHitConditionalBreakpoints     = True
+      , supportsModulesRequest                = True
+      , additionalModuleColumns               = [ defaultColumnDescriptor
+                                                  { columnDescriptorAttributeName = "Extra"
+                                                  , columnDescriptorLabel = "Label"
+                                                  }
+                                                ]
+      , supportsValueFormattingOptions        = True
+      , supportTerminateDebuggee              = True
+      , supportsLoadedSourcesRequest          = True
+      }
     config = ServerConfig
       { host = testHost
       , port = testPort
-      , serverCapabilities = defaultCapabilities
+      , serverCapabilities = capabilities
       , debugLogging = False
       }