diff --git a/hls-call-hierarchy-plugin.cabal b/hls-call-hierarchy-plugin.cabal --- a/hls-call-hierarchy-plugin.cabal +++ b/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 description: Please see the README on GitHub at diff --git a/src/Ide/Plugin/CallHierarchy/Internal.hs b/src/Ide/Plugin/CallHierarchy/Internal.hs --- a/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -12,7 +12,6 @@ , outgoingCalls ) where -import Control.Concurrent import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class @@ -31,6 +30,7 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat as Compat import Development.IDE.Spans.AtPoint +import GHC.Conc.Sync import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types @@ -47,7 +47,7 @@ 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) @@ -62,38 +62,51 @@ \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 + 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 :: 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] + 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 -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem -construct nfp (ident, contexts, ssp) +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 + | 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 _ -> 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 +116,18 @@ 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 +141,16 @@ 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 @@ -292,7 +318,12 @@ liftIO $ writeAndIndexHieFile hsc se msum f exports asts source pure () ) - liftIO $ threadDelay 100000 -- delay 0.1 sec to make more exact results. + ShakeExtras{hiedbWriter} <- getShakeExtras + liftIO $ atomically $ check $ indexPending hiedbWriter + where + check p = do + v <- readTVar p + if HM.null v then pure () else retry -- Copy unexport function form `ghcide/src/Development/IDE/Core/Rules.hs` getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString diff --git a/src/Ide/Plugin/CallHierarchy/Query.hs b/src/Ide/Plugin/CallHierarchy/Query.hs --- a/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/src/Ide/Plugin/CallHierarchy/Query.hs @@ -21,11 +21,10 @@ let (o, m, u) = parseSymbol symbol query conn (Query $ T.pack $ concat - [ "SELECT mods.mod, defs.occ, mods.hs_src, defs.sl, defs.sc, " - , "defs.el, defs.ec, refs.sl, refs.sc, refs.el, refs.ec " + [ "SELECT mods.mod, decls.occ, mods.hs_src, decls.sl, decls.sc, " + , "decls.el, decls.ec, refs.sl, refs.sc, refs.el, refs.ec " , "FROM refs " , "JOIN decls ON decls.hieFile = refs.hieFile " - , "JOIN defs ON defs.hieFile = decls.hieFile AND defs.occ = decls.occ " , "JOIN mods ON mods.hieFile = decls.hieFile " , "where " , "(refs.occ = ? AND refs.mod = ? AND refs.unit = ?) " diff --git a/src/Ide/Plugin/CallHierarchy/Types.hs b/src/Ide/Plugin/CallHierarchy/Types.hs --- a/src/Ide/Plugin/CallHierarchy/Types.hs +++ b/src/Ide/Plugin/CallHierarchy/Types.hs @@ -35,6 +35,7 @@ <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field + data SymbolPosition = SymbolPosition { psl :: Int , psc :: Int diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -25,11 +25,11 @@ main :: IO () main = defaultTestRunner $ - testGroup "Call Hierarchy" - [ prepareCallHierarchyTests - , incomingCallsTests - , outgoingCallsTests - ] + testGroup "Call Hierarchy" + [ prepareCallHierarchyTests + , incomingCallsTests + , outgoingCallsTests + ] prepareCallHierarchyTests :: TestTree prepareCallHierarchyTests = @@ -164,6 +164,29 @@ 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 + ] + , 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 @@ -231,6 +254,16 @@ positions = [(0, 6)] ranges = [mkRange 0 16 0 17] incomingCallTestCase contents 1 20 positions ranges + , testCase "goto typeclass instance" $ do + let contents = T.unlines + [ "class F a where f :: a" + , "instance F Bool where f = x" + , "instance F Int where f = 3" + , "x = True" + ] + positions = [(1, 22)] + ranges = [mkRange 1 26 1 27] + incomingCallTestCase contents 3 0 positions ranges ] , testCase "type family instance" $ do let contents = T.unlines @@ -238,7 +271,7 @@ , "type family A a" , "type instance A Int = Char" ] - positions = [(1, 12)] + positions = [(2, 14)] ranges = [mkRange 2 22 2 26] incomingCallTestCase contents 2 22 positions ranges , testCase "GADT" $ do @@ -249,6 +282,15 @@ 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