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 e6621bc

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 e6621bc

File tree

5 files changed

+210
-36
lines changed

5 files changed

+210
-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: 129 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,29 @@ 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
38+
import Debug.Trace
2639
import Development.IDE (Action,
2740
GetDocMap (GetDocMap),
2841
GetHieAst (GetHieAst),
42+
GetParsedModuleWithComments (..),
2943
HieAstResult (HAR, hieAst, hieModule, refMap),
3044
IdeResult, IdeState,
3145
Priority (..),
3246
Recorder, Rules,
3347
WithPriority,
3448
cmapWithPrio, define,
35-
fromNormalizedFilePath,
36-
hieKind)
49+
hieKind,
50+
srcSpanToRange,
51+
toNormalizedUri,
52+
useWithStale)
3753
import Development.IDE.Core.PluginUtils (runActionE, useE,
3854
useWithStaleE)
3955
import Development.IDE.Core.Rules (toIdeResult)
@@ -43,9 +59,9 @@ import Development.IDE.Core.Shake (ShakeExtras (..),
4359
getVirtualFile)
4460
import Development.IDE.GHC.Compat hiding (Warning)
4561
import Development.IDE.GHC.Compat.Util (mkFastString)
62+
import GHC.Parser.Annotation
4663
import Ide.Logger (logWith)
47-
import Ide.Plugin.Error (PluginError (PluginInternalError),
48-
getNormalizedFilePathE,
64+
import Ide.Plugin.Error (PluginError (PluginInternalError, PluginRuleFailed),
4965
handleMaybe,
5066
handleMaybeM)
5167
import Ide.Plugin.SemanticTokens.Mappings
@@ -57,11 +73,18 @@ import Ide.Types
5773
import qualified Language.LSP.Protocol.Lens as L
5874
import Language.LSP.Protocol.Message (MessageResult,
5975
Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))
60-
import Language.LSP.Protocol.Types (NormalizedFilePath,
76+
import Language.LSP.Protocol.Types (NormalizedUri, Range,
6177
SemanticTokens,
78+
fromNormalizedUri,
79+
getUri,
6280
type (|?) (InL, InR))
6381
import Prelude hiding (span)
6482
import qualified StmContainers.Map as STM
83+
import Type.Reflection (Typeable, eqTypeRep,
84+
pattern App,
85+
type (:~~:) (HRefl),
86+
typeOf, typeRep,
87+
withTypeable)
6588

6689

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

81113
semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
82114
semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull
@@ -130,6 +162,87 @@ getSemanticTokensRule recorder =
130162
let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap
131163
return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast
132164

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

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

‎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 によって変換されたページ (->オリジナル) /