add config for semantic-tokens-plugin for mapping from hs token type to LSP default token type

docs/features.md

@@ -399,7 +399,7 @@ Rewrites record selectors to use overloaded dot syntax
 
 ![Explicit Wildcard Demo](../plugins/hls-overloaded-record-dot-plugin/example.gif)
 
-### Missing features
+## Missing features
 
 The following features are supported by the LSP specification but not implemented in HLS.
 Contributions welcome!

generate.bash

@@ -0,0 +1,4 @@
+ghcup set ghc 9.2.8; cabal clean; cabal test --test-option="-p /generate schema/"
+ghcup set ghc 9.4.8; cabal clean; cabal test --test-option="-p /generate schema/"
+ghcup set ghc 9.6.2; cabal clean; cabal test --test-option="-p /generate schema/"
+ghcup set ghc 9.8.1; cabal clean; cabal test --test-option="-p /generate schema/"

plugins/hls-semantic-tokens-plugin/hls-semantic-tokens-plugin.cabal

@@ -28,6 +28,7 @@ library
     Ide.Plugin.SemanticTokens.Mappings
   other-modules:
     Ide.Plugin.SemanticTokens.Query
+    Ide.Plugin.SemanticTokens.SemanticConfig
     Ide.Plugin.SemanticTokens.Utils
     Ide.Plugin.SemanticTokens.Internal
 
@@ -52,12 +53,15 @@ library
     , array
     , deepseq
     , hls-graph == 2.5.0.0
+    , template-haskell
+    , data-default
 
   default-language:   Haskell2010
   default-extensions: DataKinds
 
 test-suite tests
   type:             exitcode-stdio-1.0
+  ghc-options: -Wall
   default-language: Haskell2010
   hs-source-dirs:   test
   main-is:          Main.hs
@@ -83,3 +87,5 @@ test-suite tests
     , bytestring
     , ghcide                == 2.5.0.0
     , hls-plugin-api        == 2.5.0.0
+    , template-haskell
+    , data-default

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module Ide.Plugin.SemanticTokens (descriptor) where
 
@@ -11,10 +12,11 @@ import           Language.LSP.Protocol.Message
 descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState
 descriptor recorder plId =
   (defaultPluginDescriptor plId "Provides semantic tokens")
-    { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSemanticTokensFull Internal.semanticTokensFull,
+    { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder),
       Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder <> Internal.persistentGetSemanticTokensRule,
       pluginConfigDescriptor =
         defaultConfigDescriptor
           { configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False}
+          , configCustomConfig = mkCustomConfig Internal.semanticConfigProperties
           }
     }

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

@@ -1,82 +1,86 @@
------------------------------------------------------------------------------
------------------------------------------------------------------------------
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE OverloadedLabels      #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UnicodeSyntax         #-}
 
 -- |
 -- This module provides the core functionality of the plugin.
-module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule) where
+module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule, semanticConfigProperties) where
 
