Skip to content

Commit

Permalink
add config for semantic-tokens-plugin for mapping from hs token type …
Browse files Browse the repository at this point in the history 
…to LSP default token type (#3940)

* add config for semantic tokens for mapping between hs token type to LSP default token type

* fix Missing features header

* Delete plugins/hls-semantic-tokens-plugin/test/testdata/TDatatype.hs

* Delete plugins/hls-semantic-tokens-plugin/test/testdata/TDatafamily.hs

* Delete plugins/hls-semantic-tokens-plugin/test/testdata/TPatternsyn.hs

* update doc

* fix ghc96 schema generation

* remove typedata and add ghc98 scheme generation test file

* Ajust case in mappings

* add ghc92 generate scheme

* add ghc94 generate scheme

* cleanup

* modify the lspTokenReverseMap to take semantic config

* rename fromLspTokenType to lspTokenTypeHsTokenType

* add description for semantic tokens mappings config

* fix doc and cleanup

* delete content for /test/testdata/schema for now, since we are modifying the configuration

* semantic config keys use lower case in the first element

* add config generation scheme test

* fix config generation scheme test

* ajust names for semantic tokens

* add token suffix to token type configuration

* cleanup

* fix merge
  • Loading branch information
@soulomoon
soulomoon authored Jan 14, 2024
1 parent b000b6b commit 1c62ba3
Show file tree
Hide file tree
Showing 38 changed files with 2,996 additions and 300 deletions.
2 changes: 1 addition & 1 deletion docs/features.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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!
Expand Down
6 changes: 6 additions & 0 deletions plugins/hls-semantic-tokens-plugin/hls-semantic-tokens-plugin.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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
Expand All @@ -83,3 +87,5 @@ test-suite tests
, bytestring
, ghcide == 2.5.0.0
, hls-plugin-api == 2.5.0.0
, template-haskell
, data-default
4 changes: 3 additions & 1 deletion plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Ide.Plugin.SemanticTokens (descriptor) where

Expand All @@ -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
}
}
108 changes: 56 additions & 52 deletions plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs
View file
Original file line number Diff line number Diff line change
@@ -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.
Expand Down
112 changes: 60 additions & 52 deletions plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.

Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
Loading

0 comments on commit 1c62ba3

Please sign in to comment.