Skip to content

Commit c2bd211

Browse files
July541July541
committed
Refresh hiedb before incoming/outgoing calls
1 parent 61d9df9 commit c2bd211

File tree

7 files changed

+73
-80
lines changed

7 files changed

+73
-80
lines changed

‎.github/workflows/test.yml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -201,6 +201,6 @@ jobs:
201201
name: Test hls-refine-imports-plugin test suite
202202
run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun"
203203

204-
- if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc }}
204+
- if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}}
205205
name: Test hls-call-hierarchy-plugin test suite
206206
run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun"

‎cabal.project‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -88,17 +88,17 @@ allow-newer:
8888
source-repository-package
8989
type: git
9090
location: https://github.com/haskell/lsp.git
91-
tag: e96383ab19534128f12acc70a69fbc15d4f298cc
91+
tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96
9292
subdir: lsp-types
9393

9494
source-repository-package
9595
type: git
9696
location: https://github.com/haskell/lsp.git
97-
tag: e96383ab19534128f12acc70a69fbc15d4f298cc
97+
tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96
9898
subdir: lsp-test
9999

100100
source-repository-package
101101
type: git
102102
location: https://github.com/haskell/lsp.git
103-
tag: e96383ab19534128f12acc70a69fbc15d4f298cc
103+
tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96
104104
subdir: lsp

‎plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,9 +22,11 @@ library
2222
build-depends:
2323
, aeson
2424
, base >=4.12 && <5
25+
, bytestring
2526
, containers
2627
, extra
2728
, ghc
29+
, ghc-api-compat
2830
, ghcide >=1.2 && <1.5
2931
, hiedb
3032
, hls-plugin-api ^>=1.1

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
module Ide.Plugin.CallHierarchy where
1+
module Ide.Plugin.CallHierarchy (descriptor) where
22

33
import Development.IDE
44
import qualified Ide.Plugin.CallHierarchy.Internal as X

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

Lines changed: 53 additions & 58 deletions
Original file line numberDiff line numberDiff line change
@@ -5,39 +5,42 @@
55
{-# LANGUAGE RecordWildCards #-}
66
{-# LANGUAGE ScopedTypeVariables #-}
77
{-# LANGUAGE StandaloneDeriving #-}
8+
89
module Ide.Plugin.CallHierarchy.Internal (
910
prepareCallHierarchy
1011
, incomingCalls
1112
, outgoingCalls
1213
) where
1314

15+
import Control.Concurrent
1416
import Control.Lens ((^.))
1517
import Control.Monad.Extra
1618
import Control.Monad.IO.Class
1719
import Data.Aeson as A
20+
import qualified Data.ByteString as BS
1821
import qualified Data.HashMap.Strict as HM
1922
import Data.List (groupBy, sortBy)
2023
import qualified Data.Map as M
2124
import Data.Maybe
2225
import qualified Data.Set as S
2326
import qualified Data.Text as T
27+
import qualified Data.Text.Encoding as T
2428
import Data.Tuple.Extra
2529
import Development.IDE
30+
import Development.IDE.Core.Compile
2631
import Development.IDE.Core.Shake
2732
import Development.IDE.GHC.Compat
2833
import Development.IDE.Spans.AtPoint
29-
import Development.IDE.Spans.Common
3034
import HieDb (Symbol (Symbol))
3135
import qualified Ide.Plugin.CallHierarchy.Query as Q
3236
import Ide.Plugin.CallHierarchy.Types
3337
import Ide.Types
3438
import Language.LSP.Types
3539
import qualified Language.LSP.Types.Lens as L
36-
import Maybes
3740
import Name
38-
import SrcLoc
3941
import Text.Read (readMaybe)
4042

43+
-- | Render prepare call hierarchy request.
4144
prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy
4245
prepareCallHierarchy state pluginId param
4346
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri =
@@ -92,11 +95,11 @@ construct nfp (ident, contexts, ssp)
9295

9396
| Just ctx <- declInfo contexts
9497
= Just $ case ctx of
95-
Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp
96-
Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp
97-
Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp
98-
Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp
99-
Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp
98+
Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp
99+
Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp
100+
Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp
101+
Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp
102+
Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp
100103
Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp
101104
_ -> mkCallHierarchyItem' ident skUnknown ssp ssp
102105

@@ -125,7 +128,7 @@ construct nfp (ident, contexts, ssp)
125128
mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem
126129
mkCallHierarchyItem nfp ident kind span selSpan =
127130
CallHierarchyItem
128-
(T.pack $ identifierName ident)
131+
(T.pack $ optimize $ identifierName ident)
129132
kind
130133
Nothing
131134
(Just $ T.pack $ identifierToDetail ident)
@@ -144,12 +147,16 @@ mkCallHierarchyItem nfp ident kind span selSpan =
144147
Left modName -> moduleNameString modName
145148
Right name -> occNameString $ nameOccName name
146149

150+
optimize :: String -> String
151+
optimize name -- optimize display for DuplicateRecordFields
152+
| "$sel:" == take 5 name = drop 5 name
153+
| otherwise = name
154+
147155
mkSymbol :: Identifier -> Maybe Symbol
148156
mkSymbol = \case
149157
Left _ -> Nothing
150158
Right name -> Just $ Symbol (occName name) (nameModule name)
151159

152-
153160
----------------------------------------------------------------------
154161
-------------- Incoming calls and outgoing calls ---------------------
155162
----------------------------------------------------------------------
@@ -158,11 +165,12 @@ deriving instance Ord SymbolKind
158165
deriving instance Ord SymbolTag
159166
deriving instance Ord CallHierarchyItem
160167

168+
-- | Render incoming calls request.
161169
incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls
162170
incomingCalls state pluginId param = do
163171
liftIO $ runAction "CallHierarchy.incomingCalls" state $
164172
queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall
165-
foiIncomingCalls mergeIncomingCalls >>=
173+
mergeIncomingCalls >>=
166174
\case
167175
Just x -> pure $ Right $ Just $ List x
168176
Nothing -> pure $ Left $ responseError "CallHierarchy: IncomingCalls internal error"
@@ -178,11 +186,12 @@ incomingCalls state pluginId param = do
178186
merge calls = let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls
179187
in CallHierarchyIncomingCall (head calls ^. L.from) (List ranges)
180188

189+
-- Render outgoing calls request.
181190
outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls
182191
outgoingCalls state pluginId param = do
183192
liftIO $ runAction "CallHierarchy.outgoingCalls" state $
184193
queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall
185-
foiOutgoingCalls mergeOutgoingCalls >>=
194+
mergeOutgoingCalls >>=
186195
\case
187196
Just x -> pure $ Right $ Just $ List x
188197
Nothing -> pure $ Left $ responseError "CallHierarchy: OutgoingCalls internal error"
@@ -223,21 +232,20 @@ queryCalls :: (Show a)
223232
=> CallHierarchyItem
224233
-> (HieDb -> Symbol -> IO [Vertex])
225234
-> (Vertex -> Action (Maybe a))
226-
-> (NormalizedFilePath -> Position -> Action (Maybe [a]))
227235
-> ([a] -> [a])
228236
-> Action (Maybe [a])
229-
queryCalls item queryFunc makeFunc foiCalls merge
237+
queryCalls item queryFunc makeFunc merge
230238
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
239+
refreshHieDb
240+
231241
ShakeExtras{hiedb} <- getShakeExtras
232242
maySymbol <- getSymbol nfp
233243
case maySymbol of
234244
Nothing -> error "CallHierarchy.Impossible"
235245
Just symbol -> do
236246
vs <- liftIO $ queryFunc hiedb symbol
237-
nonFOIItems <- mapM makeFunc vs
238-
foiRes <- foiCalls nfp pos
239-
let nonFOIRes = Just $ catMaybes nonFOIItems
240-
pure $ merge <$> (nonFOIRes <> foiRes)
247+
items <- Just . catMaybes <$> mapM makeFunc vs
248+
pure $ merge <$> items
241249
| otherwise = pure Nothing
242250
where
243251
uri = item ^. L.uri
@@ -266,43 +274,30 @@ queryCalls item queryFunc makeFunc foiCalls merge
266274
Just res -> pure res
267275
Nothing -> pure Nothing
268276

269-
foiIncomingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyIncomingCall])
270-
foiIncomingCalls nfp pos =
271-
use GetHieAst nfp >>=
272-
\case
273-
Nothing -> pure Nothing
274-
Just (HAR _ hf _ _ _) -> do
275-
case listToMaybe $ pointCommand hf pos id of
276-
Nothing -> pure Nothing
277-
Just ast -> do
278-
fs <- HM.keys <$> getFilesOfInterestUntracked
279-
Just . concatMap (`callers` ast) <$> mapMaybeM (use GetHieAst) fs
280-
where
281-
callers :: HieAstResult -> HieAST a -> [CallHierarchyIncomingCall]
282-
callers (HAR _ hf _ _ _) ast = mkIncomingCalls $ filter (sameAst ast) $ M.elems (getAsts hf)
283-
284-
sameAst :: HieAST a -> HieAST b -> Bool
285-
sameAst ast1 ast2 = (M.keys . nodeIdentifiers . nodeInfo) ast1
286-
== (M.keys . nodeIdentifiers . nodeInfo) ast2
287-
288-
mkIncomingCalls asts = let infos = concatMap extract asts
289-
items = mapMaybe (construct nfp) infos
290-
in map (\item ->
291-
CallHierarchyIncomingCall item
292-
(List [item ^. L.selectionRange])) items
293-
294-
foiOutgoingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyOutgoingCall])
295-
foiOutgoingCalls nfp pos =
296-
use GetHieAst nfp >>=
297-
\case
298-
Nothing -> pure Nothing
299-
Just (HAR _ hf _ _ _) -> do
300-
case listToMaybe $ pointCommand hf pos nodeChildren of
301-
Nothing -> pure Nothing
302-
Just children -> pure $ Just $ mkOutgoingCalls children
303-
where
304-
mkOutgoingCalls asts = let infos = concatMap extract asts
305-
items = mapMaybe (construct nfp) infos
306-
in map (\item ->
307-
CallHierarchyOutgoingCall item
308-
(List [item ^. L.selectionRange]) ) items
277+
-- Write modified foi files before queries.
278+
refreshHieDb :: Action ()
279+
refreshHieDb = do
280+
fs <- HM.keys . HM.filter (/= OnDisk) <$> getFilesOfInterestUntracked
281+
forM_ fs (\f -> do
282+
tmr <- use_ TypeCheck f
283+
hsc <- hscEnv <$> use_ GhcSession f
284+
(_, masts) <- liftIO $ generateHieAsts hsc tmr
285+
se <- getShakeExtras
286+
case masts of
287+
Nothing -> pure ()
288+
Just asts -> do
289+
source <- getSourceFileSource f
290+
let exports = tcg_exports $ tmrTypechecked tmr
291+
msum = tmrModSummary tmr
292+
liftIO $ writeAndIndexHieFile hsc se msum f exports asts source
293+
pure ()
294+
)
295+
liftIO $ threadDelay 100000 -- delay 0.1 sec to make more exact results.
296+
297+
-- Copy unexport function form `ghcide/src/Development/IDE/Core/Rules.hs`
298+
getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
299+
getSourceFileSource nfp = do
300+
(_, msource) <- getFileContents nfp
301+
case msource of
302+
Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp)
303+
Just source -> pure $ T.encodeUtf8 source

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

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,13 +2,17 @@
22
{-# LANGUAGE OverloadedStrings #-}
33
{-# LANGUAGE RecordWildCards #-}
44
{-# LANGUAGE ViewPatterns #-}
5-
module Ide.Plugin.CallHierarchy.Query where
5+
6+
module Ide.Plugin.CallHierarchy.Query (
7+
incomingCalls
8+
, outgoingCalls
9+
, getSymbolPosition
10+
) where
611

712
import Database.SQLite.Simple
813
import GHC
914
import HieDb (HieDb (getConn), Symbol (..),
1015
toNsChar)
11-
import qualified HieDb
1216
import Ide.Plugin.CallHierarchy.Types
1317
import Module
1418
import Name

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

Lines changed: 7 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -2,25 +2,24 @@
22
{-# LANGUAGE OverloadedStrings #-}
33
{-# LANGUAGE StandaloneDeriving #-}
44
{-# LANGUAGE TupleSections #-}
5-
module Main where
5+
6+
module Main (main) where
67

78
import Control.Lens (set, (^.))
89
import Control.Monad.Extra
910
import Data.Aeson
11+
import Data.Functor ((<&>))
1012
import Data.List (sort)
13+
import qualified Data.Map as M
1114
import qualified Data.Text as T
1215
import Ide.Plugin.CallHierarchy
1316
import qualified Language.LSP.Test as Test
1417
import qualified Language.LSP.Types.Lens as L
18+
import System.Directory.Extra
1519
import System.FilePath
1620
import qualified System.IO.Extra
1721
import Test.Hls
1822

19-
import Control.Concurrent.Extra
20-
import Data.Functor ((<&>))
21-
import qualified Data.Map as M
22-
import System.Directory.Extra
23-
2423
plugin :: PluginDescriptor IdeState
2524
plugin = descriptor "callHierarchy"
2625

@@ -177,7 +176,6 @@ incomingCallsTests =
177176
doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]
178177
[item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0)
179178
let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])]
180-
liftIO delay -- A hack, ensure HieDb be initilized.
181179
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>=
182180
\case
183181
[item] -> do
@@ -283,7 +281,6 @@ outgoingCallsTests =
283281
doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]
284282
[item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1)
285283
let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])]
286-
liftIO delay
287284
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>=
288285
\case
289286
[item] -> do
@@ -391,7 +388,7 @@ incomingCallTestCase contents queryX queryY positions ranges = withTempDir $ \di
391388
)
392389
(zip positions ranges)
393390
let expected = map mkCallHierarchyIncomingCall items
394-
liftIO delay
391+
-- liftIO delay
395392
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
396393
\case
397394
[item] -> do
@@ -411,7 +408,7 @@ incomingCallMultiFileTestCase filepath queryX queryY mp =
411408
<&> map (, range)
412409
) pr) mp
413410
let expected = map mkCallHierarchyIncomingCall items
414-
liftIO delay
411+
-- liftIO delay
415412
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
416413
\case
417414
[item] -> do
@@ -430,7 +427,6 @@ outgoingCallTestCase contents queryX queryY positions ranges = withTempDir $ \di
430427
)
431428
(zip positions ranges)
432429
let expected = map mkCallHierarchyOutgoingCall items
433-
liftIO delay
434430
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
435431
\case
436432
[item] -> do
@@ -450,7 +446,6 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp =
450446
<&> map (, range)
451447
) pr) mp
452448
let expected = map mkCallHierarchyOutgoingCall items
453-
liftIO delay
454449
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
455450
\case
456451
[item] -> do
@@ -503,6 +498,3 @@ withTempDir :: (FilePath -> IO a) -> IO a
503498
withTempDir f = System.IO.Extra.withTempDir $ \dir -> do
504499
dir' <- canonicalizePath dir
505500
f dir'
506-
507-
delay :: IO ()
508-
delay = threadDelay 1000000

0 commit comments

Comments
 (0)