-import           Control.Lens                         ((^.))
-import           Control.Monad.Except                 (ExceptT, liftEither,
-                                                       withExceptT)
-import           Control.Monad.IO.Class               (MonadIO, liftIO)
-import           Control.Monad.Trans                  (lift)
-import           Control.Monad.Trans.Except           (runExceptT)
-import qualified Data.Map                             as Map
-import qualified Data.Text                            as T
-import           Development.IDE                      (Action,
-                                                       GetDocMap (GetDocMap),
-                                                       GetHieAst (GetHieAst),
-                                                       HieAstResult (HAR, hieAst, hieModule, refMap),
-                                                       IdeResult, IdeState,
-                                                       Priority (..), Recorder,
-                                                       Rules, WithPriority,
-                                                       cmapWithPrio, define,
-                                                       fromNormalizedFilePath,
-                                                       hieKind, ideLogger,
-                                                       logPriority, use_)
-import           Development.IDE.Core.PluginUtils     (runActionE,
-                                                       useWithStaleE)
-import           Development.IDE.Core.PositionMapping (idDelta)
-import           Development.IDE.Core.Rules           (toIdeResult)
-import           Development.IDE.Core.RuleTypes       (DocAndTyThingMap (..))
-import           Development.IDE.Core.Shake           (addPersistentRule,
-                                                       getVirtualFile,
-                                                       useWithStale_)
-import           Development.IDE.GHC.Compat           hiding (Warning)
-import           Development.IDE.GHC.Compat.Util      (mkFastString)
-import           Ide.Logger                           (logWith)
-import           Ide.Plugin.Error                     (PluginError (PluginInternalError),
-                                                       getNormalizedFilePathE,
-                                                       handleMaybe,
-                                                       handleMaybeM)
+import           Control.Lens                             ((^.))
+import           Control.Monad.Except                     (ExceptT, liftEither,
+                                                           withExceptT)
+import           Control.Monad.Trans                      (lift)
+import           Control.Monad.Trans.Except               (runExceptT)
+import           Data.Aeson                               (ToJSON (toJSON))
+import qualified Data.Map                                 as Map
+import           Development.IDE                          (Action,
+                                                           GetDocMap (GetDocMap),
+                                                           GetHieAst (GetHieAst),
+                                                           HieAstResult (HAR, hieAst, hieModule, refMap),
+                                                           IdeResult, IdeState,
+                                                           Priority (..),
+                                                           Recorder, Rules,
+                                                           WithPriority,
+                                                           cmapWithPrio, define,
+                                                           fromNormalizedFilePath,
+                                                           hieKind, logPriority,
+                                                           usePropertyAction,
+                                                           use_)
+import           Development.IDE.Core.PluginUtils         (runActionE,
+                                                           useWithStaleE)
+import           Development.IDE.Core.PositionMapping     (idDelta)
+import           Development.IDE.Core.Rules               (toIdeResult)
+import           Development.IDE.Core.RuleTypes           (DocAndTyThingMap (..))
+import           Development.IDE.Core.Shake               (addPersistentRule,
+                                                           getVirtualFile,
+                                                           useWithStale_)
+import           Development.IDE.GHC.Compat               hiding (Warning)
+import           Development.IDE.GHC.Compat.Util          (mkFastString)
+import           Ide.Logger                               (logWith)
+import           Ide.Plugin.Error                         (PluginError (PluginInternalError),
+                                                           getNormalizedFilePathE,
+                                                           handleMaybe,
+                                                           handleMaybeM)
 import           Ide.Plugin.SemanticTokens.Mappings
 import           Ide.Plugin.SemanticTokens.Query
+import           Ide.Plugin.SemanticTokens.SemanticConfig (mkSemanticConfigFunctions)
 import           Ide.Plugin.SemanticTokens.Types
 import           Ide.Types
-import qualified Language.LSP.Protocol.Lens           as L
-import           Language.LSP.Protocol.Message        (Method (Method_TextDocumentSemanticTokensFull))
-import           Language.LSP.Protocol.Types          (NormalizedFilePath,
-                                                       SemanticTokens,
-                                                       type (|?) (InL))
-import           Prelude                              hiding (span)
+import qualified Language.LSP.Protocol.Lens               as L
+import           Language.LSP.Protocol.Message            (Method (Method_TextDocumentSemanticTokensFull))
+import           Language.LSP.Protocol.Types              (NormalizedFilePath,
+                                                           SemanticTokens,
+                                                           type (|?) (InL))
+import           Prelude                                  hiding (span)
 
-logActionWith :: (MonadIO m) => IdeState -> Priority -> String -> m ()
-logActionWith st prior = liftIO . logPriority (ideLogger st) prior . T.pack
+
+$mkSemanticConfigFunctions
 
 -----------------------
 ---- the api
 -----------------------
 
-computeSemanticTokens :: IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens
-computeSemanticTokens st nfp = do
-  logActionWith st Debug $ "Computing semantic tokens:" <> show nfp
+computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens
+computeSemanticTokens recorder pid _ nfp = do
+  config <- lift $ useSemanticConfigAction pid
+  logWith recorder Debug (LogConfig config)
   (RangeHsSemanticTokenTypes {rangeSemanticMap}, mapping) <- useWithStaleE GetSemanticTokens nfp
-  withExceptT PluginInternalError $ liftEither $ rangeSemanticMapSemanticTokens mapping rangeSemanticMap
+  withExceptT PluginInternalError $ liftEither $ rangeSemanticMapSemanticTokens config mapping rangeSemanticMap
 
-semanticTokensFull :: PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
-semanticTokensFull state _ param = do
+semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
+semanticTokensFull recorder state pid param = do
   nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri)
