Imporve vscode extension schema generation (haskell#1742)

berberman · jneira · web-flow · commit 98ffe9490925 · 2021-04-19T09:49:38.000Z
Co-authored-by: Javier Neira &lt;atreyu.bbb@gmail.com&gt;
diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs
@@ -47,7 +47,7 @@ descriptor plId = (defaultPluginDescriptor plId)
   { pluginRules = produceCompletions
   , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP
   , pluginCommands = [extendImportCommand]
-  , pluginCustomConfig = mkCustomConfig properties
+  , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
   }
 
 produceCompletions :: Rules ()
diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs
@@ -33,7 +33,8 @@ descriptors =
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId = (defaultPluginDescriptor plId)
   { pluginHandlers = mkPluginHandler STextDocumentHover hover'
-                  <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider
+                  <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider,
+    pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False}
   }
 
 -- ---------------------------------------------------------------------
diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs
@@ -17,8 +17,8 @@ import           Control.DeepSeq                     (rwhnf)
 import           Control.Monad                       (mzero)
 import           Control.Monad.Extra                 (whenMaybe)
 import           Control.Monad.IO.Class              (MonadIO (liftIO))
-import qualified Data.Aeson.Types                    as A
 import           Data.Aeson.Types                    (Value (..), toJSON)
+import qualified Data.Aeson.Types                    as A
 import qualified Data.HashMap.Strict                 as Map
 import           Data.List                           (find)
 import           Data.Maybe                          (catMaybes, fromJust)
@@ -60,6 +60,8 @@ import           Ide.Types                           (CommandFunction,
                                                       PluginCommand (PluginCommand),
                                                       PluginDescriptor (..),
                                                       PluginId,
+                                                      configCustomConfig,
+                                                      defaultConfigDescriptor,
                                                       defaultPluginDescriptor,
                                                       mkCustomConfig,
                                                       mkPluginHandler)
@@ -90,7 +92,7 @@ descriptor plId =
     { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider
     , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
     , pluginRules = rules
-    , pluginCustomConfig = mkCustomConfig properties
+    , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
     }
 
 properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
@@ -212,8 +214,8 @@ data Mode
   deriving (Eq, Ord, Show, Read, Enum)
 
 instance A.ToJSON Mode where
-  toJSON Always = "always"
-  toJSON Exported = "exported"
+  toJSON Always      = "always"
+  toJSON Exported    = "exported"
   toJSON Diagnostics = "diagnostics"
 
 instance A.FromJSON Mode where
diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs
@@ -5,14 +5,16 @@
 
 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 qualified Data.Aeson                as A
+import qualified Data.Aeson.Types          as A
+import           Data.Containers.ListUtils (nubOrd)
+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           Ide.Plugin.Config
-import           Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)
+import           Ide.Plugin.Properties     (toDefaultJSON,
+                                            toVSCodeExtensionSchema)
 import           Ide.Types
 import           Language.LSP.Types
 
@@ -49,7 +51,7 @@ pluginsToDefaultConfig IdePlugins {..} =
     --     }
     --   }
     -- }
-    singlePlugin PluginDescriptor {..} =
+    singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} =
       let x = genericDefaultConfig <> dedicatedDefaultConfig
        in [pId A..= A.object x | not $ null x]
       where
@@ -58,20 +60,17 @@ pluginsToDefaultConfig IdePlugins {..} =
         -- Example:
         --
         -- {
-        --   "globalOn": true,
         --   "codeActionsOn": true,
         --   "codeLensOn": true
         -- }
         --
-        -- we don't generate the config section if the plugin doesn't register any of the following six methods,
-        -- which avoids producing trivial configuration for formatters:
-        --
-        -- "stylish-haskell": {
-        --    "globalOn": true
-        -- }
         genericDefaultConfig =
-          let x = mconcat (handlersToGenericDefaultConfig <$> handlers)
-           in ["globalOn" A..= True | not $ null x] <> x
+          let x = ["diagnosticsOn" A..= True | configHasDiagnostics] <> nubOrd (mconcat (handlersToGenericDefaultConfig <$> 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..= True]
+                _   -> x
         -- Example:
         --
         -- {
@@ -80,7 +79,7 @@ pluginsToDefaultConfig IdePlugins {..} =
         --   }
         --}
         dedicatedDefaultConfig =
-          let x = customConfigToDedicatedDefaultConfig pluginCustomConfig
+          let x = customConfigToDedicatedDefaultConfig configCustomConfig
            in ["config" A..= A.object x | not $ null x]
 
         (PluginId pId) = pluginId
@@ -101,13 +100,21 @@ pluginsToDefaultConfig IdePlugins {..} =
 pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value
 pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> map snd ipMap
   where
-    singlePlugin PluginDescriptor {..} = genericSchema <> dedicatedSchema
+    singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = genericSchema <> dedicatedSchema
       where
         (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
         customConfigToDedicatedSchema (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p
         (PluginId pId) = pluginId
-        genericSchema = withIdPrefix "globalOn" A..= schemaEntry "plugin" : mconcat (handlersToGenericSchema <$> handlers)
-        dedicatedSchema = customConfigToDedicatedSchema pluginCustomConfig
+        genericSchema =
+          let x =
+                [withIdPrefix "diagnosticsOn" A..= schemaEntry "diagnostics" | configHasDiagnostics]
+                  <> nubOrd (mconcat (handlersToGenericSchema <$> 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
+                [_] -> [withIdPrefix "globalOn" A..= schemaEntry "plugin"]
+                _   -> x
+        dedicatedSchema = customConfigToDedicatedSchema configCustomConfig
         handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of
           STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= schemaEntry "code actions"]
           STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= schemaEntry "code lenses"]
diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs
@@ -63,19 +63,47 @@ data PluginDescriptor ideState =
                    , pluginRules        :: !(Rules ())
                    , pluginCommands     :: ![PluginCommand ideState]
                    , pluginHandlers     :: PluginHandlers ideState
-                   , pluginCustomConfig :: CustomConfig
+                   , pluginConfigDescriptor :: ConfigDescriptor
                    , pluginNotificationHandlers :: PluginNotificationHandlers ideState
                    }
 
--- | An existential wrapper of 'Properties', used only for documenting and generating config templates
+-- | An existential wrapper of 'Properties'
 data CustomConfig = forall r. CustomConfig (Properties r)
 
-emptyCustomConfig :: CustomConfig
-emptyCustomConfig = CustomConfig emptyProperties
+-- | Describes the configuration a plugin.
+-- A plugin may be configurable in such form:
+-- @
+-- {
+--  "plugin-id": {
+--    "globalOn": true,
+--    "codeActionsOn": true,
+--    "codeLensOn": true,
+--    "config": {
+--      "property1": "foo"
+--     }
+--   }
+-- }
+-- @
+-- @globalOn@, @codeActionsOn@, and @codeLensOn@ etc. are called generic configs,
+-- which can be inferred from handlers registered by the plugin.
+-- @config@ is called custom config, which is defined using 'Properties'.
+data ConfigDescriptor = ConfigDescriptor {
+  -- | Whether or not to generate generic configs.
+  configEnableGenericConfig :: Bool,
+  -- | Whether or not to generate @diagnosticsOn@ config.
+  -- Diagnostics emit in arbitrary shake rules,
+  -- so we can't know statically if the plugin produces diagnostics
+  configHasDiagnostics      :: Bool,
+  -- | Custom config.
+  configCustomConfig        :: CustomConfig
+}
 
 mkCustomConfig :: Properties r -> CustomConfig
 mkCustomConfig = CustomConfig
 
+defaultConfigDescriptor :: ConfigDescriptor
+defaultConfigDescriptor = ConfigDescriptor True False (mkCustomConfig emptyProperties)
+
 -- | Methods that can be handled by plugins.
 -- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method
 -- Only methods for which we know how to combine responses can be instances of 'PluginMethod'
@@ -267,7 +295,7 @@ defaultPluginDescriptor plId =
     mempty
     mempty
     mempty
-    emptyCustomConfig
+    defaultConfigDescriptor
     mempty
 
 newtype CommandId = CommandId T.Text
diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
@@ -96,6 +96,7 @@ descriptor plId = (defaultPluginDescriptor plId)
       , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
       ]
     , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider
+    , pluginConfigDescriptor = defaultConfigDescriptor {configHasDiagnostics = True}
   }
 
 -- This rule only exists for generating file diagnostics
diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs
@@ -60,8 +60,8 @@ descriptor plId = (defaultPluginDescriptor plId)
       , mkPluginHandler STextDocumentCodeLens codeLensProvider
       ]
   , pluginRules = wingmanRules plId
-  , pluginCustomConfig =
-      mkCustomConfig properties
+  , pluginConfigDescriptor =
+      defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
   }
 
 

Original file line number	Diff line number	Diff line change
`@@ -47,7 +47,7 @@ descriptor plId = (defaultPluginDescriptor plId)`
`47`	`47`	`{ pluginRules = produceCompletions`
`48`	`48`	`, pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP`
`49`	`49`	`, pluginCommands = [extendImportCommand]`
`50`		`- , pluginCustomConfig = mkCustomConfig properties`
	`50`	`+ , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}`
`51`	`51`	`}`
`52`	`52`
`53`	`53`	`produceCompletions :: Rules ()`
Original file line number	Diff line number	Diff line change
`@@ -33,7 +33,8 @@ descriptors =`
`33`	`33`	`descriptor :: PluginId -> PluginDescriptor IdeState`
`34`	`34`	`descriptor plId = (defaultPluginDescriptor plId)`
`35`	`35`	`{ pluginHandlers = mkPluginHandler STextDocumentHover hover'`
`36`		`- <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider`
	`36`	`+ <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider,`
	`37`	`+ pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False}`
`37`	`38`	`}`
`38`	`39`
`39`	`40`	`-- ---------------------------------------------------------------------`
Original file line number	Diff line number	Diff line change
`@@ -96,6 +96,7 @@ descriptor plId = (defaultPluginDescriptor plId)`
`96`	`96`	`, PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd`
`97`	`97`	`]`
`98`	`98`	`, pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider`
	`99`	`+ , pluginConfigDescriptor = defaultConfigDescriptor {configHasDiagnostics = True}`
`99`	`100`	`}`
`100`	`101`
`101`	`102`	`-- This rule only exists for generating file diagnostics`
Original file line number	Diff line number	Diff line change
`@@ -60,8 +60,8 @@ descriptor plId = (defaultPluginDescriptor plId)`
`60`	`60`	`, mkPluginHandler STextDocumentCodeLens codeLensProvider`
`61`	`61`	`]`
`62`	`62`	`, pluginRules = wingmanRules plId`
`63`		`- , pluginCustomConfig =`
`64`		`- mkCustomConfig properties`
	`63`	`+ , pluginConfigDescriptor =`
	`64`	`+ defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}`
`65`	`65`	`}`
`66`	`66`
`67`	`67`