Skip to content

Commit ab89a9c

Browse files
fendorfendor
committed
Generalise config generation
1 parent 726364d commit ab89a9c

File tree

1 file changed

+71
-86
lines changed

1 file changed

+71
-86
lines changed

‎hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs

Lines changed: 71 additions & 86 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE OverloadedStrings #-}
33
{-# LANGUAGE RecordWildCards #-}
44
{-# LANGUAGE ViewPatterns #-}
5+
{-# LANGUAGE RankNTypes #-}
56

67
module Ide.Plugin.ConfigUtils where
78

@@ -17,16 +18,19 @@ import Data.String (IsString (fromString))
1718
import qualified Data.Text as T
1819
import Ide.Plugin.Config
1920
import Ide.Plugin.Properties (toDefaultJSON,
20-
toVSCodeExtensionSchema)
21+
toVSCodeExtensionSchema, Properties, PropertyKey)
2122
import Ide.Types
2223
import Language.LSP.Protocol.Message
24+
import qualified Data.Aeson.Key as A
2325

24-
-- Attention:
25-
-- 'diagnosticsOn' will never be added into the default config or the schema,
26-
-- since diagnostics emit in arbitrary shake rules -- we don't know
27-
-- whether a plugin is capable of producing diagnostics.
28-
29-
-- | Generates a default 'Config', but remains only effective items
26+
-- | Generates a default 'Config', but retains only effective items.
27+
--
28+
-- For each plugin, we automatically generate config items if they provide handlers
29+
-- for code actions, etc...
30+
-- Naturally, we also generate plugin specific configuration.
31+
--
32+
-- If a plugin is single purpose, e.g., only has a single method handler, we
33+
-- omit the config, as it is sufficiently covered by "globalOn".
3034
pluginsToDefaultConfig :: IdePlugins a -> A.Value
3135
pluginsToDefaultConfig IdePlugins {..} =
3236
-- Use '_Object' and 'at' to get at the "plugin" key
@@ -48,88 +52,69 @@ pluginsToDefaultConfig IdePlugins {..} =
4852
-- }
4953
-- }
5054
-- }
51-
singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} =
52-
let x = genericDefaultConfig <> dedicatedDefaultConfig
53-
in [fromString (T.unpack pId) A..= A.object x | not $ null x]
54-
where
55-
(PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
56-
customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p
57-
-- Example:
58-
--
59-
-- {
60-
-- "codeActionsOn": true,
61-
-- "codeLensOn": true
62-
-- }
63-
--
64-
genericDefaultConfig =
65-
let x = ["diagnosticsOn" A..= True | configHasDiagnostics]
66-
<> nubOrd (mconcat
67-
(handlersToGenericDefaultConfig configInitialGenericConfig <$> handlers))
68-
in case x of
69-
-- if the plugin has only one capability, we produce globalOn instead of the specific one;
70-
-- otherwise we don't produce globalOn at all
71-
[_] -> ["globalOn" A..= plcGlobalOn configInitialGenericConfig]
72-
_ -> x
73-
-- Example:
74-
--
75-
-- {
76-
-- "config": {
77-
-- "property1": "foo"
78-
-- }
79-
--}
80-
dedicatedDefaultConfig =
81-
let x = customConfigToDedicatedDefaultConfig configCustomConfig
82-
in ["config" A..= A.object x | not $ null x]
83-
84-
(PluginId pId) = pluginId
85-
86-
-- This function captures ide methods registered by the plugin, and then converts it to kv pairs
87-
handlersToGenericDefaultConfig :: PluginConfig -> DSum.DSum IdeMethod f -> [A.Pair]
88-
handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of
89-
SMethod_TextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn]
90-
SMethod_TextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn]
91-
SMethod_TextDocumentRename -> ["renameOn" A..= plcRenameOn]
92-
SMethod_TextDocumentHover -> ["hoverOn" A..= plcHoverOn]
93-
SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn]
94-
SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn]
95-
SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn]
96-
_ -> []
55+
singlePlugin pd =
56+
let
57+
PluginId pId = pluginId pd
58+
x = singlePluginConfig A.fromText (const A.Bool) toDefaultJSON pd
59+
in
60+
[fromString (T.unpack pId) A..= A.object x | not $ null x]
9761

9862
-- | Generates json schema used in haskell vscode extension
9963
-- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure
10064
pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value
10165
pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> ipMap
10266
where
103-
singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = genericSchema <> dedicatedSchema
104-
where
105-
(PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
106-
customConfigToDedicatedSchema (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p
107-
(PluginId pId) = pluginId
108-
genericSchema =
109-
let x =
110-
[toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" True | configHasDiagnostics]
111-
<> nubOrd (mconcat (handlersToGenericSchema configInitialGenericConfig <$> handlers))
112-
in case x of
113-
-- If the plugin has only one capability, we produce globalOn instead of the specific one;
114-
-- otherwise we don't produce globalOn at all
115-
[_] -> [toKey' "globalOn" A..= schemaEntry "plugin" (plcGlobalOn configInitialGenericConfig)]
116-
_ -> x
117-
dedicatedSchema = customConfigToDedicatedSchema configCustomConfig
118-
handlersToGenericSchema PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of
119-
SMethod_TextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions" plcCodeActionsOn]
120-
SMethod_TextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses" plcCodeLensOn]
121-
SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename" plcRenameOn]
122-
SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover" plcHoverOn]
123-
SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols" plcSymbolsOn]
124-
SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions" plcCompletionOn]
125-
SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy" plcCallHierarchyOn]
126-
_ -> []
127-
schemaEntry desc defaultVal =
128-
A.object
129-
[ "scope" A..= A.String "resource",
130-
"type" A..= A.String "boolean",
131-
"default" A..= A.Bool defaultVal,
132-
"description" A..= A.String ("Enables " <> pId <> " " <> desc)
133-
]
134-
withIdPrefix x = "haskell.plugin." <> pId <> "." <> x
135-
toKey' = fromString . T.unpack . withIdPrefix
67+
singlePlugin pd =
68+
let
69+
(PluginId plId) = pluginId pd
70+
in
71+
singlePluginConfig (toKey' plId) (schemaEntry plId) (toVSCodeExtensionSchema (withIdPrefix plId "config.")) pd
72+
73+
schemaEntry pId desc defaultVal =
74+
A.object
75+
[ "scope" A..= A.String "resource",
76+
"type" A..= A.String "boolean",
77+
"default" A..= A.Bool defaultVal,
78+
"description" A..= A.String ("Enables " <> pId <> " " <> desc)
79+
]
80+
withIdPrefix pId x = "haskell.plugin." <> pId <> "." <> x
81+
toKey' pId = fromString . T.unpack . withIdPrefix pId
82+
83+
-- | Helper function to generate a '[A.Pair]' encoding of a singe plugin configuration.
84+
singlePluginConfig ::
85+
(T.Text -> A.Key) ->
86+
-- ^ How to modify the key in the 'A.Pair' output.
87+
-- Called with the name of the key.
88+
(T.Text -> Bool -> A.Value) ->
89+
-- ^ How to create the Value in 'A.Pair'.
90+
-- Called with a description of the value and the default value
91+
-- it should have.
92+
(forall (r :: [PropertyKey]) . Properties r -> [A.Pair]) ->
93+
-- ^ Specify how custom config is serialised.
94+
PluginDescriptor ideState ->
95+
-- ^ PluginDescriptor for the plugin to generate the config for.
96+
[A.Pair]
97+
singlePluginConfig toKey valueSchemaDesc customConfigSchema PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} =
98+
genericSchema <> dedicatedSchema
99+
where
100+
(PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
101+
customConfigToDedicatedSchema (CustomConfig p) = customConfigSchema p
102+
genericSchema =
103+
let x =
104+
[toKey "diagnosticsOn" A..= valueSchemaDesc "diagnostics" True | configHasDiagnostics]
105+
<> nubOrd (mconcat (handlersToGenericSchema configInitialGenericConfig <$> handlers))
106+
in case x of
107+
-- If the plugin has only one capability, we produce globalOn instead of the specific one;
108+
-- otherwise we don't produce globalOn at all
109+
[_] -> [toKey "globalOn" A..= valueSchemaDesc "plugin" (plcGlobalOn configInitialGenericConfig)]
110+
_ -> x
111+
dedicatedSchema = customConfigToDedicatedSchema configCustomConfig
112+
handlersToGenericSchema PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of
113+
SMethod_TextDocumentCodeAction -> [toKey "codeActionsOn" A..= valueSchemaDesc "code actions" plcCodeActionsOn]
114+
SMethod_TextDocumentCodeLens -> [toKey "codeLensOn" A..= valueSchemaDesc "code lenses" plcCodeLensOn]
115+
SMethod_TextDocumentRename -> [toKey "renameOn" A..= valueSchemaDesc "rename" plcRenameOn]
116+
SMethod_TextDocumentHover -> [toKey "hoverOn" A..= valueSchemaDesc "hover" plcHoverOn]
117+
SMethod_TextDocumentDocumentSymbol -> [toKey "symbolsOn" A..= valueSchemaDesc "symbols" plcSymbolsOn]
118+
SMethod_TextDocumentCompletion -> [toKey "completionOn" A..= valueSchemaDesc "completions" plcCompletionOn]
119+
SMethod_TextDocumentPrepareCallHierarchy -> [toKey "callHierarchyOn" A..= valueSchemaDesc "call hierarchy" plcCallHierarchyOn]
120+
_ -> []

0 commit comments

Comments
 (0)