semantic tokens: add infix operator (#4030)

* add infix operator

* add test

* mark all infix operator to have operator semantic type

* update scheme

* fix test

* fix more test

Author: soulomoon

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE TypeOperators     #-}
 
 -- |
 -- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for:
@@ -29,6 +30,16 @@ import           Language.LSP.Protocol.Types     (LspEnum (knownValues),
                                                   UInt, absolutizeTokens)
 import           Language.LSP.VFS                hiding (line)
 
+-- * 0. Mapping name to Hs semantic token type.
+
+idInfixOperator :: Identifier -> Maybe HsSemanticTokenType
+idInfixOperator (Right name) = nameInfixOperator name
+idInfixOperator _            = Nothing
+
+nameInfixOperator :: Name -> Maybe HsSemanticTokenType
+nameInfixOperator name | isSymOcc (nameOccName name) = Just TOperator
+nameInfixOperator _ = Nothing
+
 -- * 1. Mapping semantic token type to and from the LSP default token type.
 
 -- | map from haskell semantic token type to LSP default token type
@@ -46,6 +57,7 @@ toLspTokenType conf tk = case tk of
   TRecordField     -> stRecordField conf
   TPatternSynonym  -> stPatternSynonym conf
   TModule          -> stModule conf
+  TOperator        -> stOperator conf
 
 lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
 lspTokenReverseMap config
@@ -61,7 +73,10 @@ lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)
 
 -- | tyThingSemantic
 tyThingSemantic :: TyThing -> Maybe HsSemanticTokenType
-tyThingSemantic ty = case ty of
+tyThingSemantic ty | (Just hst) <- tyThingSemantic' ty = Just hst <> nameInfixOperator (getName ty)
+tyThingSemantic _ = Nothing
+tyThingSemantic' :: TyThing -> Maybe HsSemanticTokenType
+tyThingSemantic' ty = case ty of
   AnId vid
     | isTyVar vid -> Just TTypeVariable
     | isRecordSelector vid -> Just TRecordField

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

@@ -47,7 +47,7 @@ idIdSemanticFromHie hieKind rm ns = do
       spanInfos <- M.lookup name' rm'
       let typeTokenType = foldMap (typeSemantic hieKind) $ listToMaybe $ mapMaybe (identType . snd) spanInfos
       contextInfoTokenType <- foldMap (contextInfosMaybeTokenType . identInfo . snd) spanInfos
-      fold [typeTokenType, Just contextInfoTokenType]
+      fold [typeTokenType, Just contextInfoTokenType, idInfixOperator ns]
 
     contextInfosMaybeTokenType :: Set.Set ContextInfo -> Maybe HsSemanticTokenType
     contextInfosMaybeTokenType details = foldMap infoTokenType (Set.toList details)

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

@@ -40,6 +40,7 @@ docName tt = case tt of
   TTypeFamily      -> "type families"
   TRecordField     -> "record fields"
   TModule          -> "modules"
+  TOperator        -> "operators"
 
 toConfigName :: String -> String
 toConfigName = ("st" <>)

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

@@ -39,11 +39,10 @@ data HsSemanticTokenType
   | TTypeSynonym -- Type synonym
   | TTypeFamily -- type family
   | TRecordField -- from match bind
+  | TOperator-- operator
   | TModule -- module name
   deriving (Eq, Ord, Show, Enum, Bounded, Generic, Lift)
 
-
-
 -- type SemanticTokensConfig = SemanticTokensConfig_ Identity
 instance Default SemanticTokensConfig where
   def = STC
@@ -63,6 +62,7 @@ instance Default SemanticTokensConfig where
       , stTypeFamily = SemanticTokenTypes_Interface
       , stRecordField = SemanticTokenTypes_Property
       , stModule = SemanticTokenTypes_Namespace
+      , stOperator = SemanticTokenTypes_Operator
       }
 -- | SemanticTokensConfig_ is a configuration for the semantic tokens plugin.
 -- it contains map between the hs semantic token type and default token type.
@@ -79,6 +79,7 @@ data SemanticTokensConfig = STC
   , stTypeFamily      :: !SemanticTokenTypes
   , stRecordField     :: !SemanticTokenTypes
   , stModule          :: !SemanticTokenTypes
+  , stOperator        :: !SemanticTokenTypes
   } deriving (Generic, Show)
 
 

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

@@ -220,7 +220,8 @@ semanticTokensFunctionTests =
       goldenWithSemanticTokensWithDefaultConfig "local functions" "TFunctionLocal",
       goldenWithSemanticTokensWithDefaultConfig "functions under type synonym" "TFunctionUnderTypeSynonym",
       goldenWithSemanticTokensWithDefaultConfig "function in let binding" "TFunctionLet",
-      goldenWithSemanticTokensWithDefaultConfig "negative case non-function with constraint" "TNoneFunctionWithConstraint"
+      goldenWithSemanticTokensWithDefaultConfig "negative case non-function with constraint" "TNoneFunctionWithConstraint",
+      goldenWithSemanticTokensWithDefaultConfig "TOperator" "TOperator"
     ]
 
 main :: IO ()

plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected

@@ -12,7 +12,7 @@
 15:5-8 TClassMethod "boo"
 15:9-10 TVariable "x"
 15:13-14 TVariable "x"
-15:15-16 TClassMethod "+"
+15:15-16 TOperator "+"
 17:6-8 TTypeConstructor "Dd"
 17:11-13 TDataConstructor "Dd"
 17:14-17 TTypeConstructor "Int"
@@ -63,18 +63,18 @@
 36:11-13 TVariable "vv"
 37:10-12 TVariable "gg"
 38:14-17 TRecordField "foo"
-38:18-19 TFunction "$"
+38:18-19 TOperator "$"
 38:20-21 TVariable "f"
 38:24-27 TRecordField "foo"
 39:14-17 TRecordField "foo"
-39:18-19 TFunction "$"
+39:18-19 TOperator "$"
 39:20-21 TVariable "f"
 39:24-27 TRecordField "foo"
 41:1-3 TFunction "go"
 41:6-9 TRecordField "foo"
 42:1-4 TFunction "add"
 42:8-16 TModule "Prelude."
-42:16-17 TClassMethod "+"
+42:16-17 TOperator "+"
 47:1-5 TVariable "main"
 47:9-11 TTypeConstructor "IO"
 48:1-5 TVariable "main"

plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected

@@ -1,7 +1,7 @@
 4:6-9 TTypeConstructor "Foo"
 4:12-15 TDataConstructor "Foo"
 4:16-19 TTypeConstructor "Int"
-5:10-12 TClass "Eq"
-5:13-16 TTypeConstructor "Foo"
-6:6-8 TClassMethod "=="
+5:10-14 TClass "Show"
+5:15-18 TTypeConstructor "Foo"
+6:5-9 TClassMethod "show"
 6:12-21 TVariable "undefined"

plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs

@@ -2,5 +2,5 @@ module TInstanceClassMethodBind where
 
 
 data Foo = Foo Int
-instance Eq Foo where
-    (==) = undefined
+instance Show Foo where
+    show = undefined

plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected

@@ -1,2 +1,2 @@
 4:1-3 TFunction "go"
-4:10-12 TClassMethod "=="
+4:8-12 TClassMethod "show"

plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs

@@ -1,5 +1,5 @@
 module TInstanceClassMethodUse where
 
 
-go  =   (==)
+go  =  show