-  items <- runActionE "SemanticTokens.semanticTokensFull" state $ computeSemanticTokens state nfp
+  items <- runActionE "SemanticTokens.semanticTokensFull" state $ computeSemanticTokens recorder pid state nfp
   return $ InL items
 
 -- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file.

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

@@ -32,33 +32,29 @@ import           Language.LSP.VFS                hiding (line)
 -- * 1. Mapping semantic token type to and from the LSP default token type.
 
 -- | map from haskell semantic token type to LSP default token type
-toLspTokenType :: HsSemanticTokenType -> SemanticTokenTypes
-toLspTokenType tk = case tk of
-  -- Function type variable
-  TFunction     -> SemanticTokenTypes_Function
-  -- None function type variable
-  TVariable     -> SemanticTokenTypes_Variable
-  TClass        -> SemanticTokenTypes_Class
-  TClassMethod  -> SemanticTokenTypes_Method
-  TTypeVariable -> SemanticTokenTypes_TypeParameter
-  -- normal data type is a tagged union type look like enum type
-  -- and a record is a product type like struct
-  -- but we don't distinguish them yet
-  TTypeCon      -> SemanticTokenTypes_Enum
-  TDataCon      -> SemanticTokenTypes_EnumMember
-  TRecField     -> SemanticTokenTypes_Property
-  -- pattern syn is like a limited version of macro of constructing a term
-  TPatternSyn   -> SemanticTokenTypes_Macro
-  -- saturated type
-  TTypeSyn      -> SemanticTokenTypes_Type
-  -- not sure if this is correct choice
-  TTypeFamily   -> SemanticTokenTypes_Interface
-
-lspTokenReverseMap :: Map.Map SemanticTokenTypes HsSemanticTokenType
-lspTokenReverseMap = Map.fromList $ map (\x -> (toLspTokenType x, x)) $ enumFrom minBound
-
-fromLspTokenType :: SemanticTokenTypes -> Maybe HsSemanticTokenType
-fromLspTokenType tk = Map.lookup tk lspTokenReverseMap
+toLspTokenType :: SemanticTokensConfig  -> HsSemanticTokenType -> SemanticTokenTypes
+toLspTokenType conf tk = case tk of
+  TFunction        -> stFunction conf
+  TVariable        -> stVariable conf
+  TClassMethod     -> stClassMethod conf
+  TTypeVariable    -> stTypeVariable conf
+  TDataConstructor -> stDataConstructor conf
+  TClass           -> stClass conf
+  TTypeConstructor -> stTypeConstructor conf
+  TTypeSynonym     -> stTypeSynonym conf
+  TTypeFamily      -> stTypeFamily conf
+  TRecordField     -> stRecordField conf
+  TPatternSynonym  -> stPatternSynonym conf
+
+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
+
+lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
+lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)
 
 -- * 2. Mapping from GHC type and tyThing to semantic token type.
 
@@ -67,19 +63,19 @@ tyThingSemantic :: TyThing -> Maybe HsSemanticTokenType
 tyThingSemantic ty = case ty of
   AnId vid
     | isTyVar vid -> Just TTypeVariable
-    | isRecordSelector vid -> Just TRecField
+    | isRecordSelector vid -> Just TRecordField
     | isClassOpId vid -> Just TClassMethod
     | isFunVar vid -> Just TFunction
     | otherwise -> Just TVariable
   AConLike con -> case con of
-    RealDataCon _ -> Just TDataCon
-    PatSynCon _   -> Just TPatternSyn
+    RealDataCon _ -> Just TDataConstructor
+    PatSynCon _   -> Just TPatternSynonym
   ATyCon tyCon
-    | isTypeSynonymTyCon tyCon -> Just TTypeSyn
+    | isTypeSynonymTyCon tyCon -> Just TTypeSynonym
     | isTypeFamilyTyCon tyCon -> Just TTypeFamily
     | isClassTyCon tyCon -> Just TClass
-    -- fall back to TTypeCon the result
-    | otherwise -> Just TTypeCon
+    -- fall back to TTypeConstructor the result
+    | otherwise -> Just TTypeConstructor
   ACoAxiom _ -> Nothing
   where
     isFunVar :: Var -> Bool
@@ -143,36 +139,53 @@ infoTokenType x = case x of
   PatternBind {}           -> Just TVariable
   ClassTyDecl _            -> Just TClassMethod
   TyVarBind _ _            -> Just TTypeVariable
