{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Ide.Plugin.SemanticTokens.SemanticConfig where
import Data.Char (toLower)
import Data.Default (def)
import qualified Data.Set as S
import qualified Data.Text as T
import Development.IDE (usePropertyAction)
import Ide.Plugin.Properties (defineEnumProperty,
emptyProperties)
import Ide.Plugin.SemanticTokens.Types
import Language.Haskell.TH
import Language.LSP.Protocol.Types (LspEnum (..),
SemanticTokenTypes)
docName :: HsSemanticTokenType -> T.Text
docName :: HsSemanticTokenType -> Text
docName HsSemanticTokenType
tt = case HsSemanticTokenType
tt of
HsSemanticTokenType
TVariable -> Text
"variables"
HsSemanticTokenType
TFunction -> Text
"functions"
HsSemanticTokenType
TDataConstructor -> Text
"data constructors"
HsSemanticTokenType
TTypeVariable -> Text
"type variables"
HsSemanticTokenType
TClassMethod -> Text
"typeclass methods"
HsSemanticTokenType
TPatternSynonym -> Text
"pattern synonyms"
HsSemanticTokenType
TTypeConstructor -> Text
"type constructors"
HsSemanticTokenType
TClass -> Text
"typeclasses"
HsSemanticTokenType
TTypeSynonym -> Text
"type synonyms"
HsSemanticTokenType
TTypeFamily -> Text
"type families"
HsSemanticTokenType
TRecordField -> Text
"record fields"
toConfigName :: String -> String
toConfigName :: String -> String
toConfigName = (String
"st" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)
type LspTokenTypeDescriptions = [(SemanticTokenTypes, T.Text)]
lspTokenTypeDescriptions :: LspTokenTypeDescriptions
lspTokenTypeDescriptions :: LspTokenTypeDescriptions
lspTokenTypeDescriptions =
(SemanticTokenTypes -> (SemanticTokenTypes, Text))
-> [SemanticTokenTypes] -> LspTokenTypeDescriptions
forall a b. (a -> b) -> [a] -> [b]
map
( \SemanticTokenTypes
x ->
(SemanticTokenTypes
x, Text
"LSP Semantic Token Type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemanticTokenTypes -> EnumBaseType SemanticTokenTypes
forall a. LspEnum a => a -> EnumBaseType a
toEnumBaseType SemanticTokenTypes
x)
)
([SemanticTokenTypes] -> LspTokenTypeDescriptions)
-> [SemanticTokenTypes] -> LspTokenTypeDescriptions
forall a b. (a -> b) -> a -> b
$ Set SemanticTokenTypes -> [SemanticTokenTypes]
forall a. Set a -> [a]
S.toList Set SemanticTokenTypes
forall a. LspEnum a => Set a
knownValues
allHsTokenTypes :: [HsSemanticTokenType]
allHsTokenTypes :: [HsSemanticTokenType]
allHsTokenTypes = HsSemanticTokenType -> [HsSemanticTokenType]
forall a. Enum a => a -> [a]
enumFrom HsSemanticTokenType
forall a. Bounded a => a
minBound
lowerFirst :: String -> String
lowerFirst :: String -> String
lowerFirst [] = []
lowerFirst (Char
x:String
xs) = Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
allHsTokenNameStrings :: [String]
allHsTokenNameStrings :: [String]
allHsTokenNameStrings = (HsSemanticTokenType -> String)
-> [HsSemanticTokenType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String)
-> (HsSemanticTokenType -> String) -> HsSemanticTokenType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsSemanticTokenType -> String
forall a. Show a => a -> String
show) [HsSemanticTokenType]
allHsTokenTypes
defineSemanticProperty :: (KeyNameProxy s, Text, SemanticTokenTypes)
-> Properties r
-> Properties ('PropertyKey s ('TEnum SemanticTokenTypes) : r)
defineSemanticProperty (KeyNameProxy s
lb, Text
tokenType, SemanticTokenTypes
st) =
KeyNameProxy s
-> Text
-> LspTokenTypeDescriptions
-> SemanticTokenTypes
-> Properties r
-> Properties ('PropertyKey s ('TEnum SemanticTokenTypes) : r)
forall (s :: Symbol) (r :: [PropertyKey]) a.
(KnownSymbol s, NotElem s r, ToJSON a, FromJSON a, Eq a, Show a) =>
KeyNameProxy s
-> Text
-> [(a, Text)]
-> a
-> Properties r
-> Properties ('PropertyKey s ('TEnum a) : r)
defineEnumProperty
KeyNameProxy s
lb
Text
tokenType
LspTokenTypeDescriptions
lspTokenTypeDescriptions
SemanticTokenTypes
st
semanticDef :: SemanticTokensConfig
semanticDef :: SemanticTokensConfig
semanticDef = SemanticTokensConfig
forall a. Default a => a
def
mkSemanticConfigFunctions :: Q [Dec]
mkSemanticConfigFunctions :: Q [Dec]
mkSemanticConfigFunctions = do
let pid :: Name
pid = String -> Name
mkName String
"pid"
let semanticConfigPropertiesName :: Name
semanticConfigPropertiesName = String -> Name
mkName String
"semanticConfigProperties"
let useSemanticConfigActionName :: Name
useSemanticConfigActionName = String -> Name
mkName String
"useSemanticConfigAction"
let allLabels :: [Exp]
allLabels = (String -> Exp) -> [String] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Exp
LabelE (String -> Exp) -> (String -> String) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Token")(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
lowerFirst) [String]
allHsTokenNameStrings
allFieldsNames :: [Name]
allFieldsNames = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toConfigName) [String]
allHsTokenNameStrings
allVariableNames :: [Name]
allVariableNames = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"_variable_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toConfigName) [String]
allHsTokenNameStrings
mkGetProperty :: (Name, Exp) -> Stmt
mkGetProperty (Name
variable, Exp
label) =
Pat -> Exp -> Stmt
BindS
(Name -> Pat
VarP Name
variable)
(Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'usePropertyAction) Exp
label Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
pid Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
semanticConfigPropertiesName)
getProperties :: [Stmt]
getProperties = (Name -> Exp -> Stmt) -> [Name] -> [Exp] -> [Stmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Name, Exp) -> Stmt) -> Name -> Exp -> Stmt
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Name, Exp) -> Stmt
mkGetProperty) [Name]
allVariableNames [Exp]
allLabels
recordUpdate :: Exp
recordUpdate =
Exp -> [(Name, Exp)] -> Exp
RecUpdE (Name -> Exp
VarE 'semanticDef) ([(Name, Exp)] -> Exp) -> [(Name, Exp)] -> Exp
forall a b. (a -> b) -> a -> b
$
(Name -> Name -> (Name, Exp)) -> [Name] -> [Name] -> [(Name, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
fieldName Name
variableName -> (Name
fieldName, Name -> Exp
VarE Name
variableName)) [Name]
allFieldsNames [Name]
allVariableNames
bb :: Exp
bb = Maybe ModName -> [Stmt] -> Exp
DoE Maybe ModName
forall a. Maybe a
Nothing ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ [Stmt]
getProperties [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'return) Exp
recordUpdate]
let useSemanticConfigAction :: Dec
useSemanticConfigAction = Name -> [Clause] -> Dec
FunD Name
useSemanticConfigActionName [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
pid] (Exp -> Body
NormalB Exp
bb) []]
[Exp]
nameAndDescList <-
((Exp, HsSemanticTokenType) -> Q Exp)
-> [(Exp, HsSemanticTokenType)] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
( \(Exp
lb, HsSemanticTokenType
x) -> do
Exp
desc <- [|"LSP semantic token type to use for " <> docName x|]
Exp
lspToken <- [|toLspTokenType def x|]
Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE [Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
lb, Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
desc, Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
lspToken]
)
([(Exp, HsSemanticTokenType)] -> Q [Exp])
-> [(Exp, HsSemanticTokenType)] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ [Exp] -> [HsSemanticTokenType] -> [(Exp, HsSemanticTokenType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp]
allLabels [HsSemanticTokenType]
allHsTokenTypes
let body :: Exp
body = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'defineSemanticProperty)) (Name -> Exp
VarE 'emptyProperties) [Exp]
nameAndDescList
let semanticConfigProperties :: Dec
semanticConfigProperties = Name -> [Clause] -> Dec
FunD Name
semanticConfigPropertiesName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []]
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
semanticConfigProperties, Dec
useSemanticConfigAction]