Improve incoming call for typeclass and type family instance (#2162)

* Correct instance for incoming

* Get rid of constant delay

Author: July541

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs

@@ -12,7 +12,6 @@ module Ide.Plugin.CallHierarchy.Internal (
 , 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.Compile
 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
@@ -318,7 +318,12 @@ refreshHieDb = do
                 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

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs

@@ -21,11 +21,10 @@ incomingCalls (getConn -> conn) symbol = do
     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 = ?) "

plugins/hls-call-hierarchy-plugin/test/Main.hs

@@ -254,14 +254,24 @@ incomingCallsTests =
               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
               [ "{-# LANGUAGE TypeFamilies #-}"
               , "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