Skip to content

Commit 5a3d274

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 9b952c8 commit 5a3d274

File tree

9 files changed

+256
-61
lines changed

9 files changed

+256
-61
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
@@ -1790,6 +1790,7 @@ library hls-semantic-tokens-plugin
17901790
, containers
17911791
, extra
17921792
, text-rope
1793+
, ghc
17931794
, mtl >= 2.2
17941795
, ghc
17951796
, ghcide == 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 & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,23 @@
1-
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE DerivingStrategies #-}
3-
{-# LANGUAGE OverloadedLabels #-}
4-
{-# LANGUAGE OverloadedRecordDot #-}
5-
{-# LANGUAGE OverloadedStrings #-}
6-
{-# LANGUAGE PatternSynonyms #-}
7-
{-# LANGUAGE RecordWildCards #-}
8-
{-# LANGUAGE TemplateHaskell #-}
9-
{-# LANGUAGE TypeFamilies #-}
10-
{-# 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 #-}
1117

1218
-- |
1319
-- This module provides the core functionality of the plugin.
14-
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where
20+
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, getSyntacticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where
1521

1622
import Control.Concurrent.STM (stateTVar)
1723
import Control.Concurrent.STM.Stats (atomically)
@@ -21,20 +27,28 @@ import Control.Monad.Except (ExceptT, liftEither,
2127
import Control.Monad.IO.Class (MonadIO (..))
2228
import Control.Monad.Trans (lift)
2329
import Control.Monad.Trans.Except (runExceptT)
30+
import Control.Monad.Trans.Maybe
31+
import Data.Data (Data (..))
32+
import Data.List
2433
import qualified Data.Map.Strict as M
34+
import Data.Maybe
35+
import Data.Semigroup (First (..))
2536
import Data.Text (Text)
2637
import qualified Data.Text as T
2738
import Development.IDE (Action,
2839
GetDocMap (GetDocMap),
2940
GetHieAst (GetHieAst),
41+
GetParsedModuleWithComments (..),
3042
HieAstResult (HAR, hieAst, hieModule, refMap),
3143
IdeResult, IdeState,
3244
Priority (..),
3345
Recorder, Rules,
3446
WithPriority,
3547
cmapWithPrio, define,
36-
fromNormalizedFilePath,
37-
hieKind)
48+
hieKind,
49+
srcSpanToRange,
50+
toNormalizedUri,
51+
useWithStale)
3852
import Development.IDE.Core.PluginUtils (runActionE, useE,
3953
useWithStaleE)
4054
import Development.IDE.Core.Rules (toIdeResult)
@@ -44,10 +58,11 @@ import Development.IDE.Core.Shake (ShakeExtras (..),
4458
getVirtualFile)
4559
import Development.IDE.GHC.Compat hiding (Warning)
4660
import Development.IDE.GHC.Compat.Util (mkFastString)
61+
import GHC.Parser.Annotation
4762
import GHC.Iface.Ext.Types (HieASTs (getAsts),
4863
pattern HiePath)
4964
import Ide.Logger (logWith)
50-
import Ide.Plugin.Error (PluginError (PluginInternalError),
65+
import Ide.Plugin.Error (PluginError (PluginInternalError, PluginRuleFailed),
5166
getNormalizedFilePathE,
5267
handleMaybe,
5368
handleMaybeM)
@@ -61,10 +76,17 @@ import qualified Language.LSP.Protocol.Lens as L
6176
import Language.LSP.Protocol.Message (MessageResult,
6277
Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))
6378
import Language.LSP.Protocol.Types (NormalizedFilePath,
79+
Range,
6480
SemanticTokens,
81+
fromNormalizedFilePath,
6582
type (|?) (InL, InR))
6683
import Prelude hiding (span)
6784
import qualified StmContainers.Map as STM
85+
import Type.Reflection (Typeable, eqTypeRep,
86+
pattern App,
87+
type (:~~:) (HRefl),
88+
typeOf, typeRep,
89+
withTypeable)
6890

6991

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

84115
semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
85116
semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull
@@ -133,6 +164,87 @@ getSemanticTokensRule recorder =
133164
let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap
134165
return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast
135166

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

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

‎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)
@@ -43,28 +44,34 @@ nameInfixOperator _ = Nothing
4344
-- * 1. Mapping semantic token type to and from the LSP default token type.
4445

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

6269
lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
6370
lspTokenReverseMap config
6471
| length xs /= Map.size mr = error "lspTokenReverseMap: token type mapping is not bijection"
6572
| otherwise = mr
6673
where xs = enumFrom minBound
67-
mr = Map.fromList $ map (\x -> (toLspTokenType config x, x)) xs
74+
mr = Map.fromList $ map (\x -> (toLspTokenType config (HsSemanticTokenType x), x)) xs
6875

6976
lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
7077
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
@@ -17,6 +17,7 @@ import GHC.Iface.Ext.Utils (RefMap)
1717
import Ide.Plugin.SemanticTokens.Mappings
1818
import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind,
1919
HsSemanticTokenType (TModule),
20+
HsTokenType,
2021
RangeSemanticTokenTypeList,
2122
SemanticTokenId,
2223
SemanticTokensConfig)
@@ -69,11 +70,11 @@ nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n)
6970

7071
-------------------------------------------------
7172

72-
rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens
73+
rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> [(Range, HsTokenType)] -> Either Text SemanticTokens
7374
rangeSemanticsSemanticTokens sid stc mapping =
7475
makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk)
7576
where
76-
toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute
77+
toAbsSemanticToken :: Range -> HsTokenType -> SemanticTokenAbsolute
7778
toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType =
7879
let len = endColumn - startColumn
7980
in SemanticTokenAbsolute

0 commit comments

Comments
 (0)