hls-call-hierarchy-plugin 1.0.0.0 → 1.0.1.0
raw patch · 5 files changed
+104/−31 lines, 5 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- hls-call-hierarchy-plugin.cabal +1/−1
- src/Ide/Plugin/CallHierarchy/Internal.hs +52/−21
- src/Ide/Plugin/CallHierarchy/Query.hs +2/−3
- src/Ide/Plugin/CallHierarchy/Types.hs +1/−0
- test/Main.hs +48/−6
hls-call-hierarchy-plugin.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server/tree/master/plugins/hls-call-hierarchy-plugin#readme>
src/Ide/Plugin/CallHierarchy/Internal.hs view
@@ -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
src/Ide/Plugin/CallHierarchy/Query.hs view
@@ -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 = ?) "
src/Ide/Plugin/CallHierarchy/Types.hs view
@@ -35,6 +35,7 @@ <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field+ data SymbolPosition = SymbolPosition { psl :: Int , psc :: Int
test/Main.hs view
@@ -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