Support call hierarchy on type signature & add plugin to generic config & docs (#2072)

* Document call hierarchy plugin

* Fix typo

* Supoort call hierarchy on type signatures

* Add change log in readme

* Add call hierarchy config

* Remove unused tests

* Add plugin section in main readme

* Update plugins/hls-call-hierarchy-plugin/test/Main.hs

Co-authored-by: Javier Neira  <[email protected]>

* Update plugins/hls-call-hierarchy-plugin/README.md

Detailed description about config

Co-authored-by: Javier Neira  <[email protected]>

* Revise version

Co-authored-by: Javier Neira  <[email protected]>

Author: July541

hls-plugin-api/hls-plugin-api.cabal

@@ -1,6 +1,6 @@
 cabal-version: 2.4
 name:          hls-plugin-api
-version:       1.2.0.0
+version:       1.2.0.1
 synopsis:      Haskell Language Server API for plugin communication
 description:
   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>

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

@@ -86,13 +86,14 @@ pluginsToDefaultConfig IdePlugins {..} =
         -- This function captures ide methods registered by the plugin, and then converts it to kv pairs
         handlersToGenericDefaultConfig :: DSum.DSum IdeMethod f -> [A.Pair]
         handlersToGenericDefaultConfig (IdeMethod m DSum.:=> _) = case m of
-          STextDocumentCodeAction     -> ["codeActionsOn" A..= True]
-          STextDocumentCodeLens       -> ["codeLensOn" A..= True]
-          STextDocumentRename         -> ["renameOn" A..= True]
-          STextDocumentHover          -> ["hoverOn" A..= True]
-          STextDocumentDocumentSymbol -> ["symbolsOn" A..= True]
-          STextDocumentCompletion     -> ["completionOn" A..= True]
-          _                           -> []
+          STextDocumentCodeAction           -> ["codeActionsOn" A..= True]
+          STextDocumentCodeLens             -> ["codeLensOn" A..= True]
+          STextDocumentRename               -> ["renameOn" A..= True]
+          STextDocumentHover                -> ["hoverOn" A..= True]
+          STextDocumentDocumentSymbol       -> ["symbolsOn" A..= True]
+          STextDocumentCompletion           -> ["completionOn" A..= True]
+          STextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= True]
+          _                                 -> []
 
 -- | Generates json schema used in haskell vscode extension
 -- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure
@@ -121,6 +122,7 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug
           STextDocumentHover -> [withIdPrefix "hoverOn" A..= schemaEntry "hover"]
           STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= schemaEntry "symbols"]
           STextDocumentCompletion -> [withIdPrefix "completionOn" A..= schemaEntry "completions"]
+          STextDocumentPrepareCallHierarchy -> [withIdPrefix "callHierarchyOn" A..= schemaEntry "call hierarchy"]
           _ -> []
         schemaEntry desc =
           A.object

plugins/hls-call-hierarchy-plugin/README.md

