diff --git a/plugins/hls-call-hierarchy-plugin/README.md b/plugins/hls-call-hierarchy-plugin/README.md
index 619cf2a9b0559f13a2be4efee8b7ed8e070b1a24..752bf7e9f163c46d453a3b3c456dee186a1622d4 100644
--- 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
index 81f07412feb5dd48aaee9d69da26bd8f64e95334..d2c604e9d0e54f123c8b4112f21d98f4596313dd 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.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
index 5deb5da10c7ea9ac07b106ae102e35f594988ad1..5e0ab2024f1919c62afc9519629173f64be15f1e 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
@@ -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,8 +67,11 @@ 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
@@ -76,14 +79,16 @@ extract ast = let span = nodeSpan 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
index 0c10d95ca0cfdb3f15f756ba506d62a87329bb39..c279cebbe30504a2257ccf7ddfd17792ef9f7930 100644
--- 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
index b87665f3d89ea1ae68d01d2d4405559b88a755ce..24b245e8d68fb7d0bf1b8829797695a7ff31e5c8 100644
--- 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