[chore] try to fix most of the tests (9.10 and 9.12 still disagree)

Author: MangoIV

flake.nix

@@ -69,6 +69,7 @@
             # Compiler toolchain
             hpkgs.ghc
             hpkgs.haskell-language-server
+            pkgs.stack
             pkgs.haskellPackages.cabal-install
             # Dependencies needed to build some parts of Hackage
             gmp zlib ncurses

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

@@ -633,11 +633,17 @@ instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where
 #if MIN_VERSION_ghc(9,11,0)
 instance HasSrcSpan (GHC.EpToken sym) where
   getLoc = GHC.getHasLoc
+instance HasSrcSpan (GHC.EpUniToken sym sym') where
+  getLoc = GHC.getHasLoc
 #elif MIN_VERSION_ghc(9,9,0)
 instance HasSrcSpan (GHC.EpToken sym) where
   getLoc = GHC.getHasLoc . \case
     GHC.NoEpTok -> Nothing
     GHC.EpTok loc -> Just loc
+instance HasSrcSpan (GHC.EpUniToken sym sym') where
+  getLoc = GHC.getHasLoc . \case
+    GHC.NoEpUniTok -> Nothing
+    GHC.EpUniTok loc _ -> Just loc
 #endif
 
 #if MIN_VERSION_ghc(9,9,0)

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

@@ -170,6 +170,14 @@ getSyntacticTokensRule recorder =
 astTraversalWith :: forall b r. Data b => b -> (forall a. Data a => a -> [r]) -> [r]
 astTraversalWith ast f = mconcat $ flip gmapQ ast \y -> f y <> astTraversalWith y f
 
+{-# inline extractTyToTyToTy #-}
+extractTyToTyToTy :: forall f a. (Typeable f, Data a) => a -> Maybe (forall r. (forall b c. (Typeable b, Typeable c) => f b c -> r) -> r)
+extractTyToTyToTy node
+  | App (App conRep argRep1) argRep2 <- typeOf node
+  , Just HRefl <- eqTypeRep conRep (typeRep @f)
+  = Just $ withTypeable argRep1 $ withTypeable argRep2 \k -> k node
+  | otherwise = Nothing
+
 {-# inline extractTyToTy #-}
 extractTyToTy :: forall f a. (Typeable f, Data a) => a -> Maybe (forall r. (forall b. Typeable b => f b -> r) -> r)
 extractTyToTy node
@@ -191,15 +199,38 @@ computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
          [
 #if MIN_VERSION_ghc(9,9,0)
            maybeToList $ mkFromLocatable TKeyword . (\k -> k \x k' -> k' x) =<< extractTyToTy @EpToken node,
+           maybeToList $ mkFromLocatable TKeyword . (\k -> k \x k' -> k' x) =<< extractTyToTyToTy @EpUniToken node,
+           do
+           AnnContext {ac_darrow, ac_open, ac_close} <- maybeToList $ extractTy node
+           let mkFromTok :: (Foldable f, HasSrcSpan a) => f a -> [(Range,HsSyntacticTokenType)]
+               mkFromTok = foldMap (\tok -> maybeToList $ mkFromLocatable TKeyword \k -> k tok)
+           mconcat
+#if MIN_VERSION_ghc(9,11,0)
+             [ mkFromTok ac_darrow
+#else
+             [ foldMap (\(_, loc) -> maybeToList $ mkFromLocatable TKeyword \k -> k loc) ac_darrow
+#endif
+             , mkFromTok ac_open
+             , mkFromTok ac_close
+             ],
 #endif
+
 #if !MIN_VERSION_ghc(9,11,0)
            maybeToList $ mkFromLocatable TKeyword . (\x k -> k x) =<< extractTy @AddEpAnn node,
            do
            EpAnnImportDecl i p s q pkg a <- maybeToList $ extractTy @EpAnnImportDecl node
-
            mapMaybe (mkFromLocatable TKeyword . (\x k -> k x)) $ catMaybes $ [Just i, s, q, pkg, a] <> foldMap (\(l, l') -> [Just l, Just l']) p,
 #endif
-           maybeToList $ mkFromLocatable TComment . (\x k -> k x) =<< extractTy @LEpaComment node,
+           maybeToList do
+             comment <- extractTy @LEpaComment node
+#if !MIN_VERSION_ghc(9,7,0)
+             -- NOTE: on ghc 9.6 there's an empty comment that is supposed to
+             -- located the end of file
+             case comment of
+               L _ (EpaComment {ac_tok = EpaEofComment}) -> Nothing
+               _ -> pure ()
+#endif
+             mkFromLocatable TComment \k -> k comment,
            do
            L loc expr <- maybeToList $ extractTy @(LHsExpr GhcPs) node
            let fromSimple = maybeToList . flip mkFromLocatable \k -> k loc
@@ -211,8 +242,9 @@ computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
 
                HsIsString {}   -> TStringLit
              HsLit _ lit -> fromSimple case lit of
-                 HsChar {}            -> TCharLit
-                 HsCharPrim {}        -> TCharLit
+                 -- NOTE: unfortunately, lsp semantic tokens doesn't have a notion of char literals
+                 HsChar {}            -> TStringLit
+                 HsCharPrim {}        -> TStringLit
 
                  HsInt {}             -> TNumberLit
                  HsInteger {}         -> TNumberLit

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

@@ -12,24 +12,26 @@
 -- 4. Mapping from LSP tokens to SemanticTokenOriginal.
 module Ide.Plugin.SemanticTokens.Mappings where
 
-import qualified Data.Array                      as A
+import qualified Data.Array                               as A
 import           Data.Function
-import           Data.List.Extra                 (chunksOf, (!?))
-import qualified Data.Map.Strict                 as Map
-import           Data.Maybe                      (mapMaybe)
-import qualified Data.Set                        as Set
-import           Data.Text                       (Text, unpack)
-import           Development.IDE                 (HieKind (HieFresh, HieFromDisk))
+import           Data.List.Extra                          (chunksOf, (!?))
+import qualified Data.Map.Strict                          as Map
+import           Data.Maybe                               (mapMaybe)
+import qualified Data.Set                                 as Set
+import           Data.Text                                (Text, unpack)
+import           Development.IDE                          (HieKind (HieFresh, HieFromDisk))
 import           Development.IDE.GHC.Compat
+import           Ide.Plugin.SemanticTokens.SemanticConfig (allHsTokenTypes)
 import           Ide.Plugin.SemanticTokens.Types
-import           Ide.Plugin.SemanticTokens.Utils (mkRange)
-import           Language.LSP.Protocol.Types     (LspEnum (knownValues),
-                                                  SemanticTokenAbsolute (SemanticTokenAbsolute),
-                                                  SemanticTokenRelative (SemanticTokenRelative),
-                                                  SemanticTokenTypes (..),
-                                                  SemanticTokens (SemanticTokens),
-                                                  UInt, absolutizeTokens)
-import           Language.LSP.VFS                hiding (line)
+import           Ide.Plugin.SemanticTokens.Utils          (mkRange)
+import           Language.LSP.Protocol.Types              (LspEnum (knownValues),
+                                                           SemanticTokenAbsolute (SemanticTokenAbsolute),
+                                                           SemanticTokenRelative (SemanticTokenRelative),
+                                                           SemanticTokenTypes (..),
+                                                           SemanticTokens (SemanticTokens),
+                                                           UInt,
+                                                           absolutizeTokens)
+import           Language.LSP.VFS                         hiding (line)
 
 -- * 0. Mapping name to Hs semantic token type.
 
@@ -58,19 +60,16 @@ toLspTokenType conf tk = conf & case tk of
   HsSyntacticTokenType TKeyword        -> stKeyword
   HsSyntacticTokenType TComment        -> stComment
   HsSyntacticTokenType TStringLit      -> stStringLit
-  HsSyntacticTokenType TCharLit        -> stCharLit
   HsSyntacticTokenType TNumberLit      -> stNumberLit
   HsSyntacticTokenType TRecordSelector -> stRecordSelector
 
-lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
-lspTokenReverseMap config
-    | length xs /= Map.size mr = error "lspTokenReverseMap: token type mapping is not bijection"
-    | otherwise = mr
-    where xs = enumFrom minBound
-          mr = Map.fromList $ map (\x -> (toLspTokenType config (HsSemanticTokenType x), x)) xs
+lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes [HsTokenType]
+lspTokenReverseMap config = mr
+    where xs = allHsTokenTypes
+          mr = Map.fromListWith (<>) $ map (\x -> (toLspTokenType config x, [x])) xs
 
-lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
-lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)
+lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> [HsTokenType]
+lspTokenTypeHsTokenType cf tk = Map.findWithDefault [] tk (lspTokenReverseMap cf)
 
 -- * 2. Mapping from GHC type and tyThing to semantic token type.
 
@@ -186,20 +185,20 @@ infoTokenType x = case x of
 -- this function is used to recover the original tokens(with token in haskell token type zoon)
 -- from the lsp semantic tokens(with token in lsp token type zoon)
 -- the `SemanticTokensConfig` used should be a map with bijection property
-recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType]
+recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsTokenType]
 recoverSemanticTokens config v s = do
     tks <- recoverLspSemanticTokens v s
-    return $ map (lspTokenHsToken config) tks
+    return $ foldMap (lspTokenHsToken config) tks
 
 -- | lspTokenHsToken
 -- for debug and test.
 -- use the `SemanticTokensConfig` to convert lsp token type to haskell token type
 -- the `SemanticTokensConfig` used should be a map with bijection property
-lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> SemanticTokenOriginal HsSemanticTokenType
+lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> [SemanticTokenOriginal HsTokenType]
 lspTokenHsToken config (SemanticTokenOriginal tokenType location name) =
         case lspTokenTypeHsTokenType config tokenType of
-        Just t  -> SemanticTokenOriginal t location name
-        Nothing -> error "recoverSemanticTokens: unknown lsp token type"
+        [] -> error "recoverSemanticTokens: unknown lsp token type"
+        ts -> map (\t -> SemanticTokenOriginal t location name) ts
 
 -- | recoverLspSemanticTokens
 -- for debug and test.

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

@@ -44,7 +44,6 @@ docName tt = case tt of
   HsSyntacticTokenType TKeyword        -> "keyword"
   HsSyntacticTokenType TStringLit      -> "string literal"
   HsSyntacticTokenType TComment        -> "comment"
-  HsSyntacticTokenType TCharLit        -> "char literal"
   HsSyntacticTokenType TNumberLit      -> "number literal"
   HsSyntacticTokenType TRecordSelector -> "record selector"
 

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

@@ -46,13 +46,12 @@ data HsSyntacticTokenType
   = TKeyword
   | TComment
   | TStringLit
-  | TCharLit
   | TNumberLit
   | TRecordSelector
   deriving stock (Eq, Ord, Show, Enum, Bounded, Generic, Lift)
 
-data HsTokenType =
-  HsSyntacticTokenType HsSyntacticTokenType
+data HsTokenType
+  = HsSyntacticTokenType HsSyntacticTokenType
   | HsSemanticTokenType HsSemanticTokenType
   deriving stock (Eq, Ord, Show, Generic, Lift)
 

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

@@ -162,8 +162,12 @@ semanticTokensConfigTest =
             void waitForBuildQueue
             result1 <- docLspSemanticTokensString doc
             liftIO $ unlines (map show result1) @?=
-                T.unlines (["1:8-13 SemanticTokenTypes_Namespace \"Hello\"" | compilerVersion >= Version [9, 10] []]
-                        ++ ["2:1-3 SemanticTokenTypes_Variable \"go\""])
+                T.unlines ( [ "1:1-7 SemanticTokenTypes_Keyword \"module\"" ]
+                        ++ ["1:8-13 SemanticTokenTypes_Namespace \"Hello\"" | compilerVersion >= Version [9, 10] []]
+                        ++ [ "1:14-19 SemanticTokenTypes_Keyword \"where\""
+                           , "2:1-3 SemanticTokenTypes_Variable \"go\""
+                           , "2:6-7 SemanticTokenTypes_Keyword \"=\""
+                           , "2:8-9 SemanticTokenTypes_Number \"1\"" ])
     ]
 
 
@@ -182,8 +186,8 @@ semanticTokensFullDeltaTests =
       testCase "add tokens" $ do
         let file1 = "TModuleA.hs"
         let expectDelta
-                | compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 25 0 (Just [2, 0, 3, 8, 0])]))
-                | otherwise = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2, 0, 3, 8, 0])]))
+                | 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]}]))
+                | 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]}]}))
         --                                                                                         r c l t m
         --                                      where r = row, c = column, l = length, t = token, m = modifier
         Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do
@@ -203,8 +207,8 @@ semanticTokensFullDeltaTests =
       testCase "remove tokens" $ do
         let file1 = "TModuleA.hs"
         let expectDelta
-                | compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 5 20 (Just [])]))
-                | otherwise = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])]))
+                | 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]}]}))
+                | 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]}]}))
         -- delete all tokens
         Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do
           doc1 <- openDoc file1 "haskell"
@@ -244,19 +248,26 @@ semanticTokensTests =
           let expect =
                 unlines
                   (
+                     [ "[1:1-7 HsSyntacticTokenType TKeyword \"module\"]" ]
                     -- > 9.10 have module name in the token
-                    (["1:8-16 TModule \"TModuleB\"" | compilerVersion >= Version [9, 10] []])
-                      ++
-                    [
-                    "3:8-16 TModule \"TModuleA\"",
-                    "4:18-26 TModule \"TModuleA\"",
-                    "6:1-3 TVariable \"go\"",
-                    "6:6-10 TDataConstructor \"Game\"",
-                    "8:1-5 TVariable \"a\\66560bb\"",
-                    "8:8-17 TModule \"TModuleA.\"",
-                    "8:17-20 TRecordField \"a\\66560b\"",
-                    "8:21-23 TVariable \"go\""
-                  ])
+                     ++ ["[1:8-16 HsSemanticTokenType TModule \"TModuleB\"]" | compilerVersion >= Version [9, 10] []]
+                     ++ [ "[1:17-22 HsSyntacticTokenType TKeyword \"where\"]"
+                     , "[3:1-7 HsSyntacticTokenType TKeyword \"import\"]"
+                     , "[3:8-16 HsSemanticTokenType TModule \"TModuleA\"]"
+                     , "[4:1-7 HsSyntacticTokenType TKeyword \"import\"]"
+                     , "[4:8-17 HsSyntacticTokenType TKeyword \"qualified\"]"
+                     , "[4:18-26 HsSemanticTokenType TModule \"TModuleA\"]"
+                     , "[6:1-3 HsSemanticTokenType TVariable \"go\"]"
+                     , "[6:4-5 HsSyntacticTokenType TKeyword \"=\"]"
+                     , "[6:6-10 HsSemanticTokenType TDataConstructor \"Game\"]"
+                     , "[6:11-12 HsSyntacticTokenType TNumberLit \"1\"]"
+                     , "[8:1-5 HsSemanticTokenType TVariable \"a\\66560bb\"]"
+                     , "[8:5-6 HsSyntacticTokenType TKeyword \" \"]"
+                     , "[8:8-17 HsSemanticTokenType TModule \"TModuleA.\"]"
+                     , "[8:17-20 HsSyntacticTokenType TRecordSelector \"a\\66560b\",8:17-20 HsSemanticTokenType TRecordField \"a\\66560b\"]"
+                     , "[8:21-23 HsSemanticTokenType TVariable \"go\"]"
+                     ]
+                    )
           liftIO $ result @?= expect,
       goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1",
       goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym",