Skip to content

Commit a4ce2e8

Browse files
MangoIVMangoIV
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 9b23567 commit a4ce2e8

File tree

5 files changed

+178
-78
lines changed

5 files changed

+178
-78
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 <> Internal.getSyntacticTokensRule 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: 118 additions & 58 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +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 #-}
10-
{-# LANGUAGE ImpredicativeTypes #-}
11-
{-# LANGUAGE LiberalTypeSynonyms #-}
12-
{-# LANGUAGE BlockArguments #-}
13-
{-# LANGUAGE MultiWayIf #-}
14-
{-# LANGUAGE PatternSynonyms #-}
15-
{-# LANGUAGE RequiredTypeArguments #-}
16-
{-# LANGUAGE ViewPatterns #-}
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 #-}
1717

1818
-- |
1919
-- This module provides the core functionality of the plugin.
@@ -27,20 +27,28 @@ import Control.Monad.Except (ExceptT, liftEither,
2727
import Control.Monad.IO.Class (MonadIO (..))
2828
import Control.Monad.Trans (lift)
2929
import Control.Monad.Trans.Except (runExceptT)
30+
import Control.Monad.Trans.Maybe
31+
import Data.Data (Data (..))
32+
import Data.List
3033
import qualified Data.Map.Strict as M
34+
import Data.Maybe
35+
import Data.Semigroup (First (..))
3136
import Data.Text (Text)
3237
import qualified Data.Text as T
3338
import Development.IDE (Action,
3439
GetDocMap (GetDocMap),
3540
GetHieAst (GetHieAst),
41+
GetParsedModuleWithComments (..),
3642
HieAstResult (HAR, hieAst, hieModule, refMap),
3743
IdeResult, IdeState,
3844
Priority (..),
3945
Recorder, Rules,
4046
WithPriority,
4147
cmapWithPrio, define,
4248
hieKind,
43-
toNormalizedUri, GetParsedModuleWithComments (..), srcSpanToRange)
49+
srcSpanToRange,
50+
toNormalizedUri,
51+
useWithStale)
4452
import Development.IDE.Core.PluginUtils (runActionE, useE,
4553
useWithStaleE)
4654
import Development.IDE.Core.Rules (toIdeResult)
@@ -50,8 +58,9 @@ import Development.IDE.Core.Shake (ShakeExtras (..),
5058
getVirtualFile)
5159
import Development.IDE.GHC.Compat hiding (Warning)
5260
import Development.IDE.GHC.Compat.Util (mkFastString)
61+
import GHC.Parser.Annotation
5362
import Ide.Logger (logWith)
54-
import Ide.Plugin.Error (PluginError (PluginInternalError),
63+
import Ide.Plugin.Error (PluginError (PluginInternalError, PluginRuleFailed),
5564
handleMaybe,
5665
handleMaybeM)
5766
import Ide.Plugin.SemanticTokens.Mappings
@@ -63,24 +72,18 @@ import Ide.Types
6372
import qualified Language.LSP.Protocol.Lens as L
6473
import Language.LSP.Protocol.Message (MessageResult,
6574
Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))
66-
import Language.LSP.Protocol.Types (NormalizedUri,
75+
import Language.LSP.Protocol.Types (NormalizedUri, Range,
6776
SemanticTokens,
6877
fromNormalizedUri,
6978
getUri,
70-
type (|?) (InL, InR), Range)
79+
type (|?) (InL, InR))
7180
import Prelude hiding (span)
7281
import qualified StmContainers.Map as STM
73-
import Type.Reflection
74-
( Typeable,
75-
type (:~~:)(HRefl),
76-
pattern App,
77-
eqTypeRep,
78-
typeOf,
79-
typeRep,
80-
withTypeable )
81-
import Data.Data (Data (..))
82-
import GHC.Parser.Annotation
83-
import Data.Maybe
82+
import Type.Reflection (Typeable, eqTypeRep,
83+
pattern App,
84+
type (:~~:) (HRefl),
85+
typeOf, typeRep,
86+
withTypeable)
8487

8588

8689
$mkSemanticConfigFunctions
@@ -94,9 +97,17 @@ computeSemanticTokens recorder pid _ nuri = do
9497
config <- lift $ useSemanticConfigAction pid
9598
logWith recorder Debug (LogConfig config)
9699
semanticId <- lift getAndIncreaseSemanticTokensId
97-
(RangeHsSemanticTokenTypes {rangeSemanticList}, _mapping) <- useWithStaleE GetSemanticTokens nuri
98-
(RangeHsSyntacticTokenTypes {rangeSyntacticList}, mapping) <- useWithStaleE GetSyntacticTokens nuri
99-
withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping $ map (fmap HsSemanticTokenType) rangeSemanticList <> map (fmap HsSyntacticTokenType) rangeSyntacticList
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
100111

101112
semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
102113
semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull
@@ -153,35 +164,84 @@ getSemanticTokensRule recorder =
153164
getSyntacticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()
154165
getSyntacticTokensRule recorder =
155166
define (cmapWithPrio LogShake recorder) $ \GetSyntacticTokens nfp -> handleError recorder $ do
156-
(parsedModule, positionMapping) <- withExceptT LogDependencyError $ useWithStaleE GetParsedModuleWithComments nfp
157-
pure $ computeRangeHsSyntacticTokenTypeList parsedModule
158-
159-
getLocated's :: forall l a. (Data a, Typeable l) => a -> [GenLocated l (forall r. (forall b. Typeable b => b -> r) -> r)]
160-
getLocated's = mconcat . gmapQ \y -> if
161-
| App con rep <- typeOf y
162-
, Just HRefl <- eqTypeRep con (typeRep @(GenLocated l))
163-
, L l a <- y
164-
-> withTypeable rep $ L l (\k -> k a) : getLocated's y
165-
| otherwise -> getLocated's y
166-
167-
pattern IsA :: forall b t. (Typeable b, Typeable t) => forall. b ~ t => b -> t
168-
pattern IsA x <- ((\y -> (y, eqTypeRep (typeRep @b) (typeOf y))) -> (x, Just HRefl))
169-
170-
mkFromLocatedNode :: GenLocated SrcSpanAnnA (forall r. (forall b. Typeable b => b -> r) -> r) -> Maybe (Range, HsSyntacticTokenType)
171-
mkFromLocatedNode (L ann w) = w \node -> case node of
172-
IsA @(HsExpr GhcPs) expr -> case expr of
173-
HsLet {} -> let
174-
mrange = srcSpanToRange $ getLoc ann
175-
in (, TKeyword) <$> mrange
176-
_ -> Nothing
177-
_ -> Nothing
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
178189

179190
computeRangeHsSyntacticTokenTypeList :: ParsedModule -> RangeHsSyntacticTokenTypes
180191
computeRangeHsSyntacticTokenTypeList ParsedModule {pm_parsed_source} =
181-
let locs = getLocated's @SrcSpanAnnA pm_parsed_source
182-
toks = mapMaybe mkFromLocatedNode locs
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+
, maybeToList do
202+
L loc expr <- extractTy @(LHsExpr GhcPs) node
203+
let fromSimple = 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+
HsRecSel {} -> fromSimple TRecordSelector
234+
_ -> Nothing
235+
]
183236
in RangeHsSyntacticTokenTypes toks
184237

238+
{-# inline mkFromLocatable #-}
239+
mkFromLocatable
240+
:: HsSyntacticTokenType
241+
-> (forall r. (forall a. HasSrcSpan a => a -> r) -> r)
242+
-> Maybe (Range, HsSyntacticTokenType)
243+
mkFromLocatable tt w = w \tok -> let mrange = srcSpanToRange $ getLoc tok in fmap (, tt) mrange
244+
185245
-- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs
186246

187247
-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log)

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

Lines changed: 21 additions & 17 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)
@@ -40,23 +41,26 @@ nameInfixOperator _ = Nothing
4041

4142
-- | map from haskell semantic token type to LSP default token type
4243
toLspTokenType :: SemanticTokensConfig -> HsTokenType -> SemanticTokenTypes
43-
toLspTokenType conf tk = case tk of
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
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
6064

6165
lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
6266
lspTokenReverseMap config

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

Lines changed: 12 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
23
{-# LANGUAGE DerivingVia #-}
34
{-# LANGUAGE GADTs #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE StrictData #-}
67
{-# LANGUAGE TypeFamilies #-}
7-
{-# LANGUAGE DeriveAnyClass #-}
88

99
module Ide.Plugin.SemanticTokens.Types where
1010

@@ -46,6 +46,9 @@ data HsSyntacticTokenType
4646
= TKeyword
4747
| TComment
4848
| TStringLit
49+
| TCharLit
50+
| TNumberLit
51+
| TRecordSelector
4952
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic, Lift)
5053

5154
data HsTokenType =
@@ -57,8 +60,11 @@ data HsTokenType =
5760
instance Default SemanticTokensConfig where
5861
def = STC
5962
{ stKeyword = SemanticTokenTypes_Keyword
63+
, stRecordSelector = SemanticTokenTypes_Property
6064
, stComment = SemanticTokenTypes_Comment
6165
, stStringLit = SemanticTokenTypes_String
66+
, stNumberLit = SemanticTokenTypes_Number
67+
, stCharLit = SemanticTokenTypes_String
6268
, stFunction = SemanticTokenTypes_Function
6369
, stVariable = SemanticTokenTypes_Variable
6470
, stDataConstructor = SemanticTokenTypes_EnumMember
@@ -81,8 +87,11 @@ instance Default SemanticTokensConfig where
8187
-- it contains map between the hs semantic token type and default token type.
8288
data SemanticTokensConfig = STC
8389
{ stStringLit :: !SemanticTokenTypes
90+
, stCharLit :: !SemanticTokenTypes
91+
, stNumberLit :: !SemanticTokenTypes
8492
, stComment :: !SemanticTokenTypes
8593
, stKeyword :: !SemanticTokenTypes
94+
, stRecordSelector :: !SemanticTokenTypes
8695
, stFunction :: !SemanticTokenTypes
8796
, stVariable :: !SemanticTokenTypes
8897
, stDataConstructor :: !SemanticTokenTypes
@@ -172,6 +181,7 @@ data SemanticLog
172181
| LogConfig SemanticTokensConfig
173182
| LogMsg String
174183
| LogNoVF
184+
| LogSyntacticTokens RangeHsSyntacticTokenTypes
175185
| LogSemanticTokensDeltaMisMatch Text (Maybe Text)
176186

177187
instance Pretty SemanticLog where
@@ -185,6 +195,6 @@ instance Pretty SemanticLog where
185195
-> "SemanticTokensDeltaMisMatch: previousIdFromRequest: " <> pretty previousIdFromRequest
186196
<> " previousIdFromCache: " <> pretty previousIdFromCache
187197
LogDependencyError err -> "SemanticTokens' dependency error: " <> pretty err
188-
198+
LogSyntacticTokens (RangeHsSyntacticTokenTypes synList) -> "Syntactic tokens: " <> pretty (show synList)
189199

190200
type SemanticTokenId = Text

0 commit comments

Comments
 (0)