Skip to content

Commit 8dfcaf8

Browse files
soulomoonsoulomoon
authored
Semantic tokens: add module name support and improve performance and accuracy by traversing the hieAst along with source code (#3958)
fix #3957 Things have been done: 1. Switch `Name` to `Identifier` in the implementation and add `ModuleName` to the `HsSemanticTokenType` 2. Strip ``` ` ` ``` and `()`, and split out qualified names. e.g.``` `Preclude.length` ``` to ```Preclude.``` `length` 3. add tokenizer to walk ast with the souce rope to get more accurate result and faster. Should fix #3983. 4. add type sig to semanticConfig's TH result
1 parent 06ec06c commit 8dfcaf8

30 files changed

+666
-183
lines changed

‎haskell-language-server.cabal‎

Lines changed: 27 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -140,7 +140,7 @@ flag cabal
140140

141141
common cabal
142142
if flag(cabal)
143-
build-depends: hls-cabal-plugin
143+
build-depends: hls-cabal-plugin
144144
cpp-options: -Dhls_cabal
145145

146146
library hls-cabal-plugin
@@ -223,7 +223,7 @@ flag class
223223

224224
common class
225225
if flag(class)
226-
build-depends: hls-class-plugin
226+
build-depends: hls-class-plugin
227227
cpp-options: -Dhls_class
228228

229229
library hls-class-plugin
@@ -287,7 +287,7 @@ flag callHierarchy
287287

288288
common callHierarchy
289289
if flag(callHierarchy)
290-
build-depends: hls-call-hierarchy-plugin
290+
build-depends: hls-call-hierarchy-plugin
291291
cpp-options: -Dhls_callHierarchy
292292

293293
library hls-call-hierarchy-plugin
@@ -348,7 +348,7 @@ flag eval
348348

349349
common eval
350350
if flag(eval)
351-
build-depends: hls-eval-plugin
351+
build-depends: hls-eval-plugin
352352
cpp-options: -Dhls_eval
353353

354354
library hls-eval-plugin
@@ -429,7 +429,7 @@ test-suite hls-eval-plugin-tests
429429

430430
common importLens
431431
if flag(importLens)
432-
build-depends: hls-explicit-imports-plugin
432+
build-depends: hls-explicit-imports-plugin
433433
cpp-options: -Dhls_importLens
434434

435435
flag importLens
@@ -494,7 +494,7 @@ flag rename
494494

495495
common rename
496496
if flag(rename)
497-
build-depends: hls-rename-plugin
497+
build-depends: hls-rename-plugin
498498
cpp-options: -Dhls_rename
499499

500500
library hls-rename-plugin
@@ -550,7 +550,7 @@ flag retrie
550550

551551
common retrie
552552
if flag(retrie)
553-
build-depends: hls-retrie-plugin
553+
build-depends: hls-retrie-plugin
554554
cpp-options: -Dhls_retrie
555555

556556
library hls-retrie-plugin
@@ -615,7 +615,7 @@ flag hlint
615615

616616
common hlint
617617
if flag(hlint) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))
618-
build-depends: hls-hlint-plugin
618+
build-depends: hls-hlint-plugin
619619
cpp-options: -Dhls_hlint
620620

621621
library hls-hlint-plugin
@@ -695,7 +695,7 @@ flag stan
695695

696696
common stan
697697
if flag(stan) && (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0))
698-
build-depends: hls-stan-plugin
698+
build-depends: hls-stan-plugin
699699
cpp-options: -Dhls_stan
700700

701701
library hls-stan-plugin
@@ -769,7 +769,7 @@ flag moduleName
769769

770770
common moduleName
771771
if flag(moduleName)
772-
build-depends: hls-module-name-plugin
772+
build-depends: hls-module-name-plugin
773773
cpp-options: -Dhls_moduleName
774774

775775
library hls-module-name-plugin
@@ -814,7 +814,7 @@ flag pragmas
814814

815815
common pragmas
816816
if flag(pragmas)
817-
build-depends: hls-pragmas-plugin
817+
build-depends: hls-pragmas-plugin
818818
cpp-options: -Dhls_pragmas
819819

820820
library hls-pragmas-plugin
@@ -862,7 +862,7 @@ flag splice
862862

863863
common splice
864864
if flag(splice)
865-
build-depends: hls-splice-plugin
865+
build-depends: hls-splice-plugin
866866
cpp-options: -Dhls_splice
867867

868868
library hls-splice-plugin
@@ -1040,7 +1040,7 @@ flag codeRange
10401040

10411041
common codeRange
10421042
if flag(codeRange)
1043-
build-depends: hls-code-range-plugin
1043+
build-depends: hls-code-range-plugin
10441044
cpp-options: -Dhls_codeRange
10451045

10461046
library hls-code-range-plugin
@@ -1100,7 +1100,7 @@ flag changeTypeSignature
11001100

11011101
common changeTypeSignature
11021102
if flag(changeTypeSignature)
1103-
build-depends: hls-change-type-signature-plugin
1103+
build-depends: hls-change-type-signature-plugin
11041104
cpp-options: -Dhls_changeTypeSignature
11051105

11061106
library hls-change-type-signature-plugin
@@ -1160,7 +1160,7 @@ flag gadt
11601160

11611161
common gadt
11621162
if flag(gadt)
1163-
build-depends: hls-gadt-plugin
1163+
build-depends: hls-gadt-plugin
11641164
cpp-options: -Dhls_gadt
11651165

11661166
library hls-gadt-plugin
@@ -1213,7 +1213,7 @@ flag explicitFixity
12131213

12141214
common explicitFixity
12151215
if flag(explicitFixity)
1216-
build-depends: hls-explicit-fixity-plugin
1216+
build-depends: hls-explicit-fixity-plugin
12171217
cpp-options: -DexplicitFixity
12181218

12191219
library hls-explicit-fixity-plugin
@@ -1260,7 +1260,7 @@ flag explicitFields
12601260

12611261
common explicitFields
12621262
if flag(explicitFields)
1263-
build-depends: hls-explicit-record-fields-plugin
1263+
build-depends: hls-explicit-record-fields-plugin
12641264
cpp-options: -DexplicitFields
12651265

12661266
library hls-explicit-record-fields-plugin
@@ -1284,7 +1284,7 @@ library hls-explicit-record-fields-plugin
12841284
if flag(pedantic)
12851285
ghc-options: -Werror
12861286
-Wwarn=incomplete-record-updates
1287-
1287+
12881288
test-suite hls-explicit-record-fields-plugin-tests
12891289
import: warnings
12901290
default-language: Haskell2010
@@ -1309,7 +1309,7 @@ flag overloadedRecordDot
13091309

13101310
common overloadedRecordDot
13111311
if flag(overloadedRecordDot)
1312-
build-depends: hls-overloaded-record-dot-plugin
1312+
build-depends: hls-overloaded-record-dot-plugin
13131313
cpp-options: -Dhls_overloaded_record_dot
13141314

13151315
library hls-overloaded-record-dot-plugin
@@ -1356,7 +1356,7 @@ flag floskell
13561356

13571357
common floskell
13581358
if flag(floskell) && (impl(ghc < 9.7) || flag(ignore-plugins-ghc-bounds))
1359-
build-depends: hls-floskell-plugin
1359+
build-depends: hls-floskell-plugin
13601360
cpp-options: -Dhls_floskell
13611361

13621362
library hls-floskell-plugin
@@ -1398,7 +1398,7 @@ flag fourmolu
13981398

13991399
common fourmolu
14001400
if flag(fourmolu)
1401-
build-depends: hls-fourmolu-plugin
1401+
build-depends: hls-fourmolu-plugin
14021402
cpp-options: -Dhls_fourmolu
14031403

14041404
library hls-fourmolu-plugin
@@ -1451,7 +1451,7 @@ flag ormolu
14511451

14521452
common ormolu
14531453
if flag(ormolu)
1454-
build-depends: hls-ormolu-plugin
1454+
build-depends: hls-ormolu-plugin
14551455
cpp-options: -Dhls_ormolu
14561456

14571457
library hls-ormolu-plugin
@@ -1504,7 +1504,7 @@ flag stylishHaskell
15041504

15051505
common stylishHaskell
15061506
if flag(stylishHaskell) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))
1507-
build-depends: hls-stylish-haskell-plugin
1507+
build-depends: hls-stylish-haskell-plugin
15081508
cpp-options: -Dhls_stylishHaskell
15091509

15101510
library hls-stylish-haskell-plugin
@@ -1549,7 +1549,7 @@ flag refactor
15491549

15501550
common refactor
15511551
if flag(refactor)
1552-
build-depends: hls-refactor-plugin
1552+
build-depends: hls-refactor-plugin
15531553
cpp-options: -Dhls_refactor
15541554

