diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index b4dbe11eb3..f58005a4a6 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/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 diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index b1af283df8..411311106d 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/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 diff --git a/plugins/hls-call-hierarchy-plugin/README.md b/plugins/hls-call-hierarchy-plugin/README.md new file mode 100644 index 0000000000..619cf2a9b0 --- /dev/null +++ b/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) diff --git a/plugins/hls-call-hierarchy-plugin/call-hierarchy-in-emacs.gif b/plugins/hls-call-hierarchy-plugin/call-hierarchy-in-emacs.gif new file mode 100644 index 0000000000..545baf1555 Binary files /dev/null and b/plugins/hls-call-hierarchy-plugin/call-hierarchy-in-emacs.gif differ diff --git a/plugins/hls-call-hierarchy-plugin/call-hierarchy-in-vscode.gif b/plugins/hls-call-hierarchy-plugin/call-hierarchy-in-vscode.gif new file mode 100644 index 0000000000..2f4ddc64bd Binary files /dev/null and b/plugins/hls-call-hierarchy-plugin/call-hierarchy-in-vscode.gif differ diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 4eef2d7d89..81f07412fe 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -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 diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 4d43fc4120..5deb5da10c 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -62,9 +62,13 @@ 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 @@ -72,28 +76,29 @@ extract ast = let span = nodeSpan 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 diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index b543ffbb05..b87665f3d8 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -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