Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 1bde91a

Browse files
committed
[feat] syntactic syntactic tokens
Use the GHC AST and lsp semantic tokens to convince the language server to give highlighting even without any editor highlighting plugins.
1 parent b8c9b84 commit 1bde91a

File tree

5 files changed

+209
-36
lines changed

5 files changed

+209
-36
lines changed

‎ghcide/src/Development/IDE/GHC/Compat/Core.hs

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -630,11 +630,37 @@ instance HasSrcSpan SrcSpan where
630630
instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where
631631
getLoc = GHC.getLoc
632632

633+
#if MIN_VERSION_ghc(9,11,0)
634+
instance HasSrcSpan (GHC.EpToken sym) where
635+
getLoc = GHC.getHasLoc
636+
#else
637+
instance HasSrcSpan (GHC.EpToken sym) where
638+
getLoc = GHC.getHasLoc . \case
639+
GHC.NoEpTok -> Nothing
640+
GHC.EpTok loc -> Just loc
641+
#endif
642+
633643
#if MIN_VERSION_ghc(9,9,0)
634644
instance HasSrcSpan (EpAnn a) where
635645
getLoc = GHC.getHasLoc
636646
#endif
637647

648+
#if !MIN_VERSION_ghc(9,11,0)
649+
instance HasSrcSpan GHC.AddEpAnn where
650+
getLoc (GHC.AddEpAnn _ loc) = getLoc loc
651+
652+
instance HasSrcSpan GHC.EpaLocation where
653+
getLoc loc = GHC.getHasLoc loc
654+
#endif
655+
656+
#if !MIN_VERSION_ghc(9,11,0)
657+
instance HasSrcSpan GHC.LEpaComment where
658+
getLoc :: GHC.LEpaComment -> SrcSpan
659+
getLoc (GHC.L l _) = case l of
660+
SrcLoc.EpaDelta {} -> panic "compiler inserted epadelta into NoCommentsLocation"
661+
SrcLoc.EpaSpan span -> span
662+
#endif
663+
638664
#if MIN_VERSION_ghc(9,9,0)
639665
instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where
640666
getLoc (L l _) = getLoc l

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,7 @@ descriptor recorder plId =
1818
Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder,
1919
pluginConfigDescriptor =
2020
defaultConfigDescriptor
21-
{ configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False}
21+
{ configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = True}
2222
, configCustomConfig = mkCustomConfig Internal.semanticConfigProperties
2323
}
2424
}

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

