Skip to content

Commit 188b82b

Browse files
MangoIVMangoIV
committed
[wip]
1 parent 2c200b4 commit 188b82b

File tree

8 files changed

+139
-49
lines changed

8 files changed

+139
-49
lines changed

‎haskell-language-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1729,6 +1729,7 @@ library hls-semantic-tokens-plugin
17291729
, containers
17301730
, extra
17311731
, text-rope
1732+
, ghc
17321733
, mtl >= 2.2
17331734
, ghcide == 2.11.0.0
17341735
, hls-plugin-api == 2.11.0.0

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ descriptor recorder plId =
1515
{ Ide.Types.pluginHandlers =
1616
mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder)
1717
<> mkPluginHandler SMethod_TextDocumentSemanticTokensFullDelta (Internal.semanticTokensFullDelta recorder),
18-
Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder,
18+
Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder <> Internal.getSyntacticTokensRule recorder,
1919
pluginConfigDescriptor =
2020
defaultConfigDescriptor
2121
{ configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False}

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

Lines changed: 55 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -7,10 +7,17 @@
77
{-# LANGUAGE TemplateHaskell #-}
88
{-# LANGUAGE TypeFamilies #-}
99
{-# LANGUAGE UnicodeSyntax #-}
10+
{-# LANGUAGE ImpredicativeTypes #-}
11+
{-# LANGUAGE LiberalTypeSynonyms #-}
12+
{-# LANGUAGE BlockArguments #-}
13+
{-# LANGUAGE MultiWayIf #-}
14+
{-# LANGUAGE PatternSynonyms #-}
15+
{-# LANGUAGE RequiredTypeArguments #-}
16+
{-# LANGUAGE ViewPatterns #-}
1017

1118
-- |
1219
-- This module provides the core functionality of the plugin.
13-
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where
20+
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, getSyntacticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where
1421

1522
import Control.Concurrent.STM (stateTVar)
1623
import Control.Concurrent.STM.Stats (atomically)
@@ -33,7 +40,7 @@ import Development.IDE (Action,
3340
WithPriority,
3441
cmapWithPrio, define,
3542
fromNormalizedFilePath,
36-
hieKind)
43+
hieKind, GetParsedModuleWithComments (..), srcSpanToRange)
3744
import Development.IDE.Core.PluginUtils (runActionE, useE,
3845
useWithStaleE)
3946
import Development.IDE.Core.Rules (toIdeResult)
@@ -59,9 +66,20 @@ import Language.LSP.Protocol.Message (MessageResult,
5966
Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))
6067
import Language.LSP.Protocol.Types (NormalizedFilePath,
6168
SemanticTokens,
62-
type (|?) (InL, InR))
69+
type (|?) (InL, InR), Range)
6370
import Prelude hiding (span)
6471
import qualified StmContainers.Map as STM
72+
import Type.Reflection
73+
( Typeable,
74+
type (:~~:)(HRefl),
75+
pattern App,
76+
eqTypeRep,
77+
typeOf,
78+
typeRep,
79+
withTypeable )
80+
import Data.Data (Data (..))
81+
import GHC.Parser.Annotation
82+
import Data.Maybe
6583

6684

6785
$mkSemanticConfigFunctions
@@ -75,8 +93,9 @@ computeSemanticTokens recorder pid _ nfp = do
7593
config <- lift $ useSemanticConfigAction pid
7694
logWith recorder Debug (LogConfig config)
7795
semanticId <- lift getAndIncreaseSemanticTokensId
78-
(RangeHsSemanticTokenTypes {rangeSemanticList}, mapping) <- useWithStaleE GetSemanticTokens nfp
79-
withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList
96+
(RangeHsSemanticTokenTypes {rangeSemanticList}, _mapping) <- useWithStaleE GetSemanticTokens nfp
97+
(RangeHsSyntacticTokenTypes {rangeSyntacticList}, mapping) <- useWithStaleE GetSyntacticTokens nfp
98+
withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping $ map (fmap HsSemanticTokenType) rangeSemanticList <> map (fmap HsSyntacticTokenType) rangeSyntacticList
8099

81100
semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
82101
semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull
@@ -130,6 +149,37 @@ getSemanticTokensRule recorder =
130149
let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap
131150
return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast
132151

152+
getSyntacticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()
153+
getSyntacticTokensRule recorder =
154+
define (cmapWithPrio LogShake recorder) $ \GetSyntacticTokens nfp -> handleError recorder $ do
155+
(parsedModule, positionMapping) <- withExceptT LogDependencyError $ useWithStaleE GetParsedModuleWithComments nfp
156+
pure $ computeRangeHsSyntacticTokenTypeList parsedModule
157+
158+
getLocated's :: forall l a. (Data a, Typeable l) => a -> [GenLocated l (forall r. (forall b. Typeable b => b -> r) -> r)]
159+
getLocated's = mconcat . gmapQ \y -> if
160+
| App con rep <- typeOf y
161+
, Just HRefl <- eqTypeRep con (typeRep @(GenLocated l))
162+
, L l a <- y
163+
-> withTypeable rep $ L l (\k -> k a) : getLocated's y
164+
| otherwise -> getLocated's y
165+
166+
pattern IsA :: forall b t. (Typeable b, Typeable t) => forall. b ~ t => b -> t
167+
pattern IsA x <- ((\y -> (y, eqTypeRep (typeRep @b) (typeOf y))) -> (x, Just HRefl))
168+
169+
mkFromLocatedNode :: GenLocated SrcSpanAnnA (forall r. (forall b. Typeable b => b -> r) -> r) -> Maybe (Range, HsSyntacticTokenType)
170+
mkFromLocatedNode (L ann w) = w \node -> case node of
171+
IsA @(HsExpr GhcPs) expr -> case expr of
172+
HsLet {} -> let
173+
mrange = srcSpanToRange $ getLoc ann
174+
in (, TKeyword) <$> mrange
175+
_ -> Nothing
176+
_ -> Nothing
177+
178+
computeRangeHsSyntacticTokenTypeList :: ParsedModule -> RangeHsSyntacticTokenTypes
179+
computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
180+
let locs = getLocated's @SrcSpanAnnA pm_parsed_source
181+
toks = mapMaybe mkFromLocatedNode locs
182+
in RangeHsSyntacticTokenTypes toks
133183

134184
-- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs
135185

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

Lines changed: 18 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -39,28 +39,31 @@ nameInfixOperator _ = Nothing
3939
-- * 1. Mapping semantic token type to and from the LSP default token type.
4040

4141
-- | map from haskell semantic token type to LSP default token type
42-
toLspTokenType :: SemanticTokensConfig -> HsSemanticTokenType -> SemanticTokenTypes
42+
toLspTokenType :: SemanticTokensConfig -> HsTokenType -> SemanticTokenTypes
4343
toLspTokenType conf tk = case tk of
44-
TFunction -> stFunction conf
45-
TVariable -> stVariable conf
46-
TClassMethod -> stClassMethod conf
47-
TTypeVariable -> stTypeVariable conf
48-
TDataConstructor -> stDataConstructor conf
49-
TClass -> stClass conf
50-
TTypeConstructor -> stTypeConstructor conf
51-
TTypeSynonym -> stTypeSynonym conf
52-
TTypeFamily -> stTypeFamily conf
53-
TRecordField -> stRecordField conf
54-
TPatternSynonym -> stPatternSynonym conf
55-
TModule -> stModule conf
56-
TOperator -> stOperator conf
44+
HsSemanticTokenType TFunction -> stFunction conf
45+
HsSemanticTokenType TVariable -> stVariable conf
46+
HsSemanticTokenType TClassMethod -> stClassMethod conf
47+
HsSemanticTokenType TTypeVariable -> stTypeVariable conf
48+
HsSemanticTokenType TDataConstructor -> stDataConstructor conf
49+
HsSemanticTokenType TClass -> stClass conf
50+
HsSemanticTokenType TTypeConstructor -> stTypeConstructor conf
51+
HsSemanticTokenType TTypeSynonym -> stTypeSynonym conf
52+
HsSemanticTokenType TTypeFamily -> stTypeFamily conf
53+
HsSemanticTokenType TRecordField -> stRecordField conf
54+
HsSemanticTokenType TPatternSynonym -> stPatternSynonym conf
55+
HsSemanticTokenType TModule -> stModule conf
56+
HsSemanticTokenType TOperator -> stOperator conf
57+
HsSyntacticTokenType TKeyword -> stKeyword conf
58+
HsSyntacticTokenType TComment -> stComment conf
59+
HsSyntacticTokenType TStringLit -> stStringLit conf
5760

5861
lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
5962
lspTokenReverseMap config
6063
| length xs /= Map.size mr = error "lspTokenReverseMap: token type mapping is not bijection"
6164
| otherwise = mr
6265
where xs = enumFrom minBound
63-
mr = Map.fromList $ map (\x -> (toLspTokenType config x, x)) xs
66+
mr = Map.fromList $ map (\x -> (toLspTokenType config (HsSemanticTokenType x), x)) xs
6467

6568
lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
6669
lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind,
1616
HsSemanticTokenType (TModule),
1717
RangeSemanticTokenTypeList,
1818
SemanticTokenId,
19-
SemanticTokensConfig)
19+
SemanticTokensConfig, HsTokenType)
2020
import Language.LSP.Protocol.Types (Position (Position),
2121
Range (Range),
2222
SemanticTokenAbsolute (SemanticTokenAbsolute),
@@ -66,11 +66,11 @@ nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n)
6666

6767
-------------------------------------------------
6868

69-
rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens
69+
rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> [(Range, HsTokenType)] -> Either Text SemanticTokens
7070
rangeSemanticsSemanticTokens sid stc mapping =
7171
makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk)
7272
where
73-
toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute
73+
toAbsSemanticToken :: Range -> HsTokenType -> SemanticTokenAbsolute
7474
toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType =
7575
let len = endColumn - startColumn
7676
in SemanticTokenAbsolute

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

Lines changed: 26 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -26,21 +26,24 @@ import Language.Haskell.TH
2626
import Language.LSP.Protocol.Types (LspEnum (..),
2727
SemanticTokenTypes)
2828

29-
docName :: HsSemanticTokenType -> T.Text
29+
docName :: HsTokenType -> T.Text
3030
docName tt = case tt of
31-
TVariable -> "variables"
32-
TFunction -> "functions"
33-
TDataConstructor -> "data constructors"
34-
TTypeVariable -> "type variables"
35-
TClassMethod -> "typeclass methods"
36-
TPatternSynonym -> "pattern synonyms"
37-
TTypeConstructor -> "type constructors"
38-
TClass -> "typeclasses"
39-
TTypeSynonym -> "type synonyms"
40-
TTypeFamily -> "type families"
41-
TRecordField -> "record fields"
42-
TModule -> "modules"
43-
TOperator -> "operators"
31+
HsSemanticTokenType TVariable -> "variables"
32+
HsSemanticTokenType TFunction -> "functions"
33+
HsSemanticTokenType TDataConstructor -> "data constructors"
34+
HsSemanticTokenType TTypeVariable -> "type variables"
35+
HsSemanticTokenType TClassMethod -> "typeclass methods"
36+
HsSemanticTokenType TPatternSynonym -> "pattern synonyms"
37+
HsSemanticTokenType TTypeConstructor -> "type constructors"
38+
HsSemanticTokenType TClass -> "typeclasses"
39+
HsSemanticTokenType TTypeSynonym -> "type synonyms"
40+
HsSemanticTokenType TTypeFamily -> "type families"
41+
HsSemanticTokenType TRecordField -> "record fields"
42+
HsSemanticTokenType TModule -> "modules"
43+
HsSemanticTokenType TOperator -> "operators"
44+
HsSyntacticTokenType TKeyword -> "keyword"
45+
HsSyntacticTokenType TStringLit -> "string literal"
46+
HsSyntacticTokenType TComment -> "comment"
4447

4548
toConfigName :: String -> String
4649
toConfigName = ("st" <>)
@@ -55,15 +58,21 @@ lspTokenTypeDescriptions =
5558
)
5659
$ S.toList knownValues
5760

58-
allHsTokenTypes :: [HsSemanticTokenType]
59-
allHsTokenTypes = enumFrom minBound
61+
allHsTokenTypes :: [HsTokenType]
62+
allHsTokenTypes = map HsSemanticTokenType (enumFrom minBound) <> map HsSyntacticTokenType (enumFrom minBound)
6063

6164
lowerFirst :: String -> String
6265
lowerFirst [] = []
6366
lowerFirst (x : xs) = toLower x : xs
6467

68+
-- TODO: drop the "syntax/semanticness" before showing
6569
allHsTokenNameStrings :: [String]
66-
allHsTokenNameStrings = map (drop 1 . show) allHsTokenTypes
70+
allHsTokenNameStrings = map (unwrap $ drop 1 . show) allHsTokenTypes
71+
where
72+
unwrap :: (forall a. Show a => a -> String) -> HsTokenType -> String
73+
unwrap k tt' = case tt' of
74+
HsSemanticTokenType tt -> k tt
75+
HsSyntacticTokenType tt -> k tt
6776

6877
defineSemanticProperty ::
6978
(NotElem s r, KnownSymbol s) =>

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

Lines changed: 2 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -3,11 +3,8 @@
33

44
module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where
55

6-
import Control.Lens (Identity (runIdentity))
76
import Control.Monad (foldM, guard)
8-
import Control.Monad.State.Strict (MonadState (get),
9-
MonadTrans (lift),
10-
evalStateT, modify, put)
7+
import Control.Monad.State.Strict (MonadState (get), MonadTrans (lift), modify, put, evalState)
118
import Control.Monad.Trans.State.Strict (StateT, runStateT)
129
import Data.Char (isAlphaNum)
1310
import Data.DList (DList)
@@ -72,7 +69,7 @@ foldMapM f ta = foldM (\b a -> mappend b <$> f a) mempty ta
7269

7370
computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes
7471
computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast =
75-
RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst lookupHsTokenType ast) (mkPTokenState vf)
72+
RangeHsSemanticTokenTypes $ DL.toList $ evalState (foldAst lookupHsTokenType ast) (mkPTokenState vf)
7673
-- | foldAst
7774
-- visit every leaf node in the ast in depth first order
7875
foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))

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

