Skip to content

Commit 0999c22

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

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
@@ -170,6 +170,14 @@ getSyntacticTokensRule recorder =
170170
astTraversalWith :: forall b r. Data b => b -> (forall a. Data a => a -> [r]) -> [r]
171171
astTraversalWith ast f = mconcat $ flip gmapQ ast \y -> f y <> astTraversalWith y f
172172

173+
{-# inline extractTyToTyToTy #-}
174+
extractTyToTyToTy :: forall f a. (Typeable f, Data a) => a -> Maybe (forall r. (forall b c. (Typeable b, Typeable c) => f b c -> r) -> r)
175+
extractTyToTyToTy node
176+
| App (App conRep argRep1) argRep2 <- typeOf node
177+
, Just HRefl <- eqTypeRep conRep (typeRep @f)
178+
= Just $ withTypeable argRep1 $ withTypeable argRep2 \k -> k node
179+
| otherwise = Nothing
180+
173181
{-# inline extractTyToTy #-}
174182
extractTyToTy :: forall f a. (Typeable f, Data a) => a -> Maybe (forall r. (forall b. Typeable b => f b -> r) -> r)
175183
extractTyToTy node
@@ -191,15 +199,38 @@ computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
191199
[
192200
#if MIN_VERSION_ghc(9,9,0)
193201
maybeToList $ mkFromLocatable TKeyword . (\k -> k \x k' -> k' x) =<< extractTyToTy @EpToken node,
202+
maybeToList $ mkFromLocatable TKeyword . (\k -> k \x k' -> k' x) =<< extractTyToTyToTy @EpUniToken node,
203+
do
204+
AnnContext {ac_darrow, ac_open, ac_close} <- maybeToList $ extractTy node
205+
let mkFromTok :: (Foldable f, HasSrcSpan a) => f a -> [(Range,HsSyntacticTokenType)]
206+
mkFromTok = foldMap (\tok -> maybeToList $ mkFromLocatable TKeyword \k -> k tok)
207+
mconcat
208+
#if MIN_VERSION_ghc(9,11,0)
209+
[ mkFromTok ac_darrow
210+
#else
211+
[ foldMap (\(_, loc) -> maybeToList $ mkFromLocatable TKeyword \k -> k loc) ac_darrow
212+
#endif
213+
, mkFromTok ac_open
214+
, mkFromTok ac_close
215+
],
194216
#endif
217+
195218
#if !MIN_VERSION_ghc(9,11,0)
196219
maybeToList $ mkFromLocatable TKeyword . (\x k -> k x) =<< extractTy @AddEpAnn node,
197220
do
198221
EpAnnImportDecl i p s q pkg a <- maybeToList $ extractTy @EpAnnImportDecl node
199-
200222
mapMaybe (mkFromLocatable TKeyword . (\x k -> k x)) $ catMaybes $ [Just i, s, q, pkg, a] <> foldMap (\(l, l') -> [Just l, Just l']) p,
201223
#endif
202-
maybeToList $ mkFromLocatable TComment . (\x k -> k x) =<< extractTy @LEpaComment node,
224+
maybeToList do
225+
comment <- extractTy @LEpaComment node
226+
#if !MIN_VERSION_ghc(9,7,0)
227+
-- NOTE: on ghc 9.6 there's an empty comment that is supposed to
228+
-- located the end of file
229+
case comment of
230+
L _ (EpaComment {ac_tok = EpaEofComment}) -> Nothing
231+
_ -> pure ()
232+
#endif
233+
mkFromLocatable TComment \k -> k comment,
203234
do
204235
L loc expr <- maybeToList $ extractTy @(LHsExpr GhcPs) node
205236
let fromSimple = maybeToList . flip mkFromLocatable \k -> k loc
@@ -211,8 +242,9 @@ computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
211242

212243
HsIsString {} -> TStringLit
213244
HsLit _ lit -> fromSimple case lit of
214-
HsChar {} -> TCharLit
215-
HsCharPrim {} -> TCharLit
245+
-- NOTE: unfortunately, lsp semantic tokens doesn't have a notion of char literals
246+
HsChar {} -> TStringLit
247+
HsCharPrim {} -> TStringLit
216248

217249
HsInt {} -> TNumberLit
218250
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,24 +12,26 @@
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 Ide.Plugin.SemanticTokens.Types
25-
import Ide.Plugin.SemanticTokens.Utils (mkRange)
26-
import Language.LSP.Protocol.Types (LspEnum (knownValues),
27-
SemanticTokenAbsolute (SemanticTokenAbsolute),
28-
SemanticTokenRelative (SemanticTokenRelative),
29-
SemanticTokenTypes (..),
30-
SemanticTokens (SemanticTokens),
31-
UInt, absolutizeTokens)
32-
import Language.LSP.VFS hiding (line)
26+
import Ide.Plugin.SemanticTokens.Utils (mkRange)
27+
import Language.LSP.Protocol.Types (LspEnum (knownValues),
28+
SemanticTokenAbsolute (SemanticTokenAbsolute),
29+
SemanticTokenRelative (SemanticTokenRelative),
30+
SemanticTokenTypes (..),
31+
SemanticTokens (SemanticTokens),
32+
UInt,
33+
absolutizeTokens)
34+
import Language.LSP.VFS hiding (line)
3335

3436
-- * 0. Mapping name to Hs semantic token type.
3537

@@ -58,19 +60,16 @@ toLspTokenType conf tk = conf & case tk of
5860
HsSyntacticTokenType TKeyword -> stKeyword
5961
HsSyntacticTokenType TComment -> stComment
6062
HsSyntacticTokenType TStringLit -> stStringLit
61-
HsSyntacticTokenType TCharLit -> stCharLit
6263
HsSyntacticTokenType TNumberLit -> stNumberLit
6364
HsSyntacticTokenType TRecordSelector -> stRecordSelector
6465

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

72-
lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
73-
lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)
71+
lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> [HsTokenType]
72+
lspTokenTypeHsTokenType cf tk = Map.findWithDefault [] tk (lspTokenReverseMap cf)
7473

7574
-- * 2. Mapping from GHC type and tyThing to semantic token type.
7675

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

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

204203
-- | recoverLspSemanticTokens
205204
-- 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)