-  RecField _ _             -> Just TRecField
+  RecField _ _             -> Just TRecordField
   -- data constructor, type constructor, type synonym, type family
   Decl ClassDec _          -> Just TClass
-  Decl DataDec _           -> Just TTypeCon
-  Decl ConDec _            -> Just TDataCon
-  Decl SynDec _            -> Just TTypeSyn
+  Decl DataDec _           -> Just TTypeConstructor
+  Decl ConDec _            -> Just TDataConstructor
+  Decl SynDec _            -> Just TTypeSynonym
   Decl FamDec _            -> Just TTypeFamily
   -- instance dec is class method
   Decl InstDec _           -> Just TClassMethod
-  Decl PatSynDec _         -> Just TPatternSyn
+  Decl PatSynDec _         -> Just TPatternSynonym
   EvidenceVarUse           -> Nothing
   EvidenceVarBind {}       -> Nothing
 
 -- * 4. Mapping from LSP tokens to SemanticTokenOriginal.
 
--- | line, startChar, len, tokenType, modifiers
-type ActualToken = (UInt, UInt, UInt, HsSemanticTokenType, UInt)
-
 -- | recoverSemanticTokens
 -- 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)
-recoverSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal]
-recoverSemanticTokens vsf (SemanticTokens _ xs) = 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 (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 config (SemanticTokenOriginal tokenType location name) =
+        case lspTokenTypeHsTokenType config tokenType of
+        Just t  -> SemanticTokenOriginal t location name
+        Nothing -> error "recoverSemanticTokens: unknown lsp token type"
+
+-- | recoverLspSemanticTokens
+-- for debug and test.
+-- this function is used to recover the original tokens(with token in standard lsp token type zoon)
+-- from the lsp semantic tokens(with token in lsp token type zoon)
+recoverLspSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal SemanticTokenTypes]
+recoverLspSemanticTokens vsf (SemanticTokens _ xs) = do
   tokens <- dataActualToken xs
   return $ mapMaybe (tokenOrigin sourceCode) tokens
   where
     sourceCode = unpack $ virtualFileText vsf
-    tokenOrigin :: [Char] -> ActualToken -> Maybe SemanticTokenOriginal
-    tokenOrigin sourceCode' (line, startChar, len, tokenType, _) = do
+    tokenOrigin :: [Char] -> SemanticTokenAbsolute -> Maybe (SemanticTokenOriginal SemanticTokenTypes)
+    tokenOrigin sourceCode' (SemanticTokenAbsolute line startChar len tokenType _tokenModifiers) = do
       -- convert back to count from 1
       let range = mkRange line startChar len
       CodePointRange (CodePointPosition x y) (CodePointPosition _ y1) <- rangeToCodePointRange vsf range
@@ -183,20 +196,15 @@ recoverSemanticTokens vsf (SemanticTokens _ xs) = do
       let name = maybe "no source" (take (fromIntegral len') . drop (fromIntegral startChar')) tLine
       return $ SemanticTokenOriginal tokenType (Loc (line' + 1) (startChar' + 1) len') name
 
-    dataActualToken :: [UInt] -> Either Text [ActualToken]
+    dataActualToken :: [UInt] -> Either Text [SemanticTokenAbsolute]
     dataActualToken dt =
-      maybe decodeError (Right . fmap semanticTokenAbsoluteActualToken . absolutizeTokens) $
+      maybe decodeError (Right . absolutizeTokens) $
         mapM fromTuple (chunksOf 5 $ map fromIntegral dt)
       where
         decodeError = Left "recoverSemanticTokenRelative: wrong token data"
         fromTuple [a, b, c, d, _] = SemanticTokenRelative a b c <$> fromInt (fromIntegral d) <*> return []
         fromTuple _ = Nothing
 
-    semanticTokenAbsoluteActualToken :: SemanticTokenAbsolute -> ActualToken
-    semanticTokenAbsoluteActualToken (SemanticTokenAbsolute line startChar len tokenType _tokenModifiers) =
-      case fromLspTokenType tokenType of
-        Just t  -> (line, startChar, len, t, 0)
-        Nothing -> error "semanticTokenAbsoluteActualToken: unknown token type"
 
     -- legends :: SemanticTokensLegend
     fromInt :: Int -> Maybe SemanticTokenTypes