modify the lspTokenReverseMap to take semantic config

Author: soulomoon

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

@@ -48,11 +48,15 @@ toLspTokenType conf tk = case tk of
   TRecField     -> runIdentity $ stRecField conf
   TPatternSyn   -> runIdentity $ stPatternSyn conf
 
-lspTokenReverseMap :: Map.Map SemanticTokenTypes HsSemanticTokenType
-lspTokenReverseMap = Map.fromList $ map (\x -> (toLspTokenType def x, x)) $ enumFrom minBound
+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 x, x)) xs
 
-fromLspTokenType :: SemanticTokenTypes -> Maybe HsSemanticTokenType
-fromLspTokenType tk = Map.lookup tk lspTokenReverseMap
+fromLspTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
+fromLspTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)
 
 -- * 2. Mapping from GHC type and tyThing to semantic token type.
 
@@ -156,18 +160,19 @@ infoTokenType x = case x of
 -- for debug and test.
 -- 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)
--- this use the default token type mapping
-recoverSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType]
-recoverSemanticTokens v s = do
+-- the `SemanticTokensConfig` used should be a map with bijection property
+recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType]
+recoverSemanticTokens config v s = do
     tks <- recoverLspSemanticTokens v s
-    return $ map fromLspTokenTypeStrict tks
+    return $ map (lspTokenHsToken config) tks
 
--- | fromLspTokenTypeStrict
+-- | lspTokenHsToken
 -- for debug and test.
--- use the default token type mapping to convert lsp token type to haskell token type
-fromLspTokenTypeStrict :: SemanticTokenOriginal SemanticTokenTypes -> SemanticTokenOriginal HsSemanticTokenType
-fromLspTokenTypeStrict (SemanticTokenOriginal tokenType location name) =
-        case fromLspTokenType tokenType of
+-- 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 config (SemanticTokenOriginal tokenType location name) =
+        case fromLspTokenType config tokenType of
         Just t  -> SemanticTokenOriginal t location name
         Nothing -> error "recoverSemanticTokens: unknown lsp token type"
 

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

@@ -76,20 +76,20 @@ goldenWithHaskellAndCapsOutPut config plugin title tree path desc act =
         void waitForBuildQueue
         act doc
 
-goldenWithSemanticTokens :: TestName -> FilePath -> TestTree
-goldenWithSemanticTokens title path =
+goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree
+goldenWithSemanticTokensWithDefaultConfig title path =
   goldenWithHaskellAndCapsOutPut
     def
     semanticTokensPlugin
     title
     (mkFs $ FS.directProject (path <.> "hs"))
     path
     "expected"
-    docSemanticTokensString
+    (docSemanticTokensString def)
 
-docSemanticTokensString :: TextDocumentIdentifier -> Session String
-docSemanticTokensString doc = do
-  xs  <- map fromLspTokenTypeStrict <$> docLspSemanticTokensString doc
+docSemanticTokensString :: SemanticTokensConfig-> TextDocumentIdentifier -> Session String
+docSemanticTokensString cf doc = do
+  xs  <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc
   return $ unlines . map show $ xs
 
 docLspSemanticTokensString :: TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes]
@@ -106,19 +106,19 @@ semanticTokensClassTests :: TestTree
 semanticTokensClassTests =
   testGroup
     "type class"
-    [ goldenWithSemanticTokens "golden type class" "TClass",
-      goldenWithSemanticTokens "imported class method InstanceClassMethodBind" "TInstanceClassMethodBind",
-      goldenWithSemanticTokens "imported class method TInstanceClassMethodUse" "TInstanceClassMethodUse",
-      goldenWithSemanticTokens "imported deriving" "TClassImportedDeriving"
+    [ goldenWithSemanticTokensWithDefaultConfig "golden type class" "TClass",
+      goldenWithSemanticTokensWithDefaultConfig "imported class method InstanceClassMethodBind" "TInstanceClassMethodBind",
+      goldenWithSemanticTokensWithDefaultConfig "imported class method TInstanceClassMethodUse" "TInstanceClassMethodUse",
+      goldenWithSemanticTokensWithDefaultConfig "imported deriving" "TClassImportedDeriving"
     ]
 
 semanticTokensValuePatternTests :: TestTree
 semanticTokensValuePatternTests =
   testGroup
     "value and patterns "
-    [ goldenWithSemanticTokens "value bind" "TValBind",
-      goldenWithSemanticTokens "pattern match" "TPatternMatch",
-      goldenWithSemanticTokens "pattern bind" "TPatternbind"
+    [ goldenWithSemanticTokensWithDefaultConfig "value bind" "TValBind",
+      goldenWithSemanticTokensWithDefaultConfig "pattern match" "TPatternMatch",
+      goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternbind"
     ]
 
 mkSemanticConfig :: Value -> Config
@@ -187,35 +187,35 @@ semanticTokensTests =
               either
                 (error . show)
                 (\xs -> liftIO $ xs @?= expect)
-                $ recoverSemanticTokens vfs tokens
+                $ recoverSemanticTokens def vfs tokens
               return ()
             _ -> error "No tokens found"
           liftIO $ 1 @?= 1,
-      goldenWithSemanticTokens "mixed constancy test result generated from one ghc version" "T1",
-      goldenWithSemanticTokens "pattern bind" "TPatternSyn",
-      goldenWithSemanticTokens "type family" "TTypefamily",
-      goldenWithSemanticTokens "TUnicodeSyntax" "TUnicodeSyntax"
+      goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1",
+      goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSyn",
+      goldenWithSemanticTokensWithDefaultConfig "type family" "TTypefamily",
+      goldenWithSemanticTokensWithDefaultConfig "TUnicodeSyntax" "TUnicodeSyntax"
     ]
 
 semanticTokensDataTypeTests :: TestTree
 semanticTokensDataTypeTests =
   testGroup
     "get semantic Tokens"
-    [ goldenWithSemanticTokens "simple datatype" "TDataType",
-      goldenWithSemanticTokens "record" "TRecord",
-      goldenWithSemanticTokens "datatype import" "TDatatypeImported",
-      goldenWithSemanticTokens "datatype family" "TDataFamily",
-      goldenWithSemanticTokens "GADT" "TGADT"
+    [ goldenWithSemanticTokensWithDefaultConfig "simple datatype" "TDataType",
+      goldenWithSemanticTokensWithDefaultConfig "record" "TRecord",
+      goldenWithSemanticTokensWithDefaultConfig "datatype import" "TDatatypeImported",
+      goldenWithSemanticTokensWithDefaultConfig "datatype family" "TDataFamily",
+      goldenWithSemanticTokensWithDefaultConfig "GADT" "TGADT"
     ]
 
 semanticTokensFunctionTests :: TestTree
 semanticTokensFunctionTests =
   testGroup
     "get semantic of functions"
-    [ goldenWithSemanticTokens "functions" "TFunction",
-      goldenWithSemanticTokens "local functions" "TFunctionLocal",
-      goldenWithSemanticTokens "function in let binding" "TFunctionLet",
-      goldenWithSemanticTokens "negative case non-function with constraint" "TNoneFunctionWithConstraint"
+    [ goldenWithSemanticTokensWithDefaultConfig "functions" "TFunction",
+      goldenWithSemanticTokensWithDefaultConfig "local functions" "TFunctionLocal",
+      goldenWithSemanticTokensWithDefaultConfig "function in let binding" "TFunctionLet",
+      goldenWithSemanticTokensWithDefaultConfig "negative case non-function with constraint" "TNoneFunctionWithConstraint"
     ]
 
 main :: IO ()