Lines changed: 33 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE OverloadedStrings #-}
55
{-# LANGUAGE StrictData #-}
66
{-# LANGUAGE TypeFamilies #-}
7+
{-# LANGUAGE DeriveAnyClass #-}
78

89
module Ide.Plugin.SemanticTokens.Types where
910

@@ -39,12 +40,26 @@ data HsSemanticTokenType
3940
| TRecordField -- from match bind
4041
| TOperator-- operator
4142
| TModule -- module name
42-
deriving (Eq, Ord, Show, Enum, Bounded, Generic, Lift)
43+
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic, Lift)
44+
45+
data HsSyntacticTokenType
46+
= TKeyword
47+
| TComment
48+
| TStringLit
49+
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic, Lift)
50+
51+
data HsTokenType =
52+
HsSyntacticTokenType HsSyntacticTokenType
53+
| HsSemanticTokenType HsSemanticTokenType
54+
deriving stock (Eq, Ord, Show, Generic, Lift)
4355

4456
-- type SemanticTokensConfig = SemanticTokensConfig_ Identity
4557
instance Default SemanticTokensConfig where
4658
def = STC
47-
{ stFunction = SemanticTokenTypes_Function
59+
{ stKeyword = SemanticTokenTypes_Keyword
60+
, stComment = SemanticTokenTypes_Comment
61+
, stStringLit = SemanticTokenTypes_String
62+
, stFunction = SemanticTokenTypes_Function
4863
, stVariable = SemanticTokenTypes_Variable
4964
, stDataConstructor = SemanticTokenTypes_EnumMember
5065
, stTypeVariable = SemanticTokenTypes_TypeParameter
@@ -65,7 +80,10 @@ instance Default SemanticTokensConfig where
6580
-- | SemanticTokensConfig_ is a configuration for the semantic tokens plugin.
6681
-- it contains map between the hs semantic token type and default token type.
6782
data SemanticTokensConfig = STC
68-
{ stFunction :: !SemanticTokenTypes
83+
{ stStringLit :: !SemanticTokenTypes
84+
, stComment :: !SemanticTokenTypes
85+
, stKeyword :: !SemanticTokenTypes
86+
, stFunction :: !SemanticTokenTypes
6987
, stVariable :: !SemanticTokenTypes
7088
, stDataConstructor :: !SemanticTokenTypes
7189
, stTypeVariable :: !SemanticTokenTypes
@@ -113,6 +131,18 @@ instance Hashable GetSemanticTokens
113131

114132
instance NFData GetSemanticTokens
115133

134+
data GetSyntacticTokens = GetSyntacticTokens
135+
deriving stock (Eq, Show, Generic)
136+
deriving anyclass (Hashable, NFData)
137+
138+
newtype RangeHsSyntacticTokenTypes = RangeHsSyntacticTokenTypes {rangeSyntacticList :: [(Range, HsSyntacticTokenType)]}
139+
instance NFData RangeHsSyntacticTokenTypes where rnf = rwhnf
140+
141+
instance Show RangeHsSyntacticTokenTypes where
142+
show = unlines . map (\(r, tk) -> showRange r <> " " <> show tk) . rangeSyntacticList
143+
144+
type instance RuleResult GetSyntacticTokens = RangeHsSyntacticTokenTypes
145+
116146
type RangeSemanticTokenTypeList = [(Range, HsSemanticTokenType)]
117147

118148
newtype RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemanticList :: RangeSemanticTokenTypeList}

0 commit comments

Comments
 (0)