Call hierarchy support

.github/workflows/test.yml

@@ -200,3 +200,7 @@ jobs:
       - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }}
         name: Test hls-refine-imports-plugin test suite
         run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun"
+
+      - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc }}
+        name: Test hls-call-hierarchy-plugin test suite
+        run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun"

cabal-ghc901.project

@@ -22,6 +22,7 @@ packages:
          ./plugins/hls-pragmas-plugin
          ./plugins/hls-module-name-plugin
         --  ./plugins/hls-ormolu-plugin
+         ./plugins/hls-call-hierarchy-plugin
 tests: true
 
 package *

cabal.project

@@ -22,6 +22,7 @@ packages:
          ./plugins/hls-pragmas-plugin
          ./plugins/hls-module-name-plugin
          ./plugins/hls-ormolu-plugin
+         ./plugins/hls-call-hierarchy-plugin
 tests: true
 
 package *
@@ -83,4 +84,3 @@ allow-newer:
     svg-builder:base,
     these:base,
     time-compat:base
-

exe/Plugins.hs

@@ -13,6 +13,10 @@ import           Ide.Plugin.Example2               as Example2
 
 -- haskell-language-server optional plugins
 
+#if callHierarchy
+import           Ide.Plugin.CallHierarchy          as CallHierarchy
+#endif
+
 #if class
 import           Ide.Plugin.Class                  as Class
 #endif
@@ -117,6 +121,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
 #if brittany
       Brittany.descriptor "brittany" :
 #endif
+#if callHierarchy
+      CallHierarchy.descriptor "callHierarchy":
+#endif
 #if class
       Class.descriptor "class" :
 #endif

ghcide/test/exe/Main.hs

@@ -196,6 +196,7 @@ initializeResponseTests = withResource acquire release tests where
     , chk "NO folding range"          _foldingRangeProvider (Just $ InL False)
     , che "   execute command"      _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId]
     , chk "   workspace"                         _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}))
+    , chk "   call hierarchy"        _callHierarchyProvider (Just $ InL True)
     , chk "NO experimental"                   _experimental Nothing
     ] where
 

haskell-language-server.cabal

@@ -106,6 +106,11 @@ flag class
   default:     True
   manual:      True
 
+flag callHierarchy
+  description: Enable call hierarchy plugin
+  default:     True
+  manual:      True
+
 flag haddockComments
   description: Enable haddockComments plugin
   default:     True
@@ -193,6 +198,11 @@ common class
     build-depends: hls-class-plugin ^>= 1.0.0.1
     cpp-options: -Dclass
 
+common callHierarchy
+  if flag(callHierarchy) || flag(all-plugins)
+    build-depends: hls-call-hierarchy-plugin ^>= 1.0.0.0
+    cpp-options: -DcallHierarchy
+
 common haddockComments
   if flag(haddockComments) || flag(all-plugins)
     build-depends: hls-haddock-comments-plugin ^>= 1.0.0.1
@@ -274,6 +284,7 @@ executable haskell-language-server
   import:             common-deps
                     -- plugins
                     , example-plugins
+                    , callHierarchy
                     , class
                     , haddockComments
                     , eval
@@ -426,6 +437,8 @@ test-suite func-test
   if flag(pedantic)
     ghc-options: -Werror -Wredundant-constraints
 
+  if flag(callHierarchy) || flag(all-plugins)
+    cpp-options: -DcallHierarchy
   if flag(class) || flag(all-plugins)
     cpp-options: -Dclass
   if flag(haddockComments) || flag(all-plugins)

hls-plugin-api/src/Ide/Plugin/Config.hs

@@ -121,54 +121,58 @@ instance A.ToJSON Config where
 -- This provides a regular naming scheme for all plugin config.
 data PluginConfig =
     PluginConfig
-      { plcGlobalOn      :: !Bool
-      , plcCodeActionsOn :: !Bool
-      , plcCodeLensOn    :: !Bool
-      , plcDiagnosticsOn :: !Bool
-      , plcHoverOn       :: !Bool
-      , plcSymbolsOn     :: !Bool
-      , plcCompletionOn  :: !Bool
-      , plcRenameOn      :: !Bool
-      , plcConfig        :: !A.Object
+      { plcGlobalOn        :: !Bool
+      , plcCallHierarchyOn :: !Bool
+      , plcCodeActionsOn   :: !Bool
+      , plcCodeLensOn      :: !Bool
+      , plcDiagnosticsOn   :: !Bool
+      , plcHoverOn         :: !Bool
+      , plcSymbolsOn       :: !Bool
+      , plcCompletionOn    :: !Bool
+      , plcRenameOn        :: !Bool
+      , plcConfig          :: !A.Object
       } deriving (Show,Eq)
 
 instance Default PluginConfig where
   def = PluginConfig
-      { plcGlobalOn      = True
-      , plcCodeActionsOn = True
-      , plcCodeLensOn    = True
-      , plcDiagnosticsOn = True
-      , plcHoverOn       = True
-      , plcSymbolsOn     = True
-      , plcCompletionOn  = True
-      , plcRenameOn      = True
-      , plcConfig        = mempty
+      { plcGlobalOn        = True
+      , plcCallHierarchyOn = True
+      , plcCodeActionsOn   = True
+      , plcCodeLensOn      = True
+      , plcDiagnosticsOn   = True
+      , plcHoverOn         = True
+      , plcSymbolsOn       = True
+      , plcCompletionOn    = True
+      , plcRenameOn        = True
+      , plcConfig          = mempty
       }
 
 instance A.ToJSON PluginConfig where
-    toJSON (PluginConfig g ca cl d h s c rn cfg) = r
+    toJSON (PluginConfig g ch ca cl d h s c rn cfg) = r
       where
-        r = object [ "globalOn"      .= g
-                   , "codeActionsOn" .= ca
-                   , "codeLensOn"    .= cl
-                   , "diagnosticsOn" .= d
-                   , "hoverOn"       .= h
-                   , "symbolsOn"     .= s
-                   , "completionOn"  .= c
-                   , "renameOn"      .= rn
-                   , "config"        .= cfg
+        r = object [ "globalOn"        .= g
+                   , "callHierarchyOn" .= ch
+                   , "codeActionsOn"   .= ca
+                   , "codeLensOn"      .= cl
+                   , "diagnosticsOn"   .= d
+                   , "hoverOn"         .= h
+                   , "symbolsOn"       .= s
+                   , "completionOn"    .= c
+                   , "renameOn"        .= rn
+                   , "config"          .= cfg
                    ]
 
 instance A.FromJSON PluginConfig where
   parseJSON = A.withObject "PluginConfig" $ \o  -> PluginConfig
-      <$> o .:? "globalOn"      .!= plcGlobalOn def
-      <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def
-      <*> o .:? "codeLensOn"    .!= plcCodeLensOn    def
-      <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ
-      <*> o .:? "hoverOn"       .!= plcHoverOn       def
-      <*> o .:? "symbolsOn"     .!= plcSymbolsOn     def
-      <*> o .:? "completionOn"  .!= plcCompletionOn  def
-      <*> o .:? "renameOn"      .!= plcRenameOn      def
-      <*> o .:? "config"        .!= plcConfig        def
+      <$> o .:? "globalOn"        .!= plcGlobalOn def
+      <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def
+      <*> o .:? "codeActionsOn"   .!= plcCodeActionsOn def
+      <*> o .:? "codeLensOn"      .!= plcCodeLensOn    def
+      <*> o .:? "diagnosticsOn"   .!= plcDiagnosticsOn def -- AZ
+      <*> o .:? "hoverOn"         .!= plcHoverOn       def
+      <*> o .:? "symbolsOn"       .!= plcSymbolsOn     def
+      <*> o .:? "completionOn"    .!= plcCompletionOn  def
+      <*> o .:? "renameOn"        .!= plcRenameOn      def
+      <*> o .:? "config"          .!= plcConfig        def
 
 -- ---------------------------------------------------------------------

hls-plugin-api/src/Ide/Types.hs

@@ -255,6 +255,15 @@ instance PluginMethod TextDocumentRangeFormatting where
   pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
   combineResponses _ _ _ _ (x :| _) = x
 
+instance PluginMethod TextDocumentPrepareCallHierarchy where
+  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
+
+instance PluginMethod CallHierarchyIncomingCalls where
+  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
+
+instance PluginMethod CallHierarchyOutgoingCalls where
+  pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn
+
 -- ---------------------------------------------------------------------
 
 -- | Methods which have a PluginMethod instance
@@ -452,6 +461,8 @@ instance HasTracing InitializeParams
 instance HasTracing (Maybe InitializedParams)
 instance HasTracing WorkspaceSymbolParams where
   traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query)
+instance HasTracing CallHierarchyIncomingCallsParams
+instance HasTracing CallHierarchyOutgoingCallsParams
 
 -- ---------------------------------------------------------------------