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 bc4ed9a

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 bc4ed9a

File tree

9 files changed

+256
-60
lines changed

9 files changed

+256
-60
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

‎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: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,10 +15,10 @@ 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
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 & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,23 @@
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.
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)
@@ -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,8 +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),
63+
import Ide.Plugin.Error (PluginError (PluginInternalError, PluginRuleFailed),
4864
getNormalizedFilePathE,
4965
handleMaybe,
5066
handleMaybeM)
@@ -58,10 +74,17 @@ import qualified Language.LSP.Protocol.Lens as L
5874
import Language.LSP.Protocol.Message (MessageResult,
5975
Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))
6076
import Language.LSP.Protocol.Types (NormalizedFilePath,
77+
Range,
6178
SemanticTokens,
79+
fromNormalizedFilePath,
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 nfp
104+
rangesemanticTypes <- lift $ useWithStale GetSemanticTokens nfp
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 -> maybeToList $ mkFromLocatable TRecordSelector \k -> k field
235+
HsProjection _ projs -> 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: 23 additions & 16 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,28 +40,34 @@ 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
6067
| length xs /= Map.size mr = error "lspTokenReverseMap: token type mapping is not bijection"
6168
| otherwise = mr
6269
where xs = enumFrom minBound
63-
mr = Map.fromList $ map (\x -> (toLspTokenType config x, x)) xs
70+
mr = Map.fromList $ map (\x -> (toLspTokenType config (HsSemanticTokenType x), x)) xs
6471

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

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import Development.IDE.GHC.Compat
1414
import Ide.Plugin.SemanticTokens.Mappings
1515
import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind,
1616
HsSemanticTokenType (TModule),
17+
HsTokenType,
1718
RangeSemanticTokenTypeList,
1819
SemanticTokenId,
1920
SemanticTokensConfig)
@@ -66,11 +67,11 @@ nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n)
6667

6768
-------------------------------------------------
6869

69-
rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens
70+
rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> [(Range, HsTokenType)] -> Either Text SemanticTokens
7071
rangeSemanticsSemanticTokens sid stc mapping =
7172
makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk)
7273
where
73-
toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute
74+
toAbsSemanticToken :: Range -> HsTokenType -> SemanticTokenAbsolute
7475
toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType =
7576
let len = endColumn - startColumn
7677
in SemanticTokenAbsolute

0 commit comments

Comments
(0)

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