Skip to content

Commit a9f81ae

Browse files
MangoIVMangoIV
committed
[chore] try to fix most of the tests (9.10 and 9.12 still disagree)
1 parent a60ff82 commit a9f81ae

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

57 files changed

+1247
-598
lines changed

‎flake.nix

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,7 @@
6969
# Compiler toolchain
7070
hpkgs.ghc
7171
hpkgs.haskell-language-server
72+
pkgs.stack
7273
pkgs.haskellPackages.cabal-install
7374
# Dependencies needed to build some parts of Hackage
7475
gmp zlib ncurses

‎ghcide/src/Development/IDE/GHC/Compat/Core.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -633,11 +633,17 @@ instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where
633633
#if MIN_VERSION_ghc(9,11,0)
634634
instance HasSrcSpan (GHC.EpToken sym) where
635635
getLoc = GHC.getHasLoc
636+
instance HasSrcSpan (GHC.EpUniToken sym sym') where
637+
getLoc = GHC.getHasLoc
636638
#elif MIN_VERSION_ghc(9,9,0)
637639
instance HasSrcSpan (GHC.EpToken sym) where
638640
getLoc = GHC.getHasLoc . \case
639641
GHC.NoEpTok -> Nothing
640642
GHC.EpTok loc -> Just loc
643+
instance HasSrcSpan (GHC.EpUniToken sym sym') where
644+
getLoc = GHC.getHasLoc . \case
645+
GHC.NoEpUniTok -> Nothing
646+
GHC.EpUniTok loc _ -> Just loc
641647
#endif
642648

643649
#if MIN_VERSION_ghc(9,9,0)

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

Lines changed: 36 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -172,6 +172,14 @@ getSyntacticTokensRule recorder =
172172
astTraversalWith :: forall b r. Data b => b -> (forall a. Data a => a -> [r]) -> [r]
173173
astTraversalWith ast f = mconcat $ flip gmapQ ast \y -> f y <> astTraversalWith y f
174174

175+
{-# inline extractTyToTyToTy #-}
176+
extractTyToTyToTy :: forall f a. (Typeable f, Data a) => a -> Maybe (forall r. (forall b c. (Typeable b, Typeable c) => f b c -> r) -> r)
177+
extractTyToTyToTy node
178+
| App (App conRep argRep1) argRep2 <- typeOf node
179+
, Just HRefl <- eqTypeRep conRep (typeRep @f)
180+
= Just $ withTypeable argRep1 $ withTypeable argRep2 \k -> k node
181+
| otherwise = Nothing
182+
175183
{-# inline extractTyToTy #-}
176184
extractTyToTy :: forall f a. (Typeable f, Data a) => a -> Maybe (forall r. (forall b. Typeable b => f b -> r) -> r)
177185
extractTyToTy node
@@ -193,15 +201,38 @@ computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
193201
[
194202
#if MIN_VERSION_ghc(9,9,0)
195203
maybeToList $ mkFromLocatable TKeyword . (\k -> k \x k' -> k' x) =<< extractTyToTy @EpToken node,
204+
maybeToList $ mkFromLocatable TKeyword . (\k -> k \x k' -> k' x) =<< extractTyToTyToTy @EpUniToken node,
205+
do
206+
AnnContext {ac_darrow, ac_open, ac_close} <- maybeToList $ extractTy node
207+
let mkFromTok :: (Foldable f, HasSrcSpan a) => f a -> [(Range,HsSyntacticTokenType)]
208+
mkFromTok = foldMap (\tok -> maybeToList $ mkFromLocatable TKeyword \k -> k tok)
209+
mconcat
210+
#if MIN_VERSION_ghc(9,11,0)
211+
[ mkFromTok ac_darrow
212+
#else
213+
[ foldMap (\(_, loc) -> maybeToList $ mkFromLocatable TKeyword \k -> k loc) ac_darrow
214+
#endif
215+
, mkFromTok ac_open
216+
, mkFromTok ac_close
217+
],
196218
#endif
219+
197220
#if !MIN_VERSION_ghc(9,11,0)
198221
maybeToList $ mkFromLocatable TKeyword . (\x k -> k x) =<< extractTy @AddEpAnn node,
199222
do
200223
EpAnnImportDecl i p s q pkg a <- maybeToList $ extractTy @EpAnnImportDecl node
201-
202224
mapMaybe (mkFromLocatable TKeyword . (\x k -> k x)) $ catMaybes $ [Just i, s, q, pkg, a] <> foldMap (\(l, l') -> [Just l, Just l']) p,
203225
#endif
204-
maybeToList $ mkFromLocatable TComment . (\x k -> k x) =<< extractTy @LEpaComment node,
226+
maybeToList do
227+
comment <- extractTy @LEpaComment node
228+
#if !MIN_VERSION_ghc(9,7,0)
229+
-- NOTE: on ghc 9.6 there's an empty comment that is supposed to
230+
-- located the end of file
231+
case comment of
232+
L _ (EpaComment {ac_tok = EpaEofComment}) -> Nothing
233+
_ -> pure ()
234+
#endif
235+
mkFromLocatable TComment \k -> k comment,
205236
do
206237
L loc expr <- maybeToList $ extractTy @(LHsExpr GhcPs) node
207238
let fromSimple = maybeToList . flip mkFromLocatable \k -> k loc
@@ -213,8 +244,9 @@ computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
213244

214245
HsIsString {} -> TStringLit
215246
HsLit _ lit -> fromSimple case lit of
216-
HsChar {} -> TCharLit
217-
HsCharPrim {} -> TCharLit
247+
-- NOTE: unfortunately, lsp semantic tokens doesn't have a notion of char literals
248+
HsChar {} -> TStringLit
249+
HsCharPrim {} -> TStringLit
218250

219251
HsInt {} -> TNumberLit
220252
HsInteger {} -> TNumberLit

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

Lines changed: 28 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -12,28 +12,30 @@
1212
-- 4. Mapping from LSP tokens to SemanticTokenOriginal.
1313
module Ide.Plugin.SemanticTokens.Mappings where
1414

15-
import qualified Data.Array as A
15+
import qualified Data.Array as A
1616
import Data.Function
17-
import Data.List.Extra (chunksOf, (!?))
18-
import qualified Data.Map.Strict as Map
19-
import Data.Maybe (mapMaybe)
20-
import qualified Data.Set as Set
21-
import Data.Text (Text, unpack)
22-
import Development.IDE (HieKind (HieFresh, HieFromDisk))
17+
import Data.List.Extra (chunksOf, (!?))
18+
import qualified Data.Map.Strict as Map
19+
import Data.Maybe (mapMaybe)
20+
import qualified Data.Set as Set
21+
import Data.Text (Text, unpack)
22+
import Development.IDE (HieKind (HieFresh, HieFromDisk))
2323
import Development.IDE.GHC.Compat
24+
import Ide.Plugin.SemanticTokens.SemanticConfig (allHsTokenTypes)
2425
import GHC.Iface.Ext.Types (BindType (..),
2526
ContextInfo (..),
2627
DeclType (..), HieType (..),
2728
HieTypeFlat, TypeIndex)
2829
import Ide.Plugin.SemanticTokens.Types
29-
import Ide.Plugin.SemanticTokens.Utils (mkRange)
30-
import Language.LSP.Protocol.Types (LspEnum (knownValues),
31-
SemanticTokenAbsolute (SemanticTokenAbsolute),
32-
SemanticTokenRelative (SemanticTokenRelative),
33-
SemanticTokenTypes (..),
34-
SemanticTokens (SemanticTokens),
35-
UInt, absolutizeTokens)
36-
import Language.LSP.VFS hiding (line)
30+
import Ide.Plugin.SemanticTokens.Utils (mkRange)
31+
import Language.LSP.Protocol.Types (LspEnum (knownValues),
32+
SemanticTokenAbsolute (SemanticTokenAbsolute),
33+
SemanticTokenRelative (SemanticTokenRelative),
34+
SemanticTokenTypes (..),
35+
SemanticTokens (SemanticTokens),
36+
UInt,
37+
absolutizeTokens)
38+
import Language.LSP.VFS hiding (line)
3739

3840
-- * 0. Mapping name to Hs semantic token type.
3941

@@ -62,19 +64,16 @@ toLspTokenType conf tk = conf & case tk of
6264
HsSyntacticTokenType TKeyword -> stKeyword
6365
HsSyntacticTokenType TComment -> stComment
6466
HsSyntacticTokenType TStringLit -> stStringLit
65-
HsSyntacticTokenType TCharLit -> stCharLit
6667
HsSyntacticTokenType TNumberLit -> stNumberLit
6768
HsSyntacticTokenType TRecordSelector -> stRecordSelector
6869

69-
lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
70-
lspTokenReverseMap config
71-
| length xs /= Map.size mr = error "lspTokenReverseMap: token type mapping is not bijection"
72-
| otherwise = mr
73-
where xs = enumFrom minBound
74-
mr = Map.fromList $ map (\x -> (toLspTokenType config (HsSemanticTokenType x), x)) xs
70+
lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes [HsTokenType]
71+
lspTokenReverseMap config = mr
72+
where xs = allHsTokenTypes
73+
mr = Map.fromListWith (<>) $ map (\x -> (toLspTokenType config x, [x])) xs
7574

76-
lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
77-
lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)
75+
lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> [HsTokenType]
76+
lspTokenTypeHsTokenType cf tk = Map.findWithDefault [] tk (lspTokenReverseMap cf)
7877

7978
-- * 2. Mapping from GHC type and tyThing to semantic token type.
8079

@@ -190,20 +189,20 @@ infoTokenType x = case x of
190189
-- this function is used to recover the original tokens(with token in haskell token type zoon)
191190
-- from the lsp semantic tokens(with token in lsp token type zoon)
192191
-- the `SemanticTokensConfig` used should be a map with bijection property
193-
recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType]
192+
recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsTokenType]
194193
recoverSemanticTokens config v s = do
195194
tks <- recoverLspSemanticTokens v s
196-
return $ map (lspTokenHsToken config) tks
195+
return $ foldMap (lspTokenHsToken config) tks
197196

198197
-- | lspTokenHsToken
199198
-- for debug and test.
200199
-- use the `SemanticTokensConfig` to convert lsp token type to haskell token type
201200
-- the `SemanticTokensConfig` used should be a map with bijection property
202-
lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> SemanticTokenOriginal HsSemanticTokenType
201+
lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> [SemanticTokenOriginal HsTokenType]
203202
lspTokenHsToken config (SemanticTokenOriginal tokenType location name) =
204203
case lspTokenTypeHsTokenType config tokenType of
205-
Just t -> SemanticTokenOriginal t location name
206-
Nothing -> error "recoverSemanticTokens: unknown lsp token type"
204+
[] -> error "recoverSemanticTokens: unknown lsp token type"
205+
ts -> map (\t -> SemanticTokenOriginal t location name) ts
207206

208207
-- | recoverLspSemanticTokens
209208
-- for debug and test.

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

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,6 @@ docName tt = case tt of
4444
HsSyntacticTokenType TKeyword -> "keyword"
4545
HsSyntacticTokenType TStringLit -> "string literal"
4646
HsSyntacticTokenType TComment -> "comment"
47-
HsSyntacticTokenType TCharLit -> "char literal"
4847
HsSyntacticTokenType TNumberLit -> "number literal"
4948
HsSyntacticTokenType TRecordSelector -> "record selector"
5049

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

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -46,13 +46,12 @@ data HsSyntacticTokenType
4646
= TKeyword
4747
| TComment
4848
| TStringLit
49-
| TCharLit
5049
| TNumberLit
5150
| TRecordSelector
5251
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic, Lift)
5352

54-
data HsTokenType =
55-
HsSyntacticTokenType HsSyntacticTokenType
53+
data HsTokenType
54+
= HsSyntacticTokenType HsSyntacticTokenType
5655
| HsSemanticTokenType HsSemanticTokenType
5756
deriving stock (Eq, Ord, Show, Generic, Lift)
5857

‎plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs

Lines changed: 29 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -162,8 +162,12 @@ semanticTokensConfigTest =
162162
void waitForBuildQueue
163163
result1 <- docLspSemanticTokensString doc
164164
liftIO $ unlines (map show result1) @?=
165-
T.unlines (["1:8-13 SemanticTokenTypes_Namespace \"Hello\"" | compilerVersion >= Version [9, 10] []]
166-
++ ["2:1-3 SemanticTokenTypes_Variable \"go\""])
165+
T.unlines ( [ "1:1-7 SemanticTokenTypes_Keyword \"module\"" ]
166+
++ ["1:8-13 SemanticTokenTypes_Namespace \"Hello\"" | compilerVersion >= Version [9, 10] []]
167+
++ [ "1:14-19 SemanticTokenTypes_Keyword \"where\""
168+
, "2:1-3 SemanticTokenTypes_Variable \"go\""
169+
, "2:6-7 SemanticTokenTypes_Keyword \"=\""
170+
, "2:8-9 SemanticTokenTypes_Number \"1\"" ])
167171
]
168172

169173

@@ -182,8 +186,8 @@ semanticTokensFullDeltaTests =
182186
testCase "add tokens" $ do
183187
let file1 = "TModuleA.hs"
184188
let expectDelta
185-
| compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 25 0 (Just [2, 0, 3, 8, 0])]))
186-
| otherwise = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2, 0, 3, 8, 0])]))
189+
| compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit {_start = 60, _deleteCount = 0, _data_ = Just [2,0,3,8,0,0,4,1,15,0,0,2,1,19,0]}]))
190+
| otherwise = InR (InL (SemanticTokensDelta {_resultId = Just "1", _edits = [SemanticTokensEdit {_start = 55, _deleteCount = 0, _data_ = Just [2,0,3,8,0,0,4,1,15,0,0,2,1,19,0]}]}))
187191
-- r c l t m
188192
-- where r = row, c = column, l = length, t = token, m = modifier
189193
Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do
@@ -203,8 +207,8 @@ semanticTokensFullDeltaTests =
203207
testCase "remove tokens" $ do
204208
let file1 = "TModuleA.hs"
205209
let expectDelta
206-
| compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 5 20 (Just [])]))
207-
| otherwise = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])]))
210+
| compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta {_resultId = Just "1", _edits = [SemanticTokensEdit {_start = 21, _deleteCount = 12, _data_ = Just []},SemanticTokensEdit {_start = 34, _deleteCount = 3, _data_ = Just []},SemanticTokensEdit {_start = 41, _deleteCount = 0, _data_ = Just [7]},SemanticTokensEdit {_start = 42, _deleteCount = 2, _data_ = Just [15]},SemanticTokensEdit {_start = 46, _deleteCount = 1, _data_ = Just [5]},SemanticTokensEdit {_start = 51, _deleteCount = 6, _data_ = Just [6]}]}))
211+
| otherwise = InR (InL (SemanticTokensDelta {_resultId = Just "1", _edits = [SemanticTokensEdit {_start = 16, _deleteCount = 12, _data_ = Just []},SemanticTokensEdit {_start = 29, _deleteCount = 3, _data_ = Just []},SemanticTokensEdit {_start = 36, _deleteCount = 0, _data_ = Just [7]},SemanticTokensEdit {_start = 37, _deleteCount = 2, _data_ = Just [15]},SemanticTokensEdit {_start = 41, _deleteCount = 1, _data_ = Just [5]},SemanticTokensEdit {_start = 46, _deleteCount = 6, _data_ = Just [6]}]}))
208212
-- delete all tokens
209213
Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do
210214
doc1 <- openDoc file1 "haskell"
@@ -244,19 +248,26 @@ semanticTokensTests =
244248
let expect =
245249
unlines
246250
(
251+
[ "[1:1-7 HsSyntacticTokenType TKeyword \"module\"]" ]
247252
-- > 9.10 have module name in the token
248-
(["1:8-16 TModule \"TModuleB\"" | compilerVersion >= Version [9, 10] []])
249-
++
250-
[
251-
"3:8-16 TModule \"TModuleA\"",
252-
"4:18-26 TModule \"TModuleA\"",
253-
"6:1-3 TVariable \"go\"",
254-
"6:6-10 TDataConstructor \"Game\"",
255-
"8:1-5 TVariable \"a\\66560bb\"",
256-
"8:8-17 TModule \"TModuleA.\"",
257-
"8:17-20 TRecordField \"a\\66560b\"",
258-
"8:21-23 TVariable \"go\""
259-
])
253+
++ ["[1:8-16 HsSemanticTokenType TModule \"TModuleB\"]" | compilerVersion >= Version [9, 10] []]
254+
++ [ "[1:17-22 HsSyntacticTokenType TKeyword \"where\"]"
255+
, "[3:1-7 HsSyntacticTokenType TKeyword \"import\"]"
256+
, "[3:8-16 HsSemanticTokenType TModule \"TModuleA\"]"
257+
, "[4:1-7 HsSyntacticTokenType TKeyword \"import\"]"
258+
, "[4:8-17 HsSyntacticTokenType TKeyword \"qualified\"]"
259+
, "[4:18-26 HsSemanticTokenType TModule \"TModuleA\"]"
260+
, "[6:1-3 HsSemanticTokenType TVariable \"go\"]"
261+
, "[6:4-5 HsSyntacticTokenType TKeyword \"=\"]"
262+
, "[6:6-10 HsSemanticTokenType TDataConstructor \"Game\"]"
263+
, "[6:11-12 HsSyntacticTokenType TNumberLit \"1\"]"
264+
, "[8:1-5 HsSemanticTokenType TVariable \"a\\66560bb\"]"
265+
, "[8:5-6 HsSyntacticTokenType TKeyword \" \"]"
266+
, "[8:8-17 HsSemanticTokenType TModule \"TModuleA.\"]"
267+
, "[8:17-20 HsSyntacticTokenType TRecordSelector \"a\\66560b\",8:17-20 HsSemanticTokenType TRecordField \"a\\66560b\"]"
268+
, "[8:21-23 HsSemanticTokenType TVariable \"go\"]"
269+
]
270+
)
260271
liftIO $ result @?= expect,
261272
goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1",
262273
goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym",

0 commit comments

Comments
 (0)