15551555
library hls-refactor-plugin
@@ -1665,7 +1665,7 @@ flag semanticTokens
16651665

16661666
common semanticTokens
16671667
if flag(semanticTokens)
1668-
build-depends: hls-semantic-tokens-plugin
1668+
build-depends: hls-semantic-tokens-plugin
16691669
cpp-options: -Dhls_semanticTokens
16701670

16711671
library hls-semantic-tokens-plugin
@@ -1679,6 +1679,7 @@ library hls-semantic-tokens-plugin
16791679
Ide.Plugin.SemanticTokens.Query
16801680
Ide.Plugin.SemanticTokens.SemanticConfig
16811681
Ide.Plugin.SemanticTokens.Utils
1682+
Ide.Plugin.SemanticTokens.Tokenize
16821683
Ide.Plugin.SemanticTokens.Internal
16831684

16841685
hs-source-dirs: plugins/hls-semantic-tokens-plugin/src
@@ -1688,6 +1689,7 @@ library hls-semantic-tokens-plugin
16881689
, containers
16891690
, extra
16901691
, hiedb
1692+
, text-rope
16911693
, mtl >= 2.2
16921694
, ghcide == 2.6.0.0
16931695
, hls-plugin-api == 2.6.0.0

‎hls-plugin-api/src/Ide/Plugin/Properties.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@
1515
module Ide.Plugin.Properties
1616
( PropertyType (..),
1717
ToHsType,
18+
NotElem,
1819
MetaData (..),
1920
PropertyKey (..),
2021
SPropertyKey (..),

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs‎

Lines changed: 23 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,9 @@
55
{-# LANGUAGE MultiParamTypeClasses #-}
66
{-# LANGUAGE NamedFieldPuns #-}
77
{-# LANGUAGE OverloadedLabels #-}
8+
{-# LANGUAGE OverloadedRecordDot #-}
89
{-# LANGUAGE OverloadedStrings #-}
10+
{-# LANGUAGE PolyKinds #-}
911
{-# LANGUAGE RecordWildCards #-}
1012
{-# LANGUAGE ScopedTypeVariables #-}
1113
{-# LANGUAGE TemplateHaskell #-}
@@ -21,8 +23,9 @@ import Control.Monad.Except (ExceptT, liftEither,
2123
withExceptT)
2224
import Control.Monad.Trans (lift)
2325
import Control.Monad.Trans.Except (runExceptT)
24-
import Data.Aeson (ToJSON (toJSON))
25-
import qualified Data.Map as Map
26+
import Data.Map.Strict (Map)
27+
import qualified Data.Map.Strict as M
28+
import qualified Data.Set as S
2629
import Development.IDE (Action,
2730
GetDocMap (GetDocMap),
2831
GetHieAst (GetHieAst),
@@ -34,7 +37,6 @@ import Development.IDE (Action,
3437
cmapWithPrio, define,
3538
fromNormalizedFilePath,
3639
hieKind, logPriority,
37-
usePropertyAction,
3840
use_)
3941
import Development.IDE.Core.PluginUtils (runActionE,
4042
useWithStaleE)
@@ -54,6 +56,7 @@ import Ide.Plugin.Error (PluginError (PluginIn
5456
import Ide.Plugin.SemanticTokens.Mappings
5557
import Ide.Plugin.SemanticTokens.Query
5658
import Ide.Plugin.SemanticTokens.SemanticConfig (mkSemanticConfigFunctions)
59+
import Ide.Plugin.SemanticTokens.Tokenize (hieAstSpanIdentifiers)
5760
import Ide.Plugin.SemanticTokens.Types
5861
import Ide.Types
5962
import qualified Language.LSP.Protocol.Lens as L
@@ -91,37 +94,36 @@ semanticTokensFull recorder state pid param = do
9194
-- Local names token type from 'hieAst'
9295
-- Name locations from 'hieAst'
9396
-- Visible names from 'tmrRenamed'
97+
9498
--
9599
-- It then combines this information to compute the semantic tokens for the file.
96100
getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()
97101
getSemanticTokensRule recorder =
98102
define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> handleError recorder $ do
99103
(HAR {..}) <- lift $ use_ GetHieAst nfp
100104
(DKMap {getTyThingMap}, _) <- lift $ useWithStale_ GetDocMap nfp
101-
ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst Map.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp
105+
ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp
102106
virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp
103107
-- get current location from the old ones
104-
let spanNamesMap = hieAstSpanNames virtualFile ast
105-
let names = nameSetElemsStable $ unionNameSets $ Map.elems spanNamesMap
106-
let localSemanticMap = mkLocalNameSemanticFromAst names (hieKindFunMasksKind hieKind) refMap
108+
let spanIdMap = M.filter (not . null) $ hieAstSpanIdentifiers virtualFile ast
109+
let names = S.unions $ M.elems spanIdMap
110+
let localSemanticMap = mkLocalIdSemanticFromAst names (hieKindFunMasksKind hieKind) refMap
107111
-- get imported name semantic map
108-
let importedNameSemanticMap = foldr (getTypeExclude localSemanticMap getTyThingMap) emptyNameEnv names
109-
let sMap = plusNameEnv_C (<>) importedNameSemanticMap localSemanticMap
110-
let rangeTokenType = extractSemanticTokensFromNames sMap spanNamesMap
112+
let importedIdSemanticMap = M.mapMaybe id
113+
$ M.fromSet (getTypeThing getTyThingMap) (names `S.difference` M.keysSet localSemanticMap)
114+
let sMap = M.unionWith (<>) importedIdSemanticMap localSemanticMap
115+
let rangeTokenType = extractSemanticTokensFromNames sMap spanIdMap
111116
return $ RangeHsSemanticTokenTypes rangeTokenType
112117
where
113-
-- ignore one already in discovered in local
114-
getTypeExclude ::
115-
NameEnv a ->
118+
getTypeThing ::
116119
NameEnv TyThing ->
117-
Name ->
118-
NameEnv HsSemanticTokenType ->
119-
NameEnv HsSemanticTokenType
120-
getTypeExclude localEnv tyThingMap n nameMap
121-
| n `elemNameEnv` localEnv = nameMap
122-
| otherwise =
123-
let tyThing = lookupNameEnv tyThingMap n
124-
in maybe nameMap (extendNameEnv nameMap n) (tyThing >>= tyThingSemantic)
120+
Identifier ->
121+
Maybe HsSemanticTokenType
122+
getTypeThing tyThingMap n
123+
| (Right name) <- n =
124+
let tyThing = lookupNameEnv tyThingMap name
125+
in (tyThing >>= tyThingSemantic)
126+
| otherwise = Nothing
125127

126128
-- | Persistent rule to ensure that semantic tokens doesn't block on startup
127129
persistentGetSemanticTokensRule :: Rules ()

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ module Ide.Plugin.SemanticTokens.Mappings where
1313

1414
import qualified Data.Array as A
1515
import Data.List.Extra (chunksOf, (!?))
16-
import qualified Data.Map as Map
16+
import qualified Data.Map.Strict as Map
1717
import Data.Maybe (mapMaybe)
1818
import qualified Data.Set as Set
1919
import Data.Text (Text, unpack)
@@ -45,6 +45,7 @@ toLspTokenType conf tk = case tk of
4545
TTypeFamily -> stTypeFamily conf
4646
TRecordField -> stRecordField conf
4747
TPatternSynonym -> stPatternSynonym conf
48+
TModule -> stModule conf
4849

4950
lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
5051
lspTokenReverseMap config
@@ -114,15 +115,15 @@ recoverFunMaskArray flattened = unflattened
114115
-- The recursion in 'unflattened' is crucial - it's what gives us sharing
115116
-- function indicator check.
116117
unflattened :: A.Array TypeIndex Bool
117-
unflattened = fmap (\flatTy -> go (fmap (unflattened A.!) flatTy)) flattened
118+
unflattened = fmap (go . fmap (unflattened A.!)) flattened
118119

119-
-- Unfold an 'HieType' whose subterms have already been unfolded
120+
-- Unfold an 'HieType' whose sub-terms have already been unfolded
120121
go :: HieType Bool -> Bool
121122
go (HTyVarTy _name) = False
122123
go (HAppTy _f _x) = False
123124
go (HLitTy _lit) = False
124125
go (HForAllTy ((_n, _k), _af) b) = b
125-
go (HFunTy _ _ _) = True
126+
go (HFunTy {}) = True
126127
go (HQualTy _constraint b) = b
127128
go (HCastTy b) = b
128129
go HCoercionTy = False

0 commit comments

Comments
 (0)