Skip to content

Commit

Permalink
Generalise config generation
Browse files Browse the repository at this point in the history
  • Loading branch information
@fendor
fendor committed Jan 4, 2024
1 parent 726364d commit ab89a9c
Showing 1 changed file with 71 additions and 86 deletions.
157 changes: 71 additions & 86 deletions hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}

module Ide.Plugin.ConfigUtils where

Expand All @@ -17,16 +18,19 @@ import Data.String (IsString (fromString))
import qualified Data.Text as T
import Ide.Plugin.Config
import Ide.Plugin.Properties (toDefaultJSON,
toVSCodeExtensionSchema)
toVSCodeExtensionSchema, Properties, PropertyKey)
import Ide.Types
import Language.LSP.Protocol.Message
import qualified Data.Aeson.Key as A

-- Attention:
-- 'diagnosticsOn' will never be added into the default config or the schema,
-- since diagnostics emit in arbitrary shake rules -- we don't know
-- whether a plugin is capable of producing diagnostics.

-- | Generates a default 'Config', but remains only effective items
-- | Generates a default 'Config', but retains only effective items.
--
-- For each plugin, we automatically generate config items if they provide handlers
-- for code actions, etc...
-- Naturally, we also generate plugin specific configuration.
--
-- If a plugin is single purpose, e.g., only has a single method handler, we
-- omit the config, as it is sufficiently covered by "globalOn".
pluginsToDefaultConfig :: IdePlugins a -> A.Value
pluginsToDefaultConfig IdePlugins {..} =
-- Use '_Object' and 'at' to get at the "plugin" key
Expand All @@ -48,88 +52,69 @@ pluginsToDefaultConfig IdePlugins {..} =
-- }
-- }
-- }
singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} =
let x = genericDefaultConfig <> dedicatedDefaultConfig
in [fromString (T.unpack pId) A..= A.object x | not $ null x]
where
(PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p
-- Example:
--
-- {
-- "codeActionsOn": true,
-- "codeLensOn": true
-- }
--
genericDefaultConfig =
let x = ["diagnosticsOn" A..= True | configHasDiagnostics]
<> nubOrd (mconcat
(handlersToGenericDefaultConfig configInitialGenericConfig <$> handlers))
in case x of
-- if the plugin has only one capability, we produce globalOn instead of the specific one;
-- otherwise we don't produce globalOn at all
[_] -> ["globalOn" A..= plcGlobalOn configInitialGenericConfig]
_ -> x
-- Example:
--
-- {
-- "config": {
-- "property1": "foo"
-- }
--}
dedicatedDefaultConfig =
let x = customConfigToDedicatedDefaultConfig configCustomConfig
in ["config" A..= A.object x | not $ null x]

(PluginId pId) = pluginId

-- This function captures ide methods registered by the plugin, and then converts it to kv pairs
handlersToGenericDefaultConfig :: PluginConfig -> DSum.DSum IdeMethod f -> [A.Pair]
handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of
SMethod_TextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn]
SMethod_TextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn]
SMethod_TextDocumentRename -> ["renameOn" A..= plcRenameOn]
SMethod_TextDocumentHover -> ["hoverOn" A..= plcHoverOn]
SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn]
SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn]
SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn]
_ -> []
singlePlugin pd =
let
PluginId pId = pluginId pd
x = singlePluginConfig A.fromText (const A.Bool) toDefaultJSON pd
in
[fromString (T.unpack pId) A..= A.object x | not $ null x]

