Regularize custom config of plugins

ghcide/exe/Arguments.hs

@@ -11,16 +11,17 @@ 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
+    ,argsVSCodeExtensionConfig :: Bool
+    ,argsShakeProfiling        :: Maybe FilePath
+    ,argsOTMemoryProfiling     :: Bool
+    ,argsTesting               :: Bool
+    ,argsDisableKick           :: Bool
+    ,argsThreads               :: Int
+    ,argsVerbose               :: Bool
+    ,argFilesOrCmd             :: a
     }
 
 getArguments :: IO Arguments
@@ -35,6 +36,7 @@ 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)")
       <*> 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,7 @@ 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            (pluginsToVSCodeExtensionSchema)
 import           Ide.PluginUtils                   (pluginDescToIdePlugins)
 import           Paths_ghcide                      (version)
 import qualified System.Directory.Extra            as IO
@@ -58,6 +62,13 @@ main = do
     if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
     else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
 
+    let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
+
+    when argsVSCodeExtensionConfig $ do
+      LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema 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

@@ -13,16 +13,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 +48,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 +87,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 +208,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 +244,12 @@ 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
+  _             -> 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,41 @@
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE ViewPatterns      #-}
+
+module Ide.Plugin.ConfigUtils where
+
+import qualified Data.Aeson            as A
+import qualified Data.Dependent.Map    as DMap
+import qualified Data.Dependent.Sum    as DSum
+import qualified Data.Map              as Map
+import           Ide.Plugin.Properties (toVSCodeExtensionSchema)
+import           Ide.Types
+import           Language.LSP.Types
+
+pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value
+pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap
+  where
+    singlePlugin PluginDescriptor {..} = genericConfig <> dedicatedConfig
+      where
+        (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
+        customConfigToDedicatedConfig (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p
+        (PluginId pId) = pluginId
+        genericConfig = withIdPrefix "globalOn" A..= methodEntry "plugin" : mconcat (handlersToGenericConfig <$> handlers)
+        dedicatedConfig = customConfigToDedicatedConfig pluginCustomConfig
+        handlersToGenericConfig (IdeMethod m DSum.:=> _) = case m of
+          STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= methodEntry "code actions"]
+          STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= methodEntry "code lenses"]
+          STextDocumentRename -> [withIdPrefix "renameOn" A..= methodEntry "rename"]
+          STextDocumentHover -> [withIdPrefix "hoverOn" A..= methodEntry "hover"]
+          STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= methodEntry "symbols"]
+          STextDocumentCompletion -> [withIdPrefix "completionOn" A..= methodEntry "completions"]
+          _ -> []
+        methodEntry 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