Supoort call hierarchy on type signatures

Author: July541

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.1.0
 synopsis:           Call hierarchy plugin for Haskell Language Server
 license:            Apache-2.0
 license-file:       LICENSE

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs

@@ -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/test/Main.hs

@@ -31,6 +31,13 @@ main = defaultTestRunner $
            , outgoingCallsTests
            ]
 
+main1 = defaultTestRunner  $ testCase "t1" $ do
+    let contents = T.unlines ["a :: Int", "f=3","a = 3"]
+        range = mkRange 2 0 2 5
+        selRange = mkRange 2 0 2 1
+        expected = mkCallHierarchyItemV "a" SkFunction range selRange
+    oneCaseWithCreate contents 0 0 expected
+
 prepareCallHierarchyTests :: TestTree
 prepareCallHierarchyTests =
   testGroup
@@ -164,6 +171,20 @@ prepareCallHierarchyTests =
           selRange = mkRange 1 13 1 14
           expected = mkCallHierarchyItemC "A" SkConstructor range selRange
       oneCaseWithCreate contents 1 13 expected
+  , testGroup "type singature"
+      [ 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