-- | Generates json schema used in haskell vscode extension
-- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure
pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value
pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> ipMap
where
singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = genericSchema <> dedicatedSchema
where
(PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
customConfigToDedicatedSchema (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p
(PluginId pId) = pluginId
genericSchema =
let x =
[toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" True | configHasDiagnostics]
<> nubOrd (mconcat (handlersToGenericSchema configInitialGenericConfig <$> handlers))
in case x of
-- If the plugin has only one capability, we produce globalOn instead of the specific one;
-- otherwise we don't produce globalOn at all
[_] -> [toKey' "globalOn" A..= schemaEntry "plugin" (plcGlobalOn configInitialGenericConfig)]
_ -> x
dedicatedSchema = customConfigToDedicatedSchema configCustomConfig
handlersToGenericSchema PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of
SMethod_TextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions" plcCodeActionsOn]
SMethod_TextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses" plcCodeLensOn]
SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename" plcRenameOn]
SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover" plcHoverOn]
SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols" plcSymbolsOn]
SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions" plcCompletionOn]
SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy" plcCallHierarchyOn]
_ -> []
schemaEntry desc defaultVal =
A.object
[ "scope" A..= A.String "resource",
"type" A..= A.String "boolean",
"default" A..= A.Bool defaultVal,
"description" A..= A.String ("Enables " <> pId <> " " <> desc)
]
withIdPrefix x = "haskell.plugin." <> pId <> "." <> x
toKey' = fromString . T.unpack . withIdPrefix
singlePlugin pd =
let
(PluginId plId) = pluginId pd
in
singlePluginConfig (toKey' plId) (schemaEntry plId) (toVSCodeExtensionSchema (withIdPrefix plId "config.")) pd

schemaEntry pId desc defaultVal =
A.object
[ "scope" A..= A.String "resource",
"type" A..= A.String "boolean",
"default" A..= A.Bool defaultVal,
"description" A..= A.String ("Enables " <> pId <> " " <> desc)
]
withIdPrefix pId x = "haskell.plugin." <> pId <> "." <> x
toKey' pId = fromString . T.unpack . withIdPrefix pId

-- | Helper function to generate a '[A.Pair]' encoding of a singe plugin configuration.
singlePluginConfig ::
(T.Text -> A.Key) ->
-- ^ How to modify the key in the 'A.Pair' output.
-- Called with the name of the key.
(T.Text -> Bool -> A.Value) ->
-- ^ How to create the Value in 'A.Pair'.
-- Called with a description of the value and the default value
-- it should have.
(forall (r :: [PropertyKey]) . Properties r -> [A.Pair]) ->
-- ^ Specify how custom config is serialised.
PluginDescriptor ideState ->
-- ^ PluginDescriptor for the plugin to generate the config for.
[A.Pair]
singlePluginConfig toKey valueSchemaDesc customConfigSchema PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} =
genericSchema <> dedicatedSchema
where
(PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
customConfigToDedicatedSchema (CustomConfig p) = customConfigSchema p
genericSchema =
let x =
[toKey "diagnosticsOn" A..= valueSchemaDesc "diagnostics" True | configHasDiagnostics]
<> nubOrd (mconcat (handlersToGenericSchema configInitialGenericConfig <$> handlers))
in case x of
-- If the plugin has only one capability, we produce globalOn instead of the specific one;
-- otherwise we don't produce globalOn at all
[_] -> [toKey "globalOn" A..= valueSchemaDesc "plugin" (plcGlobalOn configInitialGenericConfig)]
_ -> x
dedicatedSchema = customConfigToDedicatedSchema configCustomConfig
handlersToGenericSchema PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of
SMethod_TextDocumentCodeAction -> [toKey "codeActionsOn" A..= valueSchemaDesc "code actions" plcCodeActionsOn]
SMethod_TextDocumentCodeLens -> [toKey "codeLensOn" A..= valueSchemaDesc "code lenses" plcCodeLensOn]
SMethod_TextDocumentRename -> [toKey "renameOn" A..= valueSchemaDesc "rename" plcRenameOn]
SMethod_TextDocumentHover -> [toKey "hoverOn" A..= valueSchemaDesc "hover" plcHoverOn]
SMethod_TextDocumentDocumentSymbol -> [toKey "symbolsOn" A..= valueSchemaDesc "symbols" plcSymbolsOn]
SMethod_TextDocumentCompletion -> [toKey "completionOn" A..= valueSchemaDesc "completions" plcCompletionOn]
SMethod_TextDocumentPrepareCallHierarchy -> [toKey "callHierarchyOn" A..= valueSchemaDesc "call hierarchy" plcCallHierarchyOn]
_ -> []

0 comments on commit ab89a9c

Please sign in to comment.