{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE OverloadedLabels      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeFamilies          #-}

module Ide.Plugin.SemanticTokens.SemanticConfig where

import           Data.Char                       (toLower)
import           Data.Default                    (def)
import qualified Data.Set                        as S
import           Data.Text                       (Text)
import qualified Data.Text                       as T
import           Development.IDE                 (Action, usePropertyAction)
import           GHC.TypeLits                    (KnownSymbol)
import           Ide.Plugin.Properties           (KeyNameProxy, NotElem,
                                                  Properties,
                                                  PropertyKey (type PropertyKey),
                                                  PropertyType (type TEnum),
                                                  defineEnumProperty,
                                                  emptyProperties)
import           Ide.Plugin.SemanticTokens.Types
import           Ide.Types                       (PluginId)
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"
  HsSemanticTokenType
TModule          -> Text
"modules"
  HsSemanticTokenType
TOperator        -> Text
"operators"

toConfigName :: String -> String
toConfigName :: String -> String
toConfigName = (String
"st" <>)

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 ::
  (NotElem s r, KnownSymbol s) =>
  (KeyNameProxy s, Text, SemanticTokenTypes) ->
  Properties r ->
  Properties ('PropertyKey s (TEnum SemanticTokenTypes) : r)
defineSemanticProperty :: forall (s :: Symbol) (r :: [PropertyKey]).
(NotElem s r, KnownSymbol s) =>
(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

-- | it produces the following functions:
-- semanticConfigProperties :: Properties '[
-- 'PropertyKey "Variable" ('TEnum SemanticTokenTypes),
-- ...
-- ]
-- useSemanticConfigAction :: PluginId -> Action SemanticTokensConfig
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 allLabelStrs :: [String]
allLabelStrs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((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
      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 -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toConfigName) [String]
allHsTokenNameStrings
      --   <- useSemanticConfigAction label pid config
      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
      -- get and then update record
      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) []]
  let useSemanticConfigActionSig :: Dec
useSemanticConfigActionSig = Name -> Type -> Dec
SigD Name
useSemanticConfigActionName (Type
ArrowT Type -> Type -> Type
`AppT` Name -> Type
ConT ''PluginId Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Action Type -> Type -> Type
`AppT` Name -> Type
ConT ''SemanticTokensConfig))

  -- SemanticConfigProperties
  [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 propertiesType :: Type
propertiesType =
        (String -> Type -> Type) -> Type -> [String] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          ( \String
la ->
              Type -> Type -> Type
AppT
                ( Type
PromotedConsT
                    Type -> Type -> Type
`AppT` (Type -> Type -> Type
AppT (Name -> Type
ConT 'PropertyKey) (TyLit -> Type
LitT (String -> TyLit
StrTyLit String
la)) Type -> Type -> Type
`AppT` Type -> Type -> Type
AppT (Name -> Type
ConT 'TEnum) (Name -> Type
ConT ''SemanticTokenTypes))
                )
          )
          Type
PromotedNilT
          [String]
allLabelStrs
  let semanticConfigProperties :: Dec
semanticConfigProperties = Name -> [Clause] -> Dec
FunD Name
semanticConfigPropertiesName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []]
  let semanticConfigPropertiesSig :: Dec
semanticConfigPropertiesSig = Name -> Type -> Dec
SigD Name
semanticConfigPropertiesName (Type -> Type -> Type
AppT (Name -> Type
ConT ''Properties) Type
propertiesType)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
semanticConfigPropertiesSig, Dec
semanticConfigProperties, Dec
useSemanticConfigActionSig, Dec
useSemanticConfigAction]