@@ -0,0 +1,32 @@
+# Call hierarchy plugin for the [Haskell Language Server](https://github.com/haskell/haskell-language-server#readme)
+
+The call hierarchy plugin can review the code to determine where functions are called and how they relate to other functions.
+
+This plugin is useful when debugging and refactoring code because it allows you to see how different parts of the code are related. And it is more conducive for users to quickly understand their macro architecture in the face of strange code.
+
+## Demo
+
+![Call Hierarchy in Emacs](call-hierarchy-in-emacs.gif)
+
+![Call Hierarchy in VSCode](call-hierarchy-in-vscode.gif)
+
+## Prerequisite
+None. You can experience the whole feature without any setting.
+
+## Configuration
+Enabled by default. You can disable it in your editor settings whenever you like.
+
+```json
+{
+  "haskell.plugin.callHierarchy.globalOn": true
+}
+
+## Change log
+### 1.0.0.1
+- Support call hierarchy on type signatures.
+
+## Acknowledgments
+Supported by
+
+* [Google Summer of Code](https://summerofcode.withgoogle.com/)
+* Warm and timely help from mentors [@jneira](https://github.com/jneira) and [@pepeiborra](https://github.com/pepeiborra)

plugins/hls-call-hierarchy-plugin/call-hierarchy-in-emacs.gif

@@ -1,6 +1,6 @@
 cabal-version:      2.4
 name:               hls-call-hierarchy-plugin
-version:            1.0.0.0
+version:            1.0.0.1
 synopsis:           Call hierarchy plugin for Haskell Language Server
 license:            Apache-2.0
 license-file:       LICENSE

plugins/hls-call-hierarchy-plugin/call-hierarchy-in-vscode.gif

@@ -62,38 +62,43 @@ constructFromAst nfp pos =
     \case
       Nothing -> pure Nothing
       Just (HAR _ hf _ _ _) -> do
-        case listToMaybe $ pointCommand hf pos extract of
-          Just res -> pure $ Just $ mapMaybe (construct nfp) res
-          Nothing  -> pure Nothing
+        resolveIntoCallHierarchy hf pos nfp
+
+resolveIntoCallHierarchy :: Applicative f => HieASTs a -> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem])
+resolveIntoCallHierarchy hf pos nfp =
+  case listToMaybe $ pointCommand hf pos extract of
+    Just res -> pure $ Just $ mapMaybe (construct nfp hf) res
+    Nothing  -> pure Nothing
 
 extract :: HieAST a -> [(Identifier, S.Set ContextInfo, Span)]
 extract ast = let span = nodeSpan ast
                   infos = M.toList $ M.map identInfo (Compat.getNodeIds ast)
               in  [ (ident, contexts, span) | (ident, contexts) <- infos ]
 
 recFieldInfo, declInfo, valBindInfo, classTyDeclInfo,
-  useInfo, patternBindInfo :: S.Set ContextInfo -> Maybe ContextInfo
-recFieldInfo    ctxs = listToMaybe [ctx | ctx@RecField{}    <- S.toList ctxs]
-declInfo        ctxs = listToMaybe [ctx | ctx@Decl{}        <- S.toList ctxs]
-valBindInfo     ctxs = listToMaybe [ctx | ctx@ValBind{}     <- S.toList ctxs]
-classTyDeclInfo ctxs = listToMaybe [ctx | ctx@ClassTyDecl{} <- S.toList ctxs]
-useInfo         ctxs = listToMaybe [Use | Use               <- S.toList ctxs]
-patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- S.toList ctxs]
-
-construct :: NormalizedFilePath -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem
-construct nfp (ident, contexts, ssp)
+  useInfo, patternBindInfo, tyDeclInfo :: [ContextInfo] -> Maybe ContextInfo
+recFieldInfo    ctxs = listToMaybe [ctx    | ctx@RecField{}    <- ctxs]
+declInfo        ctxs = listToMaybe [ctx    | ctx@Decl{}        <- ctxs]
+valBindInfo     ctxs = listToMaybe [ctx    | ctx@ValBind{}     <- ctxs]
+classTyDeclInfo ctxs = listToMaybe [ctx    | ctx@ClassTyDecl{} <- ctxs]
+useInfo         ctxs = listToMaybe [Use    | Use               <- ctxs]
+patternBindInfo ctxs = listToMaybe [ctx    | ctx@PatternBind{} <- ctxs]
+tyDeclInfo      ctxs = listToMaybe [TyDecl | TyDecl            <- ctxs]
+
+construct :: NormalizedFilePath -> HieASTs a -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem
+construct nfp hf (ident, contexts, ssp)
   | isInternalIdentifier ident = Nothing
 
-  | Just (RecField RecFieldDecl _) <- recFieldInfo contexts
+  | Just (RecField RecFieldDecl _) <- recFieldInfo ctxList
     -- ignored type span
     = Just $ mkCallHierarchyItem' ident SkField ssp ssp
 
-  | Just ctx <- valBindInfo contexts
+  | Just ctx <- valBindInfo ctxList
     = Just $ case ctx of
         ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp
         _                -> mkCallHierarchyItem' ident skUnknown ssp ssp
 
-  | Just ctx <- declInfo contexts
+  | Just ctx <- declInfo ctxList
     = Just $ case ctx of
         Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface     (renderSpan span) ssp
         Decl ConDec   span -> mkCallHierarchyItem' ident SkConstructor   (renderSpan span) ssp
@@ -103,15 +108,18 @@ construct nfp (ident, contexts, ssp)
         Decl SynDec   span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp
         _ -> mkCallHierarchyItem' ident skUnknown ssp ssp
 
-  | Just (ClassTyDecl span) <- classTyDeclInfo contexts
+  | Just (ClassTyDecl span) <- classTyDeclInfo ctxList
     = Just $ mkCallHierarchyItem' ident SkMethod (renderSpan span) ssp
 
-  | Just (PatternBind _ _ span) <- patternBindInfo contexts
+  | Just (PatternBind _ _ span) <- patternBindInfo ctxList
     = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp
 
-  | Just Use <- useInfo contexts
+  | Just Use <- useInfo ctxList
     = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp
 
+  | Just _ <- tyDeclInfo ctxList
+    = renderTyDecl
+
   | otherwise = Nothing
   where
     renderSpan = \case Just span -> span
@@ -125,6 +133,16 @@ construct nfp (ident, contexts, ssp)
       Left _     -> False
       Right name -> isInternalName name
 
+    ctxList = S.toList contexts
+
+    renderTyDecl = case ident of
+      Left _ -> Nothing
+      Right name -> case getNameBindingInClass name ssp (getAsts hf) of
+        Nothing -> Nothing
+        Just sp -> case resolveIntoCallHierarchy hf (realSrcSpanToRange sp ^. L.start) nfp of
+          Just (Just items) -> listToMaybe items
+          _                 -> Nothing
+
 mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem
 mkCallHierarchyItem nfp ident kind span selSpan =
   CallHierarchyItem

plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal

@@ -25,11 +25,11 @@ plugin = descriptor "callHierarchy"
 
 main :: IO ()
 main = defaultTestRunner $
-         testGroup "Call Hierarchy"
-           [ prepareCallHierarchyTests
-           , incomingCallsTests
-           , outgoingCallsTests
-           ]
+  testGroup "Call Hierarchy"
+    [ prepareCallHierarchyTests
+    , incomingCallsTests
+    , outgoingCallsTests
+    ]
 
 prepareCallHierarchyTests :: TestTree
 prepareCallHierarchyTests =
@@ -164,6 +164,20 @@ prepareCallHierarchyTests =
           selRange = mkRange 1 13 1 14
           expected = mkCallHierarchyItemC "A" SkConstructor range selRange
       oneCaseWithCreate contents 1 13 expected
+  , testGroup "type signature"
+      [ testCase "next line" $ do
+          let contents = T.unlines ["a::Int", "a=3"]
+              range = mkRange 1 0 1 3
+              selRange = mkRange 1 0 1 1
+              expected = mkCallHierarchyItemV "a" SkFunction range selRange
+          oneCaseWithCreate contents 0 0 expected
+      , testCase "multi functions" $ do
+          let contents = T.unlines [ "a,b::Int", "a=3", "b=4"]
+              range = mkRange 2 0 2 3
+              selRange = mkRange 2 0 2 1
+              expected = mkCallHierarchyItemV "b" SkFunction range selRange
+          oneCaseWithCreate contents 0 2 expected
+      ]
   ]
 
 incomingCallsTests :: TestTree