{-# 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

-- | 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 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
      --   <- 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) []]

  -- 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 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]