Skip to content

Commit 800287c

Browse files
soulomoonsoulomoon
committed
add description for semantic tokens mappings config
1 parent def4db4 commit 800287c

File tree

9 files changed

+195
-133
lines changed

9 files changed

+195
-133
lines changed

‎plugins/hls-semantic-tokens-plugin/hls-semantic-tokens-plugin.cabal

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ library
2828
Ide.Plugin.SemanticTokens.Mappings
2929
other-modules:
3030
Ide.Plugin.SemanticTokens.Query
31+
Ide.Plugin.SemanticTokens.SemanticConfig
3132
Ide.Plugin.SemanticTokens.Utils
3233
Ide.Plugin.SemanticTokens.Internal
3334

@@ -52,8 +53,8 @@ library
5253
, array
5354
, deepseq
5455
, hls-graph == 2.5.0.0
56+
, template-haskell
5557
, data-default
56-
, rank2classes
5758

5859
default-language: Haskell2010
5960
default-extensions: DataKinds
@@ -86,5 +87,5 @@ test-suite tests
8687
, bytestring
8788
, ghcide == 2.5.0.0
8889
, hls-plugin-api == 2.5.0.0
89-
, rank2classes
90+
, template-haskell
9091
, data-default

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE TemplateHaskell #-}
23

34
module Ide.Plugin.SemanticTokens (descriptor) where
45

@@ -16,6 +17,6 @@ descriptor recorder plId =
1617
pluginConfigDescriptor =
1718
defaultConfigDescriptor
1819
{ configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False}
19-
, configCustomConfig = mkCustomConfig semanticConfigProperties
20+
, configCustomConfig = mkCustomConfig Internal.semanticConfigProperties
2021
}
2122
}

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