Lines changed: 128 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,19 @@
1-
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE DerivingStrategies #-}
3-
{-# LANGUAGE OverloadedLabels #-}
4-
{-# LANGUAGE OverloadedRecordDot #-}
5-
{-# LANGUAGE OverloadedStrings #-}
6-
{-# LANGUAGE RecordWildCards #-}
7-
{-# LANGUAGE TemplateHaskell #-}
8-
{-# LANGUAGE TypeFamilies #-}
9-
{-# LANGUAGE UnicodeSyntax #-}
1+
{-# LANGUAGE BlockArguments #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE DerivingStrategies #-}
4+
{-# LANGUAGE ImpredicativeTypes #-}
5+
{-# LANGUAGE LiberalTypeSynonyms #-}
6+
{-# LANGUAGE MultiWayIf #-}
7+
{-# LANGUAGE OverloadedLabels #-}
8+
{-# LANGUAGE OverloadedRecordDot #-}
9+
{-# LANGUAGE OverloadedStrings #-}
10+
{-# LANGUAGE PatternSynonyms #-}
11+
{-# LANGUAGE QuantifiedConstraints #-}
12+
{-# LANGUAGE RecordWildCards #-}
13+
{-# LANGUAGE TemplateHaskell #-}
14+
{-# LANGUAGE TypeFamilies #-}
15+
{-# LANGUAGE UnicodeSyntax #-}
16+
{-# LANGUAGE ViewPatterns #-}
1017

1118
-- |
1219
-- This module provides the core functionality of the plugin.
@@ -20,20 +27,28 @@ import Control.Monad.Except (ExceptT, liftEither,
2027
import Control.Monad.IO.Class (MonadIO (..))
2128
import Control.Monad.Trans (lift)
2229
import Control.Monad.Trans.Except (runExceptT)
30+
import Control.Monad.Trans.Maybe
31+
import Data.Data (Data (..))
32+
import Data.List
2333
import qualified Data.Map.Strict as M
34+
import Data.Maybe
35+
import Data.Semigroup (First (..))
2436
import Data.Text (Text)
2537
import qualified Data.Text as T
2638
import Development.IDE (Action,
2739
GetDocMap (GetDocMap),
2840
GetHieAst (GetHieAst),
41+
GetParsedModuleWithComments (..),
2942
HieAstResult (HAR, hieAst, hieModule, refMap),
3043
IdeResult, IdeState,
3144
Priority (..),
3245
Recorder, Rules,
3346
WithPriority,
3447
cmapWithPrio, define,
35-
fromNormalizedFilePath,
36-
hieKind)
48+
hieKind,
49+
srcSpanToRange,
50+
toNormalizedUri,
51+
useWithStale)
3752
import Development.IDE.Core.PluginUtils (runActionE, useE,
3853
useWithStaleE)
3954
import Development.IDE.Core.Rules (toIdeResult)
@@ -43,9 +58,9 @@ import Development.IDE.Core.Shake (ShakeExtras (..),
4358
getVirtualFile)
4459
import Development.IDE.GHC.Compat hiding (Warning)
4560
import Development.IDE.GHC.Compat.Util (mkFastString)
61+
import GHC.Parser.Annotation
4662
import Ide.Logger (logWith)
47-
import Ide.Plugin.Error (PluginError (PluginInternalError),
48-
getNormalizedFilePathE,
63+
import Ide.Plugin.Error (PluginError (PluginInternalError, PluginRuleFailed),
4964
handleMaybe,
5065
handleMaybeM)
5166
import Ide.Plugin.SemanticTokens.Mappings
@@ -57,11 +72,18 @@ import Ide.Types
5772
import qualified Language.LSP.Protocol.Lens as L
5873
import Language.LSP.Protocol.Message (MessageResult,
5974
Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))
60-
import Language.LSP.Protocol.Types (NormalizedFilePath,
75+
import Language.LSP.Protocol.Types (NormalizedUri, Range,
6176
SemanticTokens,
77+
fromNormalizedUri,
78+
getUri,
6279
type (|?) (InL, InR))
6380
import Prelude hiding (span)
6481
import qualified StmContainers.Map as STM
82+
import Type.Reflection (Typeable, eqTypeRep,
83+
pattern App,
84+
type (:~~:) (HRefl),
85+
typeOf, typeRep,
86+
withTypeable)
6587

6688

6789
$mkSemanticConfigFunctions
@@ -75,8 +97,17 @@ computeSemanticTokens recorder pid _ nfp = do
7597
config <- lift $ useSemanticConfigAction pid
7698
logWith recorder Debug (LogConfig config)
7799
semanticId <- lift getAndIncreaseSemanticTokensId
78-
(RangeHsSemanticTokenTypes {rangeSemanticList}, mapping) <- useWithStaleE GetSemanticTokens nfp
79-
withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList
100+
101+
(sortOn fst -> tokenList, First mapping) <- do
102+
rangesyntacticTypes <- lift $ useWithStale GetSyntacticTokens nuri
103+
rangesemanticTypes <- lift $ useWithStale GetSemanticTokens nuri
104+
let mk w u (toks, mapping) = (map (fmap w) $ u toks, First mapping)
105+
maybeToExceptT (PluginRuleFailed "no syntactic nor semantic tokens") $ hoistMaybe $
106+
(mk HsSyntacticTokenType rangeSyntacticList <$> rangesyntacticTypes)
107+
<> (mk HsSemanticTokenType rangeSemanticList <$> rangesemanticTypes)
108+
109+
-- NOTE: rangeSemanticsSemanticTokens actually assumes that the tokesn are in order. that means they have to be sorted by position
110+
withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping tokenList
80111

81112
semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
82113
semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull
@@ -130,6 +161,87 @@ getSemanticTokensRule recorder =
130161
let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap
131162
return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast
132163

164+
getSyntacticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()
165+
getSyntacticTokensRule recorder =
166+
define (cmapWithPrio LogShake recorder) $ \GetSyntacticTokens nfp -> handleError recorder $ do
167+
(parsedModule, _) <- withExceptT LogDependencyError $ useWithStaleE GetParsedModuleWithComments nfp
168+
let tokList = computeRangeHsSyntacticTokenTypeList parsedModule
169+
logWith recorder Debug $ LogSyntacticTokens tokList
170+
pure tokList
171+
172+
astTraversalWith :: forall b r. Data b => b -> (forall a. Data a => a -> [r]) -> [r]
173+
astTraversalWith ast f = mconcat $ flip gmapQ ast \y -> f y <> astTraversalWith y f
174+
175+
{-# inline extractTyToTy #-}
176+
extractTyToTy :: forall f a. (Typeable f, Data a) => a -> Maybe (forall r. (forall b. Typeable b => f b -> r) -> r)
177+
extractTyToTy node
178+
| App conRep argRep <- typeOf node
179+
, Just HRefl <- eqTypeRep conRep (typeRep @f)
180+
= Just $ withTypeable argRep $ (\k -> k node)
181+
| otherwise = Nothing
182+
183+
{-# inline extractTy #-}
184+
extractTy :: forall b a. (Typeable b, Data a) => a -> Maybe b
185+
extractTy node
186+
| Just HRefl <- eqTypeRep (typeRep @b) (typeOf node)
187+
= Just node
188+
| otherwise = Nothing
189+
190+
computeRangeHsSyntacticTokenTypeList :: ParsedModule -> RangeHsSyntacticTokenTypes
191+
computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
192+
let toks = astTraversalWith pm_parsed_source \node -> mconcat
193+
[ maybeToList $ mkFromLocatable TKeyword . (\k -> k \x k' -> k' x) =<< extractTyToTy @EpToken node
194+
-- FIXME: probably needs to be commented out for ghc > 9.10
195+
, maybeToList $ mkFromLocatable TKeyword . (\x k -> k x) =<< extractTy @AddEpAnn node
196+
, do
197+
EpAnnImportDecl i p s q pkg a <- maybeToList $ extractTy @EpAnnImportDecl node
198+
199+
mapMaybe (mkFromLocatable TKeyword . (\x k -> k x)) $ catMaybes $ [Just i, s, q, pkg, a] <> foldMap (\(l, l') -> [Just l, Just l']) p
200+
, maybeToList $ mkFromLocatable TComment . (\x k -> k x) =<< extractTy @LEpaComment node
201+
, do
202+
L loc expr <- maybeToList $ extractTy @(LHsExpr GhcPs) node
203+
let fromSimple = maybeToList . flip mkFromLocatable \k -> k loc
204+
case expr of
205+
HsOverLabel {} -> fromSimple TStringLit
206+
HsOverLit _ (OverLit _ lit) -> fromSimple case lit of
207+
HsIntegral {} -> TNumberLit
208+
HsFractional {} -> TNumberLit
209+
210+
HsIsString {} -> TStringLit
211+
HsLit _ lit -> fromSimple case lit of
212+
HsChar {} -> TCharLit
213+
HsCharPrim {} -> TCharLit
214+
215+
HsInt {} -> TNumberLit
216+
HsInteger {} -> TNumberLit
217+
HsIntPrim {} -> TNumberLit
218+
HsWordPrim {} -> TNumberLit
219+
HsWord8Prim {} -> TNumberLit
220+
HsWord16Prim {} -> TNumberLit
221+
HsWord32Prim {} -> TNumberLit
222+
HsWord64Prim {} -> TNumberLit
223+
HsInt8Prim {} -> TNumberLit
224+
HsInt16Prim {} -> TNumberLit
225+
HsInt32Prim {} -> TNumberLit
226+
HsInt64Prim {} -> TNumberLit
227+
HsFloatPrim {} -> TNumberLit
228+
HsDoublePrim {} -> TNumberLit
229+
HsRat {} -> TNumberLit
230+
231+
HsString {} -> TStringLit
232+
HsStringPrim {} -> TStringLit
233+
HsGetField _ _ field -> maybeToList $ mkFromLocatable TRecordSelector \k -> k field
234+
HsProjection _ projs -> foldMap (\proj -> maybeToList $ mkFromLocatable TRecordSelector \k -> k proj) projs
235+
_ -> []
236+
]
237+
in RangeHsSyntacticTokenTypes toks
238+
239+
{-# inline mkFromLocatable #-}
240+
mkFromLocatable
241+
:: HsSyntacticTokenType
242+
-> (forall r. (forall a. HasSrcSpan a => a -> r) -> r)
243+
-> Maybe (Range, HsSyntacticTokenType)
244+
mkFromLocatable tt w = w \tok -> let mrange = srcSpanToRange $ getLoc tok in fmap (, tt) mrange
133245

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

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

Lines changed: 22 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@
1313
module Ide.Plugin.SemanticTokens.Mappings where
1414

1515
import qualified Data.Array as A
16+
import Data.Function
1617
import Data.List.Extra (chunksOf, (!?))
1718
import qualified Data.Map.Strict as Map
1819
import Data.Maybe (mapMaybe)
@@ -39,21 +40,27 @@ nameInfixOperator _ = Nothing
3940
-- * 1. Mapping semantic token type to and from the LSP default token type.
4041

4142
-- | map from haskell semantic token type to LSP default token type
42-
toLspTokenType :: SemanticTokensConfig -> HsSemanticTokenType -> SemanticTokenTypes
43-
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
43+
toLspTokenType :: SemanticTokensConfig -> HsTokenType -> SemanticTokenTypes
44+
toLspTokenType conf tk = conf & case tk of
45+
HsSemanticTokenType TFunction -> stFunction
46+
HsSemanticTokenType TVariable -> stVariable
47+
HsSemanticTokenType TClassMethod -> stClassMethod
48+
HsSemanticTokenType TTypeVariable -> stTypeVariable
49+
HsSemanticTokenType TDataConstructor -> stDataConstructor
50+
HsSemanticTokenType TClass -> stClass
51+
HsSemanticTokenType TTypeConstructor -> stTypeConstructor
52+
HsSemanticTokenType TTypeSynonym -> stTypeSynonym
53+
HsSemanticTokenType TTypeFamily -> stTypeFamily
54+
HsSemanticTokenType TRecordField -> stRecordField
55+
HsSemanticTokenType TPatternSynonym -> stPatternSynonym
56+
HsSemanticTokenType TModule -> stModule
57+
HsSemanticTokenType TOperator -> stOperator
58+
HsSyntacticTokenType TKeyword -> stKeyword
59+
HsSyntacticTokenType TComment -> stComment
60+
HsSyntacticTokenType TStringLit -> stStringLit
61+
HsSyntacticTokenType TCharLit -> stCharLit
62+
HsSyntacticTokenType TNumberLit -> stNumberLit
63+
HsSyntacticTokenType TRecordSelector -> stRecordSelector
5764

5865
lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
5966
lspTokenReverseMap config

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

Lines changed: 32 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
23
{-# LANGUAGE DerivingVia #-}
34
{-# LANGUAGE GADTs #-}
45
{-# LANGUAGE OverloadedStrings #-}
@@ -39,12 +40,32 @@ 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+
| TCharLit
50+
| TNumberLit
51+
| TRecordSelector
52+
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic, Lift)
53+
54+
data HsTokenType =
55+
HsSyntacticTokenType HsSyntacticTokenType
56+
| HsSemanticTokenType HsSemanticTokenType
57+
deriving stock (Eq, Ord, Show, Generic, Lift)
4358

4459
-- type SemanticTokensConfig = SemanticTokensConfig_ Identity
4560
instance Default SemanticTokensConfig where
4661
def = STC
47-
{ stFunction = SemanticTokenTypes_Function
62+
{ stKeyword = SemanticTokenTypes_Keyword
63+
, stRecordSelector = SemanticTokenTypes_Property
64+
, stComment = SemanticTokenTypes_Comment
65+
, stStringLit = SemanticTokenTypes_String
66+
, stNumberLit = SemanticTokenTypes_Number
67+
, stCharLit = SemanticTokenTypes_String
68+
, stFunction = SemanticTokenTypes_Function
4869
, stVariable = SemanticTokenTypes_Variable
4970
, stDataConstructor = SemanticTokenTypes_EnumMember
5071
, stTypeVariable = SemanticTokenTypes_TypeParameter
@@ -65,7 +86,13 @@ instance Default SemanticTokensConfig where
6586
-- | SemanticTokensConfig_ is a configuration for the semantic tokens plugin.
6687
-- it contains map between the hs semantic token type and default token type.
6788
data SemanticTokensConfig = STC
68-
{ stFunction :: !SemanticTokenTypes
89+
{ stStringLit :: !SemanticTokenTypes
90+
, stCharLit :: !SemanticTokenTypes
91+
, stNumberLit :: !SemanticTokenTypes
92+
, stComment :: !SemanticTokenTypes
93+
, stKeyword :: !SemanticTokenTypes
94+
, stRecordSelector :: !SemanticTokenTypes
95+
, stFunction :: !SemanticTokenTypes
6996
, stVariable :: !SemanticTokenTypes
7097
, stDataConstructor :: !SemanticTokenTypes
7198
, stTypeVariable :: !SemanticTokenTypes
@@ -142,6 +169,7 @@ data SemanticLog
142169
| LogConfig SemanticTokensConfig
143170
| LogMsg String
144171
| LogNoVF
172+
| LogSyntacticTokens RangeHsSyntacticTokenTypes
145173
| LogSemanticTokensDeltaMisMatch Text (Maybe Text)
146174

147175
instance Pretty SemanticLog where
@@ -155,6 +183,6 @@ instance Pretty SemanticLog where
155183
-> "SemanticTokensDeltaMisMatch: previousIdFromRequest: " <> pretty previousIdFromRequest
156184
<> " previousIdFromCache: " <> pretty previousIdFromCache
157185
LogDependencyError err -> "SemanticTokens' dependency error: " <> pretty err
158-
186+
LogSyntacticTokens (RangeHsSyntacticTokenTypes synList) ->"Syntactic tokens: "<> pretty (show synList)
159187

160188
type SemanticTokenId = Text

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /