Regularize custom config of plugins

exe/Plugins.hs

@@ -100,7 +100,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
       Fourmolu.descriptor "fourmolu" :
 #endif
 #if tactic
-      Tactic.descriptor "tactic" :
+      Tactic.descriptor "tactics" :
 #endif
 #if ormolu
       Ormolu.descriptor   "ormolu" :

ghcide/exe/Arguments.hs

@@ -11,16 +11,18 @@ type Arguments = Arguments' IdeCmd
 data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP
 
 data Arguments' a = Arguments
-    {argLSP                :: Bool
-    ,argsCwd               :: Maybe FilePath
-    ,argsVersion           :: Bool
-    ,argsShakeProfiling    :: Maybe FilePath
-    ,argsOTMemoryProfiling :: Bool
-    ,argsTesting           :: Bool
-    ,argsDisableKick       :: Bool
-    ,argsThreads           :: Int
-    ,argsVerbose           :: Bool
-    ,argFilesOrCmd         :: a
+    {argLSP                    :: Bool
+    ,argsCwd                   :: Maybe FilePath
+    ,argsVersion               :: Bool
+    ,argsVSCodeExtensionSchema :: Bool
+    ,argsDefaultConfig         :: Bool
+    ,argsShakeProfiling        :: Maybe FilePath
+    ,argsOTMemoryProfiling     :: Bool
+    ,argsTesting               :: Bool
+    ,argsDisableKick           :: Bool
+    ,argsThreads               :: Int
+    ,argsVerbose               :: Bool
+    ,argFilesOrCmd             :: a
     }
 
 getArguments :: IO Arguments
@@ -35,6 +37,8 @@ arguments = Arguments
       <$> switch (long "lsp" <> help "Start talking to an LSP client")
       <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
       <*> switch (long "version" <> help "Show ghcide and GHC versions")
+      <*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
+      <*> switch (long "generate-default-config" <> help "Print config supported by the server with default values")
       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
       <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")

ghcide/exe/Main.hs

@@ -9,11 +9,14 @@ import           Arguments                         (Arguments' (..),
                                                     IdeCmd (..), getArguments)
 import           Control.Concurrent.Extra          (newLock, withLock)
 import           Control.Monad.Extra               (unless, when, whenJust)
+import qualified Data.Aeson.Encode.Pretty          as A
 import           Data.Default                      (Default (def))
 import           Data.List.Extra                   (upper)
 import           Data.Maybe                        (fromMaybe)
 import qualified Data.Text                         as T
 import qualified Data.Text.IO                      as T
+import           Data.Text.Lazy.Encoding           (decodeUtf8)
+import qualified Data.Text.Lazy.IO                 as LT
 import           Data.Version                      (showVersion)
 import           Development.GitRev                (gitHash)
 import           Development.IDE                   (Logger (Logger),
@@ -29,6 +32,8 @@ import           Development.IDE.Types.Options
 import           Development.Shake                 (ShakeOptions (shakeThreads))
 import           HieDb.Run                         (Options (..), runCommand)
 import           Ide.Plugin.Config                 (Config (checkParents, checkProject))
+import           Ide.Plugin.ConfigUtils            (pluginsToDefaultConfig,
+                                                    pluginsToVSCodeExtensionSchema)
 import           Ide.PluginUtils                   (pluginDescToIdePlugins)
 import           Paths_ghcide                      (version)
 import qualified System.Directory.Extra            as IO
@@ -58,6 +63,16 @@ main = do
     if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
     else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
 
+    let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
+
+    when argsVSCodeExtensionSchema $ do
+      LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema hlsPlugins
+      exitSuccess
+
+    when argsDefaultConfig $ do
+      LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins
+      exitSuccess
+
     whenJust argsCwd IO.setCurrentDirectory
 
     -- lock to avoid overlapping output on stdout

ghcide/ghcide.cabal

@@ -284,7 +284,8 @@ executable ghcide
         optparse-applicative,
         shake,
         text,
-        unordered-containers
+        unordered-containers,
+        aeson-pretty
     other-modules:
         Arguments
         Paths_ghcide

ghcide/src/Development/IDE/Plugin/TypeLenses.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TypeFamilies   #-}
+{-# LANGUAGE DeriveAnyClass   #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies     #-}
 
 -- | An HLS plugin to provide code lenses for type signatures
 module Development.IDE.Plugin.TypeLenses (
@@ -13,16 +14,12 @@ module Development.IDE.Plugin.TypeLenses (
 
 import           Avail                               (availsToNameSet)
 import           Control.DeepSeq                     (rwhnf)
-import           Control.Monad                       (join)
 import           Control.Monad.Extra                 (whenMaybe)
 import           Control.Monad.IO.Class              (MonadIO (liftIO))
-import qualified Data.Aeson                          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,
-                                                      fromMaybe)
+import           Data.Maybe                          (catMaybes, fromJust)
 import qualified Data.Text                           as T
 import           Development.IDE                     (GhcSession (..),
                                                       HscEnvEq (hscEnv),
@@ -52,16 +49,17 @@ import           GhcPlugins                          (GlobalRdrEnv,
                                                       realSrcLocSpan,
                                                       tidyOpenType)
 import           HscTypes                            (mkPrintUnqualified)
-import           Ide.Plugin.Config                   (Config,
-                                                      PluginConfig (plcConfig))
-import           Ide.PluginUtils                     (getPluginConfig,
-                                                      mkLspCommand)
+import           Ide.Plugin.Config                   (Config)
+import           Ide.Plugin.Properties
+import           Ide.PluginUtils                     (mkLspCommand,
+                                                      usePropertyLsp)
 import           Ide.Types                           (CommandFunction,
                                                       CommandId (CommandId),
                                                       PluginCommand (PluginCommand),
                                                       PluginDescriptor (..),
                                                       PluginId,
                                                       defaultPluginDescriptor,
+                                                      mkCustomConfig,
                                                       mkPluginHandler)
 import qualified Language.LSP.Server                 as LSP
 import           Language.LSP.Types                  (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
@@ -90,15 +88,24 @@ descriptor plId =
     { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider
     , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
     , pluginRules = rules
+    , pluginCustomConfig = mkCustomConfig properties
     }
 
+properties :: Properties '[ 'PropertyKey "mode" 'TEnum]
+properties = emptyProperties
+  & defineEnumProperty #mode "Control how type lenses are shown"
+    [ ("always", "Always displays type lenses of global bindings")
+    , ("exported", "Only display type lenses of exported global bindings")
+    , ("diagnostics", "Follows error messages produced by GHC about missing signatures")
+    ] "always"
+
 codeLensProvider ::
   IdeState ->
   PluginId ->
   CodeLensParams ->
   LSP.LspM Config (Either ResponseError (List CodeLens))
 codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do
-  (fromMaybe Always . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId
+  mode <- readMode <$> usePropertyLsp #mode pId properties
   fmap (Right . List) $ case uriToFilePath' uri of
     Just (toNormalizedFilePath' -> filePath) -> liftIO $ do
       tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)
@@ -202,14 +209,6 @@ data Mode
     Diagnostics
   deriving (Eq, Ord, Show, Read, Enum)
 
-instance A.FromJSON Mode where
-  parseJSON = A.withText "Mode" $ \s ->
-    case T.toLower s of
-      "always"      -> pure Always
-      "exported"    -> pure Exported
-      "diagnostics" -> pure Diagnostics
-      _             -> A.unexpected (A.String s)
-
 --------------------------------------------------------------------------------
 
 showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String
@@ -246,8 +245,13 @@ rules = do
     result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr)
     pure ([], result)
 
-parseCustomConfig :: A.Object -> Maybe Mode
-parseCustomConfig = A.parseMaybe (A..: "mode")
+readMode :: T.Text -> Mode
+readMode = \case
+  "always"      -> Always
+  "exported"    -> Exported
+  "diagnostics" -> Diagnostics
+  -- actually it never happens because of 'usePropertyLsp'
+  _             -> error "failed to parse type lenses mode"
 
 gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult)
 gblBindingType (Just hsc) (Just gblEnv) = do

haskell-language-server.cabal

@@ -69,6 +69,7 @@ library
     , safe-exceptions
     , sqlite-simple
     , unordered-containers
+    , aeson-pretty
 
   ghc-options:      -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors
 

hls-plugin-api/hls-plugin-api.cabal

@@ -27,6 +27,8 @@ library
   exposed-modules:
     Ide.Logger
     Ide.Plugin.Config
+    Ide.Plugin.ConfigUtils
+    Ide.Plugin.Properties
     Ide.PluginUtils
     Ide.Types
 

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

@@ -0,0 +1,127 @@
+{-# 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 qualified Data.Map              as Map
+import           Ide.Plugin.Config
+import           Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)
+import           Ide.Types
+import           Language.LSP.Types
+
+-- 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 defalut 'Config', but remains only effective items
+pluginsToDefaultConfig :: IdePlugins a -> A.Value
+pluginsToDefaultConfig IdePlugins {..} =
+  A.Object $
+    HMap.adjust
+      ( \(unsafeValueToObject -> o) ->
+          A.Object $ HMap.insert "plugin" elems o -- inplace the "plugin" section with our 'elems', leaving others unchanged
+      )
+      "haskell"
+      (unsafeValueToObject (A.toJSON defaultConfig))
+  where
+    defaultConfig@Config {} = def
+    unsafeValueToObject (A.Object o) = o
+    unsafeValueToObject _            = error "impossible"
+    elems = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap
+    -- Splice genericDefaultConfig and dedicatedDefaultConfig
+    -- Example:
+    --
+    -- {
+    --  "plugin-id": {
+    --    "globalOn": true,
+    --    "codeActionsOn": true,
+    --    "codeLensOn": true,
+    --    "config": {
+    --      "property1": "foo"
+    --     }
+    --   }
+    -- }
+    singlePlugin PluginDescriptor {..} =
+      let x = genericDefaultConfig <> dedicatedDefaultConfig
+       in [pId A..= A.object x | not $ null x]
+      where
+        (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
+        customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p
+        -- 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
+        -- Example:
+        --
+        -- {
+        --  "config": {
+        --      "property1": "foo"
+        --   }
+        --}
+        dedicatedDefaultConfig =
+          let x = customConfigToDedicatedDefaultConfig pluginCustomConfig
+           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 :: DSum.DSum IdeMethod f -> [A.Pair]
+        handlersToGenericDefaultConfig (IdeMethod m DSum.:=> _) = case m of
+          STextDocumentCodeAction     -> ["codeActionsOn" A..= True]
+          STextDocumentCodeLens       -> ["codeLensOn" A..= True]
+          STextDocumentRename         -> ["renameOn" A..= True]
+          STextDocumentHover          -> ["hoverOn" A..= True]
+          STextDocumentDocumentSymbol -> ["symbolsOn" A..= True]
+          STextDocumentCompletion     -> ["completionOn" A..= True]
+          _                           -> []
+
+-- | 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 <$> Map.elems ipMap
+  where
+    singlePlugin PluginDescriptor {..} = 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
+        handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of
+          STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= schemaEntry "code actions"]
+          STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= schemaEntry "code lenses"]
+          STextDocumentRename -> [withIdPrefix "renameOn" A..= schemaEntry "rename"]
+          STextDocumentHover -> [withIdPrefix "hoverOn" A..= schemaEntry "hover"]
+          STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= schemaEntry "symbols"]
+          STextDocumentCompletion -> [withIdPrefix "completionOn" A..= schemaEntry "completions"]
+          _ -> []
+        schemaEntry desc =
+          A.object
+            [ "scope" A..= A.String "resource",
+              "type" A..= A.String "boolean",
+              "default" A..= True,
+              "description" A..= A.String ("Enables " <> pId <> " " <> desc)
+            ]
+        withIdPrefix x = "haskell.plugin." <> pId <> "." <> x