diff --git a/plugins/hls-call-hierarchy-plugin/README.md b/plugins/hls-call-hierarchy-plugin/README.md index 619cf2a9b0..752bf7e9f1 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 81f07412fe..d2c604e9d0 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 5deb5da10c..5e0ab2024f 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 0c10d95ca0..c279cebbe3 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 b87665f3d8..24b245e8d6 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