Lines changed: 49 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -1,73 +1,79 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE DerivingStrategies #-}
3+
{-# LANGUAGE FlexibleContexts #-}
34
{-# LANGUAGE FlexibleInstances #-}
45
{-# LANGUAGE MultiParamTypeClasses #-}
56
{-# LANGUAGE NamedFieldPuns #-}
67
{-# LANGUAGE OverloadedLabels #-}
78
{-# LANGUAGE OverloadedStrings #-}
89
{-# LANGUAGE RecordWildCards #-}
910
{-# LANGUAGE ScopedTypeVariables #-}
11+
{-# LANGUAGE TemplateHaskell #-}
1012
{-# LANGUAGE TypeFamilies #-}
1113
{-# LANGUAGE UnicodeSyntax #-}
1214

1315
-- |
1416
-- This module provides the core functionality of the plugin.
15-
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule) where
17+
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule, semanticConfigProperties) where
1618

17-
import Control.Lens ((^.))
18-
import Control.Monad.Except (ExceptT, liftEither,
19-
withExceptT)
20-
import Control.Monad.Trans (lift)
21-
import Control.Monad.Trans.Except (runExceptT)
22-
import Data.Aeson (ToJSON (toJSON))
23-
import qualified Data.Map as Map
24-
import Development.IDE (Action,
25-
GetDocMap (GetDocMap),
26-
GetHieAst (GetHieAst),
27-
HieAstResult (HAR, hieAst, hieModule, refMap),
28-
IdeResult, IdeState,
29-
Priority (..), Recorder,
30-
Rules, WithPriority,
31-
cmapWithPrio, define,
32-
fromNormalizedFilePath,
33-
hieKind, logPriority,
34-
usePropertyAction, use_)
35-
import Development.IDE.Core.PluginUtils (runActionE,
36-
useWithStaleE)
37-
import Development.IDE.Core.PositionMapping (idDelta)
38-
import Development.IDE.Core.Rules (toIdeResult)
39-
import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..))
40-
import Development.IDE.Core.Shake (addPersistentRule,
41-
getVirtualFile,
42-
useWithStale_)
43-
import Development.IDE.GHC.Compat hiding (Warning)
44-
import Development.IDE.GHC.Compat.Util (mkFastString)
45-
import Ide.Logger (logWith)
46-
import Ide.Plugin.Error (PluginError (PluginInternalError),
47-
getNormalizedFilePathE,
48-
handleMaybe,
49-
handleMaybeM)
19+
import Control.Lens ((^.))
20+
import Control.Monad.Except (ExceptT, liftEither,
21+
withExceptT)
22+
import Control.Monad.Trans (lift)
23+
import Control.Monad.Trans.Except (runExceptT)
24+
import Data.Aeson (ToJSON (toJSON))
25+
import qualified Data.Map as Map
26+
import Development.IDE (Action,
27+
GetDocMap (GetDocMap),
28+
GetHieAst (GetHieAst),
29+
HieAstResult (HAR, hieAst, hieModule, refMap),
30+
IdeResult, IdeState,
31+
Priority (..),
32+
Recorder, Rules,
33+
WithPriority,
34+
cmapWithPrio, define,
35+
fromNormalizedFilePath,
36+
hieKind, logPriority,
37+
usePropertyAction,
38+
use_)
39+
import Development.IDE.Core.PluginUtils (runActionE,
40+
useWithStaleE)
41+
import Development.IDE.Core.PositionMapping (idDelta)
42+
import Development.IDE.Core.Rules (toIdeResult)
43+
import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..))
44+
import Development.IDE.Core.Shake (addPersistentRule,
45+
getVirtualFile,
46+
useWithStale_)
47+
import Development.IDE.GHC.Compat hiding (Warning)
48+
import Development.IDE.GHC.Compat.Util (mkFastString)
49+
import Ide.Logger (logWith)
50+
import Ide.Plugin.Error (PluginError (PluginInternalError),
51+
getNormalizedFilePathE,
52+
handleMaybe,
53+
handleMaybeM)
5054
import Ide.Plugin.SemanticTokens.Mappings
5155
import Ide.Plugin.SemanticTokens.Query
56+
import Ide.Plugin.SemanticTokens.SemanticConfig (mkSemanticConfigFunctions)
5257
import Ide.Plugin.SemanticTokens.Types
5358
import Ide.Types
54-
import qualified Language.LSP.Protocol.Lens as L
55-
import Language.LSP.Protocol.Message (Method (Method_TextDocumentSemanticTokensFull))
56-
import Language.LSP.Protocol.Types (NormalizedFilePath,
57-
SemanticTokens,
58-
type (|?) (InL))
59-
import Prelude hiding (span)
59+
import qualified Language.LSP.Protocol.Lens as L
60+
import Language.LSP.Protocol.Message (Method (Method_TextDocumentSemanticTokensFull))
61+
import Language.LSP.Protocol.Types (NormalizedFilePath,
62+
SemanticTokenTypes,
63+
SemanticTokens,
64+
type (|?) (InL))
65+
import Prelude hiding (span)
6066

6167

68+
$mkSemanticConfigFunctions
69+
6270
-----------------------
6371
---- the api
6472
-----------------------
6573

6674
computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens
6775
computeSemanticTokens recorder pid _ nfp = do
68-
logWith recorder Debug (LogMsg "computeSemanticTokens start")
69-
config :: SemanticTokensConfig <- lift $ usePropertyAction #tokenMapping pid semanticConfigProperties
70-
logWith recorder Debug (LogMsg $ show $ toJSON config)
76+
config <- lift $ useSemanticConfigAction pid
7177
logWith recorder Debug (LogConfig config)
7278
(RangeHsSemanticTokenTypes {rangeSemanticMap}, mapping) <- useWithStaleE GetSemanticTokens nfp
7379
withExceptT PluginInternalError $ liftEither $ rangeSemanticMapSemanticTokens config mapping rangeSemanticMap

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

Lines changed: 13 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@
22
{-# LANGUAGE OverloadedStrings #-}
33
{-# LANGUAGE TypeFamilies #-}
44

5+
6+
57
-- |
68
-- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for:
79
--
@@ -12,8 +14,6 @@
1214
module Ide.Plugin.SemanticTokens.Mappings where
1315

1416
import qualified Data.Array as A
15-
import Data.Default (def)
16-
import Data.Functor.Identity (Identity (runIdentity))
1717
import Data.List.Extra (chunksOf, (!?))
1818
import qualified Data.Map as Map
1919
import Data.Maybe (mapMaybe)
@@ -36,17 +36,17 @@ import Language.LSP.VFS hiding (line)
3636
-- | map from haskell semantic token type to LSP default token type
3737
toLspTokenType :: SemanticTokensConfig -> HsSemanticTokenType -> SemanticTokenTypes
3838
toLspTokenType conf tk = case tk of
39-
TFunction -> runIdentity $ stFunction conf
40-
TVariable -> runIdentity $ stVariable conf
41-
TClassMethod -> runIdentity $ stClassMethod conf
42-
TTypeVariable -> runIdentity $ stTypeVariable conf
43-
TDataCon -> runIdentity $ stDataCon conf
44-
TClass -> runIdentity $ stClass conf
45-
TTypeCon -> runIdentity $ stTypeCon conf
46-
TTypeSyn -> runIdentity $ stTypeSyn conf
47-
TTypeFamily -> runIdentity $ stTypeFamily conf
48-
TRecField -> runIdentity $ stRecField conf
49-
TPatternSyn -> runIdentity $ stPatternSyn conf
39+
TFunction -> stFunction conf
40+
TVariable -> stVariable conf
41+
TClassMethod -> stClassMethod conf
42+
TTypeVariable -> stTypeVariable conf
43+
TDataCon -> stDataCon conf
44+
TClass -> stClass conf
45+
TTypeCon -> stTypeCon conf
46+
TTypeSyn -> stTypeSyn conf
47+
TTypeFamily -> stTypeFamily conf
48+
TRecField -> stRecField conf
49+
TPatternSyn -> stPatternSyn conf
5050

5151
lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType
5252
lspTokenReverseMap config

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

Lines changed: 87 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,87 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE OverloadedLabels #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE TemplateHaskell #-}
5+
{-# LANGUAGE TypeFamilies #-}
6+
{-# LANGUAGE TypeOperators #-}
7+
8+
module Ide.Plugin.SemanticTokens.SemanticConfig where
9+
10+
import Data.Default (def)
11+
import qualified Data.Set as S
12+
import qualified Data.Text as T
13+
import Development.IDE (usePropertyAction)
14+
import Ide.Plugin.Properties (defineEnumProperty,
15+
emptyProperties)
16+
import Ide.Plugin.SemanticTokens.Types
17+
import Language.Haskell.TH
18+
import Language.LSP.Protocol.Types (LspEnum (..),
19+
SemanticTokenTypes)
20+
21+
toConfigName :: String -> String
22+
toConfigName = ("st" <>)
23+
24+
-- lspTokenTypeDescription :: [(SemanticTokenTypes, String)]
25+
type LspTokenTypeDescriptions = [(SemanticTokenTypes, T.Text)]
26+
27+
lspTokenTypeDescriptions :: LspTokenTypeDescriptions
28+
lspTokenTypeDescriptions =
29+
map
30+
( \x ->
31+
(x, "LSP Semantic Token Type:" <> toEnumBaseType x)
32+
)
33+
$ S.toList knownValues
34+
35+
allHsTokenTypes :: [HsSemanticTokenType]
36+
allHsTokenTypes = enumFrom minBound
37+
38+
allHsTokenNameStrings :: [String]
39+
allHsTokenNameStrings = map (drop 1 . show) allHsTokenTypes
40+
41+
defineSemanticProperty (lb, tokenType, st) =
42+
defineEnumProperty
43+
lb
44+
tokenType
45+
lspTokenTypeDescriptions
46+
st
47+
48+
semanticDef :: SemanticTokensConfig
49+
semanticDef = def
50+
51+
-- | it produces the following functions:
52+
-- semanticConfigProperties :: SemanticConfigProperties
53+
-- useSemanticConfigAction :: PluginId -> Action SemanticTokensConfig
54+
mkSemanticConfigFunctions :: Q [Dec]
55+
mkSemanticConfigFunctions = do
56+
let pid = mkName "pid"
57+
let semanticConfigPropertiesName = mkName "semanticConfigProperties"
58+
let useSemanticConfigActionName = mkName "useSemanticConfigAction"
59+
let
60+
allLabels = map LabelE allHsTokenNameStrings
61+
allFieldsNames = map (mkName . toConfigName) allHsTokenNameStrings
62+
allVariableNames = map (mkName . ("variable_" <>) . toConfigName) allHsTokenNameStrings
63+
-- <- useSemanticConfigAction label pid config
64+
mkGetProperty (variable, label) =
65+
BindS
66+
(VarP variable)
67+
(AppE (VarE 'usePropertyAction) label `AppE` VarE pid `AppE` VarE semanticConfigPropertiesName)
68+
getProperties = zipWith (curry mkGetProperty) allVariableNames allLabels
69+
recordUpdate =
70+
RecUpdE (VarE 'semanticDef) $
71+
zipWith (\fieldName variableName -> (fieldName, VarE variableName)) allFieldsNames allVariableNames
72+
-- get and then update record
73+
bb = DoE Nothing $ getProperties ++ [NoBindS $ AppE (VarE 'return) recordUpdate]
74+
let useSemanticConfigAction = FunD useSemanticConfigActionName [Clause [VarP pid] (NormalB bb) []]
75+
76+
-- SemanticConfigProperties
77+
nameAndDescList <-
78+
mapM
79+
( \(lb, x) -> do
80+
desc <- [|"LSP semantic token type to use for " <> T.pack (drop 1 $ show x)|]
81+
lspToken <- [|toLspTokenType def x|]
82+
return $ TupE [Just lb, Just desc, Just lspToken]
83+
)
84+
$ zip allLabels allHsTokenTypes
85+
let body = foldr (AppE . AppE (VarE 'defineSemanticProperty)) (VarE 'emptyProperties) nameAndDescList
86+
let semanticConfigProperties = FunD semanticConfigPropertiesName [Clause [] (NormalB body) []]
87+
return [semanticConfigProperties, useSemanticConfigAction]

0 commit comments

Comments
 (0)