Support call hierarchy on pattern matching (#2129)

* Support call hierarchy on pattern matching * Make result satisfied with the way VSCode processes data * Version bump
haskell · Aug 27, 2021 · 6fa3e64 · 6fa3e64
1 parent 32cd57d
commit 6fa3e64
Show file tree

Hide file tree

Showing 5 changed files with 40 additions and 12 deletions.
diff --git a/plugins/hls-call-hierarchy-plugin/README.md b/plugins/hls-call-hierarchy-plugin/README.md
@@ -20,6 +20,7 @@ Enabled by default. You can disable it in your editor settings whenever you like
 {
   "haskell.plugin.callHierarchy.globalOn": true
 }
+```
 
 ## Change log
 ### 1.0.0.1

diff --git 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.1
+version:            1.0.0.2
 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
@@ -47,7 +47,7 @@ prepareCallHierarchy state pluginId param
     liftIO (runAction "CallHierarchy.prepareHierarchy" state (prepareCallHierarchyItem nfp pos)) >>=
       \case
         Just items -> pure $ Right $ Just $ List items
-        Nothing    -> pure $ Left $ responseError "Call Hierarchy: No result"
+        Nothing    -> pure $ Right Nothing
   | otherwise = pure $ Left $ responseError $ T.pack $ "Call Hierarchy: uriToNormalizedFilePath failed for: " <> show uri
   where
     uri = param ^. (L.textDocument . L.uri)
@@ -67,23 +67,28 @@ constructFromAst nfp pos =
 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
+    Nothing    -> pure Nothing
+    Just infos ->
+      case mapMaybe (construct nfp hf) infos of
+        []  -> pure Nothing
+        res -> pure $ Just res
 
 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, 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]
+  useInfo, patternBindInfo, tyDeclInfo, matchBindInfo
+    :: [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]
+matchBindInfo   ctxs = listToMaybe [MatchBind | MatchBind         <- ctxs]
 
 construct :: NormalizedFilePath -> HieASTs a -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem
 construct nfp hf (ident, contexts, ssp)
@@ -93,6 +98,9 @@ construct nfp hf (ident, contexts, ssp)
     -- ignored type span
     = Just $ mkCallHierarchyItem' ident SkField ssp ssp
 
+  | isJust (matchBindInfo ctxList) && isNothing (valBindInfo ctxList)
+    = Just $ mkCallHierarchyItem' ident SkFunction ssp ssp
+
   | Just ctx <- valBindInfo ctxList
     = Just $ case ctx of
         ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp

diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs
@@ -35,6 +35,7 @@ instance FromRow Vertex where
                    <*> field <*> field <*> field
                    <*> field <*> field <*> field
                    <*> field <*> field
+
 data SymbolPosition = SymbolPosition {
   psl :: Int
 , psc :: Int

diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs
@@ -178,6 +178,15 @@ prepareCallHierarchyTests =
               expected = mkCallHierarchyItemV "b" SkFunction range selRange
           oneCaseWithCreate contents 0 2 expected
       ]
+  , testCase "multi pattern" $ do
+      let contents = T.unlines
+            [ "f (Just _) = ()"
+            , "f Nothing = ()"
+            ]
+          range = mkRange 1 0 1 1
+          selRange = mkRange 1 0 1 1
+          expected = mkCallHierarchyItemV "f" SkFunction range selRange
+      oneCaseWithCreate contents 1 0 expected
   ]
 
 incomingCallsTests :: TestTree
@@ -263,6 +272,15 @@ incomingCallsTests =
             positions = [(1, 5)]
             ranges = [mkRange 1 13 1 14]
         incomingCallTestCase contents 1 13 positions ranges
+    , testCase "multi pattern" $ do
+        let contents = T.unlines
+                [ "f 1 = 1"
+                , "f 2 = 2"
+                , "g = f"
+                ]
+            positions = [(2, 0)]
+            ranges = [mkRange 2 4 2 5]
+        incomingCallTestCase contents 1 0 positions ranges
     ]
   , testGroup "multi file"
     [ testCase "1" $ do