Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Improve incoming call for typeclass and type family instance #2162

Merged
merged 3 commits into from Sep 6, 2021
Merged

Improve incoming call for typeclass and type family instance #2162

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
25b8201
Correct instance for incoming
July541 Sep 6, 2021
b43ed7c
Get rid of constant delay
July541 Sep 6, 2021
31a25f7
Merge branch 'master' into call-hierarchy-goto-instance
July541 Sep 6, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
9 changes: 7 additions & 2 deletions plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs
View file
Open in desktop
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
5 changes: 2 additions & 3 deletions plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs
View file
Open in desktop
Expand Up @@ -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 = ?) "
Expand Down
12 changes: 11 additions & 1 deletion plugins/hls-call-hierarchy-plugin/test/Main.hs
View file
Open in desktop
Expand Up @@ -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
Expand Down