{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.ConfigUtils where
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import Data.Default (def)
import qualified Data.Dependent.Map as DMap
import qualified Data.Dependent.Sum as DSum
import qualified Data.HashMap.Lazy as HMap
import Data.List (nub)
import Ide.Plugin.Config
import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)
import Ide.Types
import Language.LSP.Types
pluginsToDefaultConfig :: IdePlugins a -> A.Value
pluginsToDefaultConfig :: IdePlugins a -> Value
pluginsToDefaultConfig IdePlugins {[(PluginId, PluginDescriptor a)]
ipMap :: forall ideState.
IdePlugins ideState -> [(PluginId, PluginDescriptor ideState)]
ipMap :: [(PluginId, PluginDescriptor a)]
..} =
Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$
(Value -> Value) -> Text -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
HMap.adjust
( \(Value -> Object
unsafeValueToObject -> Object
o) ->
Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert Text
"plugin" Value
elems Object
o
)
Text
"haskell"
(Value -> Object
unsafeValueToObject (Config -> Value
forall a. ToJSON a => a -> Value
A.toJSON Config
defaultConfig))
where
defaultConfig :: Config
defaultConfig@Config {} = Config
forall a. Default a => a
def
unsafeValueToObject :: Value -> Object
unsafeValueToObject (A.Object Object
o) = Object
o
unsafeValueToObject Value
_ = [Char] -> Object
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
elems :: Value
elems = [Pair] -> Value
A.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat ([[Pair]] -> [Pair]) -> [[Pair]] -> [Pair]
forall a b. (a -> b) -> a -> b
$ PluginDescriptor a -> [Pair]
forall a a. KeyValue a => PluginDescriptor a -> [a]
singlePlugin (PluginDescriptor a -> [Pair]) -> [PluginDescriptor a] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PluginId, PluginDescriptor a) -> PluginDescriptor a)
-> [(PluginId, PluginDescriptor a)] -> [PluginDescriptor a]
forall a b. (a -> b) -> [a] -> [b]
map (PluginId, PluginDescriptor a) -> PluginDescriptor a
forall a b. (a, b) -> b
snd [(PluginId, PluginDescriptor a)]
ipMap
singlePlugin :: PluginDescriptor a -> [a]
singlePlugin PluginDescriptor {pluginConfigDescriptor :: forall ideState. PluginDescriptor ideState -> ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor {Bool
CustomConfig
configCustomConfig :: ConfigDescriptor -> CustomConfig
configHasDiagnostics :: ConfigDescriptor -> Bool
configEnableGenericConfig :: ConfigDescriptor -> Bool
configCustomConfig :: CustomConfig
configHasDiagnostics :: Bool
configEnableGenericConfig :: Bool
..}, [PluginCommand a]
Maybe (ParserInfo (IdeCommand a))
Rules ()
PluginId
PluginNotificationHandlers a
PluginHandlers a
DynFlagsModifications
pluginCli :: forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginModifyDynflags :: forall ideState. PluginDescriptor ideState -> DynFlagsModifications
pluginNotificationHandlers :: forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
pluginHandlers :: forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
pluginCommands :: forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginRules :: forall ideState. PluginDescriptor ideState -> Rules ()
pluginId :: forall ideState. PluginDescriptor ideState -> PluginId
pluginCli :: Maybe (ParserInfo (IdeCommand a))
pluginModifyDynflags :: DynFlagsModifications
pluginNotificationHandlers :: PluginNotificationHandlers a
pluginHandlers :: PluginHandlers a
pluginCommands :: [PluginCommand a]
pluginRules :: Rules ()
pluginId :: PluginId
..} =
let x :: [Pair]
x = [Pair]
genericDefaultConfig [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
dedicatedDefaultConfig
in [Text
pId Text -> Value -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= [Pair] -> Value
A.object [Pair]
x | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Pair] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
x]
where
(PluginHandlers (DMap IdeMethod (PluginHandler a)
-> [DSum IdeMethod (PluginHandler a)]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toList -> [DSum IdeMethod (PluginHandler a)]
handlers)) = PluginHandlers a
pluginHandlers
customConfigToDedicatedDefaultConfig :: CustomConfig -> [Pair]
customConfigToDedicatedDefaultConfig (CustomConfig Properties r
p) = Properties r -> [Pair]
forall (r :: [PropertyKey]). Properties r -> [Pair]
toDefaultJSON Properties r
p
genericDefaultConfig :: [Pair]
genericDefaultConfig =
let x :: [Pair]
x = [Text
"diagnosticsOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True | Bool
configHasDiagnostics] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> [Pair]
forall a. Eq a => [a] -> [a]
nub ([[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat (DSum IdeMethod (PluginHandler a) -> [Pair]
forall (f :: Method 'FromClient 'Request -> *).
DSum IdeMethod f -> [Pair]
handlersToGenericDefaultConfig (DSum IdeMethod (PluginHandler a) -> [Pair])
-> [DSum IdeMethod (PluginHandler a)] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DSum IdeMethod (PluginHandler a)]
handlers))
in case [Pair]
x of
[Pair
_] -> [Text
"globalOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
[Pair]
_ -> [Pair]
x
dedicatedDefaultConfig :: [Pair]
dedicatedDefaultConfig =
let x :: [Pair]
x = CustomConfig -> [Pair]
customConfigToDedicatedDefaultConfig CustomConfig
configCustomConfig
in [Text
"config" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= [Pair] -> Value
A.object [Pair]
x | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Pair] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
x]
(PluginId Text
pId) = PluginId
pluginId
handlersToGenericDefaultConfig :: DSum.DSum IdeMethod f -> [A.Pair]
handlersToGenericDefaultConfig :: DSum IdeMethod f -> [Pair]
handlersToGenericDefaultConfig (IdeMethod SMethod a
m DSum.:=> f a
_) = case SMethod a
m of
SMethod a
STextDocumentCodeAction -> [Text
"codeActionsOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
SMethod a
STextDocumentCodeLens -> [Text
"codeLensOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
SMethod a
STextDocumentRename -> [Text
"renameOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
SMethod a
STextDocumentHover -> [Text
"hoverOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
SMethod a
STextDocumentDocumentSymbol -> [Text
"symbolsOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
SMethod a
STextDocumentCompletion -> [Text
"completionOn" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True]
SMethod a
_ -> []
pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value
pluginsToVSCodeExtensionSchema :: IdePlugins a -> Value
pluginsToVSCodeExtensionSchema IdePlugins {[(PluginId, PluginDescriptor a)]
ipMap :: [(PluginId, PluginDescriptor a)]
ipMap :: forall ideState.
IdePlugins ideState -> [(PluginId, PluginDescriptor ideState)]
..} = [Pair] -> Value
A.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat ([[Pair]] -> [Pair]) -> [[Pair]] -> [Pair]
forall a b. (a -> b) -> a -> b
$ PluginDescriptor a -> [Pair]
forall a. PluginDescriptor a -> [Pair]
singlePlugin (PluginDescriptor a -> [Pair]) -> [PluginDescriptor a] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PluginId, PluginDescriptor a) -> PluginDescriptor a)
-> [(PluginId, PluginDescriptor a)] -> [PluginDescriptor a]
forall a b. (a -> b) -> [a] -> [b]
map (PluginId, PluginDescriptor a) -> PluginDescriptor a
forall a b. (a, b) -> b
snd [(PluginId, PluginDescriptor a)]
ipMap
where
singlePlugin :: PluginDescriptor a -> [Pair]
singlePlugin PluginDescriptor {pluginConfigDescriptor :: forall ideState. PluginDescriptor ideState -> ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor {Bool
CustomConfig
configCustomConfig :: CustomConfig
configHasDiagnostics :: Bool
configEnableGenericConfig :: Bool
configCustomConfig :: ConfigDescriptor -> CustomConfig
configHasDiagnostics :: ConfigDescriptor -> Bool
configEnableGenericConfig :: ConfigDescriptor -> Bool
..}, [PluginCommand a]
Maybe (ParserInfo (IdeCommand a))
Rules ()
PluginId
PluginNotificationHandlers a
PluginHandlers a
DynFlagsModifications
pluginCli :: Maybe (ParserInfo (IdeCommand a))
pluginModifyDynflags :: DynFlagsModifications
pluginNotificationHandlers :: PluginNotificationHandlers a
pluginHandlers :: PluginHandlers a
pluginCommands :: [PluginCommand a]
pluginRules :: Rules ()
pluginId :: PluginId
pluginCli :: forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginModifyDynflags :: forall ideState. PluginDescriptor ideState -> DynFlagsModifications
pluginNotificationHandlers :: forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
pluginHandlers :: forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
pluginCommands :: forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginRules :: forall ideState. PluginDescriptor ideState -> Rules ()
pluginId :: forall ideState. PluginDescriptor ideState -> PluginId
..} = [Pair]
genericSchema [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
dedicatedSchema
where
(PluginHandlers (DMap IdeMethod (PluginHandler a)
-> [DSum IdeMethod (PluginHandler a)]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toList -> [DSum IdeMethod (PluginHandler a)]
handlers)) = PluginHandlers a
pluginHandlers
customConfigToDedicatedSchema :: CustomConfig -> [Pair]
customConfigToDedicatedSchema (CustomConfig Properties r
p) = Text -> Properties r -> [Pair]
forall (r :: [PropertyKey]). Text -> Properties r -> [Pair]
toVSCodeExtensionSchema (Text -> Text
withIdPrefix Text
"config.") Properties r
p
(PluginId Text
pId) = PluginId
pluginId
genericSchema :: [Pair]
genericSchema =
let x :: [Pair]
x =
[Text -> Text
withIdPrefix Text
"diagnosticsOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"diagnostics" | Bool
configHasDiagnostics]
[Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> [Pair]
forall a. Eq a => [a] -> [a]
nub ([[Pair]] -> [Pair]
forall a. Monoid a => [a] -> a
mconcat (DSum IdeMethod (PluginHandler a) -> [Pair]
handlersToGenericSchema (DSum IdeMethod (PluginHandler a) -> [Pair])
-> [DSum IdeMethod (PluginHandler a)] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DSum IdeMethod (PluginHandler a)]
handlers))
in case [Pair]
x of
[Pair
_] -> [Text -> Text
withIdPrefix Text
"globalOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"plugin"]
[Pair]
_ -> [Pair]
x
dedicatedSchema :: [Pair]
dedicatedSchema = CustomConfig -> [Pair]
customConfigToDedicatedSchema CustomConfig
configCustomConfig
handlersToGenericSchema :: DSum IdeMethod (PluginHandler a) -> [Pair]
handlersToGenericSchema (IdeMethod m DSum.:=> PluginHandler a a
_) = case SMethod a
m of
SMethod a
STextDocumentCodeAction -> [Text -> Text
withIdPrefix Text
"codeActionsOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"code actions"]
SMethod a
STextDocumentCodeLens -> [Text -> Text
withIdPrefix Text
"codeLensOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"code lenses"]
SMethod a
STextDocumentRename -> [Text -> Text
withIdPrefix Text
"renameOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"rename"]
SMethod a
STextDocumentHover -> [Text -> Text
withIdPrefix Text
"hoverOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"hover"]
SMethod a
STextDocumentDocumentSymbol -> [Text -> Text
withIdPrefix Text
"symbolsOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"symbols"]
SMethod a
STextDocumentCompletion -> [Text -> Text
withIdPrefix Text
"completionOn" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
schemaEntry Text
"completions"]
SMethod a
_ -> []
schemaEntry :: Text -> Value
schemaEntry Text
desc =
[Pair] -> Value
A.object
[ Text
"scope" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
A.String Text
"resource",
Text
"type" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
A.String Text
"boolean",
Text
"default" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Bool
True,
Text
"description" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text -> Value
A.String (Text
"Enables " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc)
]
withIdPrefix :: Text -> Text
withIdPrefix Text
x = Text
"haskell.plugin." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x