Skip to content

Commit f135edb

Browse files
berbermanisovectormergify[bot]
authored
Regularize custom config of plugins (#1576)
* Support declarative custom config, add --vscode-extension-schema * Add globalOn * Add --generate-default-config * Port tactic plugin * Fix build of tactic plugin test * Fix tactic plugin test * Revert format changes in tactics plugin * Change the descriptor of tactics plugin to "tactics" * Update plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs Co-authored-by: Sandy Maguire <sandy@sandymaguire.me> * Apply a bunch of @isovector's suggestions * Document Ide.Plugin.ConfigUtils * Add TInteger * Fix build Co-authored-by: Sandy Maguire <sandy@sandymaguire.me> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 982c4ee commit f135edb

File tree

18 files changed

+738
-111
lines changed

18 files changed

+738
-111
lines changed

‎exe/Plugins.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -100,7 +100,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
100100
Fourmolu.descriptor "fourmolu" :
101101
#endif
102102
#if tactic
103-
Tactic.descriptor "tactic" :
103+
Tactic.descriptor "tactics" :
104104
#endif
105105
#if ormolu
106106
Ormolu.descriptor "ormolu" :

‎ghcide/exe/Arguments.hs‎

Lines changed: 14 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -11,16 +11,18 @@ type Arguments = Arguments' IdeCmd
1111
data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP
1212

1313
data Arguments' a = Arguments
14-
{argLSP :: Bool
15-
,argsCwd :: Maybe FilePath
16-
,argsVersion :: Bool
17-
,argsShakeProfiling :: Maybe FilePath
18-
,argsOTMemoryProfiling :: Bool
19-
,argsTesting :: Bool
20-
,argsDisableKick :: Bool
21-
,argsThreads :: Int
22-
,argsVerbose :: Bool
23-
,argFilesOrCmd :: a
14+
{argLSP :: Bool
15+
,argsCwd :: Maybe FilePath
16+
,argsVersion :: Bool
17+
,argsVSCodeExtensionSchema :: Bool
18+
,argsDefaultConfig :: Bool
19+
,argsShakeProfiling :: Maybe FilePath
20+
,argsOTMemoryProfiling :: Bool
21+
,argsTesting :: Bool
22+
,argsDisableKick :: Bool
23+
,argsThreads :: Int
24+
,argsVerbose :: Bool
25+
,argFilesOrCmd :: a
2426
}
2527

2628
getArguments :: IO Arguments
@@ -35,6 +37,8 @@ arguments = Arguments
3537
<$> switch (long "lsp" <> help "Start talking to an LSP client")
3638
<*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
3739
<*> switch (long "version" <> help "Show ghcide and GHC versions")
40+
<*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
41+
<*> switch (long "generate-default-config" <> help "Print config supported by the server with default values")
3842
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
3943
<*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
4044
<*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")

‎ghcide/exe/Main.hs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,11 +9,14 @@ import Arguments (Arguments' (..),
99
IdeCmd (..), getArguments)
1010
import Control.Concurrent.Extra (newLock, withLock)
1111
import Control.Monad.Extra (unless, when, whenJust)
12+
import qualified Data.Aeson.Encode.Pretty as A
1213
import Data.Default (Default (def))
1314
import Data.List.Extra (upper)
1415
import Data.Maybe (fromMaybe)
1516
import qualified Data.Text as T
1617
import qualified Data.Text.IO as T
18+
import Data.Text.Lazy.Encoding (decodeUtf8)
19+
import qualified Data.Text.Lazy.IO as LT
1720
import Data.Version (showVersion)
1821
import Development.GitRev (gitHash)
1922
import Development.IDE (Logger (Logger),
@@ -29,6 +32,8 @@ import Development.IDE.Types.Options
2932
import Development.Shake (ShakeOptions (shakeThreads))
3033
import HieDb.Run (Options (..), runCommand)
3134
import Ide.Plugin.Config (Config (checkParents, checkProject))
35+
import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,
36+
pluginsToVSCodeExtensionSchema)
3237
import Ide.PluginUtils (pluginDescToIdePlugins)
3338
import Paths_ghcide (version)
3439
import qualified System.Directory.Extra as IO
@@ -58,6 +63,16 @@ main = do
5863
if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
5964
else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
6065

66+
let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
67+
68+
when argsVSCodeExtensionSchema $ do
69+
LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema hlsPlugins
70+
exitSuccess
71+
72+
when argsDefaultConfig $ do
73+
LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins
74+
exitSuccess
75+
6176
whenJust argsCwd IO.setCurrentDirectory
6277

6378
-- lock to avoid overlapping output on stdout

‎ghcide/ghcide.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -284,7 +284,8 @@ executable ghcide
284284
optparse-applicative,
285285
shake,
286286
text,
287-
unordered-containers
287+
unordered-containers,
288+
aeson-pretty
288289
other-modules:
289290
Arguments
290291
Paths_ghcide

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

Lines changed: 26 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
1-
{-# LANGUAGE DeriveAnyClass #-}
2-
{-# LANGUAGE TypeFamilies #-}
1+
{-# LANGUAGE DeriveAnyClass #-}
2+
{-# LANGUAGE OverloadedLabels #-}
3+
{-# LANGUAGE TypeFamilies #-}
34

45
-- | An HLS plugin to provide code lenses for type signatures
56
module Development.IDE.Plugin.TypeLenses (
@@ -13,16 +14,12 @@ module Development.IDE.Plugin.TypeLenses (
1314

1415
import Avail (availsToNameSet)
1516
import Control.DeepSeq (rwhnf)
16-
import Control.Monad (join)
1717
import Control.Monad.Extra (whenMaybe)
1818
import Control.Monad.IO.Class (MonadIO (liftIO))
19-
import qualified Data.Aeson as A
2019
import Data.Aeson.Types (Value (..), toJSON)
21-
import qualified Data.Aeson.Types as A
2220
import qualified Data.HashMap.Strict as Map
2321
import Data.List (find)
24-
import Data.Maybe (catMaybes, fromJust,
25-
fromMaybe)
22+
import Data.Maybe (catMaybes, fromJust)
2623
import qualified Data.Text as T
2724
import Development.IDE (GhcSession (..),
2825
HscEnvEq (hscEnv),
@@ -52,16 +49,17 @@ import GhcPlugins (GlobalRdrEnv,
5249
realSrcLocSpan,
5350
tidyOpenType)
5451
import HscTypes (mkPrintUnqualified)
55-
import Ide.Plugin.Config (Config,
56-
PluginConfig (plcConfig))
57-
import Ide.PluginUtils (getPluginConfig,
58-
mkLspCommand)
52+
import Ide.Plugin.Config (Config)
53+
import Ide.Plugin.Properties
54+
import Ide.PluginUtils (mkLspCommand,
55+
usePropertyLsp)
5956
import Ide.Types (CommandFunction,
6057
CommandId (CommandId),
6158
PluginCommand (PluginCommand),
6259
PluginDescriptor (..),
6360
PluginId,
6461
defaultPluginDescriptor,
62+
mkCustomConfig,
6563
mkPluginHandler)
6664
import qualified Language.LSP.Server as LSP
6765
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
@@ -90,15 +88,24 @@ descriptor plId =
9088
{ pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider
9189
, pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
9290
, pluginRules = rules
91+
, pluginCustomConfig = mkCustomConfig properties
9392
}
9493

94+
properties :: Properties '[ 'PropertyKey "mode" 'TEnum]
95+
properties = emptyProperties
96+
& defineEnumProperty #mode "Control how type lenses are shown"
97+
[ ("always", "Always displays type lenses of global bindings")
98+
, ("exported", "Only display type lenses of exported global bindings")
99+
, ("diagnostics", "Follows error messages produced by GHC about missing signatures")
100+
] "always"
101+
95102
codeLensProvider ::
96103
IdeState ->
97104
PluginId ->
98105
CodeLensParams ->
99106
LSP.LspM Config (Either ResponseError (List CodeLens))
100107
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do
101-
(fromMaybe Always . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId
108+
mode <- readMode <$> usePropertyLsp #mode pId properties
102109
fmap (Right . List) $ case uriToFilePath' uri of
103110
Just (toNormalizedFilePath' -> filePath) -> liftIO $ do
104111
tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)
@@ -202,14 +209,6 @@ data Mode
202209
Diagnostics
203210
deriving (Eq, Ord, Show, Read, Enum)
204211

205-
instance A.FromJSON Mode where
206-
parseJSON = A.withText "Mode" $ \s ->
207-
case T.toLower s of
208-
"always" -> pure Always
209-
"exported" -> pure Exported
210-
"diagnostics" -> pure Diagnostics
211-
_ -> A.unexpected (A.String s)
212-
213212
--------------------------------------------------------------------------------
214213

215214
showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String
@@ -246,8 +245,13 @@ rules = do
246245
result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr)
247246
pure ([], result)
248247

249-
parseCustomConfig :: A.Object -> Maybe Mode
250-
parseCustomConfig = A.parseMaybe (A..: "mode")
248+
readMode :: T.Text -> Mode
249+
readMode = \case
250+
"always" -> Always
251+
"exported" -> Exported
252+
"diagnostics" -> Diagnostics
253+
-- actually it never happens because of 'usePropertyLsp'
254+
_ -> error "failed to parse type lenses mode"
251255

252256
gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult)
253257
gblBindingType (Just hsc) (Just gblEnv) = do

‎haskell-language-server.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,7 @@ library
6969
, safe-exceptions
7070
, sqlite-simple
7171
, unordered-containers
72+
, aeson-pretty
7273

7374
ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors
7475

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,8 @@ library
2727
exposed-modules:
2828
Ide.Logger
2929
Ide.Plugin.Config
30+
Ide.Plugin.ConfigUtils
31+
Ide.Plugin.Properties
3032
Ide.PluginUtils
3133
Ide.Types
3234

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

Lines changed: 127 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,127 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RecordWildCards #-}
4+
{-# LANGUAGE ViewPatterns #-}
5+
6+
module Ide.Plugin.ConfigUtils where
7+
8+
import qualified Data.Aeson as A
9+
import qualified Data.Aeson.Types as A
10+
import Data.Default (def)
11+
import qualified Data.Dependent.Map as DMap
12+
import qualified Data.Dependent.Sum as DSum
13+
import qualified Data.HashMap.Lazy as HMap
14+
import qualified Data.Map as Map
15+
import Ide.Plugin.Config
16+
import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)
17+
import Ide.Types
18+
import Language.LSP.Types
19+
20+
-- Attention:
21+
-- 'diagnosticsOn' will never be added into the default config or the schema,
22+
-- since diagnostics emit in arbitrary shake rules -- we don't know
23+
-- whether a plugin is capable of producing diagnostics.
24+
25+
-- | Generates a defalut 'Config', but remains only effective items
26+
pluginsToDefaultConfig :: IdePlugins a -> A.Value
27+
pluginsToDefaultConfig IdePlugins {..} =
28+
A.Object $
29+
HMap.adjust
30+
( \(unsafeValueToObject -> o) ->
31+
A.Object $ HMap.insert "plugin" elems o -- inplace the "plugin" section with our 'elems', leaving others unchanged
32+
)
33+
"haskell"
34+
(unsafeValueToObject (A.toJSON defaultConfig))
35+
where
36+
defaultConfig@Config {} = def
37+
unsafeValueToObject (A.Object o) = o
38+
unsafeValueToObject _ = error "impossible"
39+
elems = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap
40+
-- Splice genericDefaultConfig and dedicatedDefaultConfig
41+
-- Example:
42+
--
43+
-- {
44+
-- "plugin-id": {
45+
-- "globalOn": true,
46+
-- "codeActionsOn": true,
47+
-- "codeLensOn": true,
48+
-- "config": {
49+
-- "property1": "foo"
50+
-- }
51+
-- }
52+
-- }
53+
singlePlugin PluginDescriptor {..} =
54+
let x = genericDefaultConfig <> dedicatedDefaultConfig
55+
in [pId A..= A.object x | not $ null x]
56+
where
57+
(PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
58+
customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p
59+
-- Example:
60+
--
61+
-- {
62+
-- "globalOn": true,
63+
-- "codeActionsOn": true,
64+
-- "codeLensOn": true
65+
-- }
66+
--
67+
-- we don't generate the config section if the plugin doesn't register any of the following six methods,
68+
-- which avoids producing trivial configuration for formatters:
69+
--
70+
-- "stylish-haskell": {
71+
-- "globalOn": true
72+
-- }
73+
genericDefaultConfig =
74+
let x = mconcat (handlersToGenericDefaultConfig <$> handlers)
75+
in ["globalOn" A..= True | not $ null x] <> x
76+
-- Example:
77+
--
78+
-- {
79+
-- "config": {
80+
-- "property1": "foo"
81+
-- }
82+
--}
83+
dedicatedDefaultConfig =
84+
let x = customConfigToDedicatedDefaultConfig pluginCustomConfig
85+
in ["config" A..= A.object x | not $ null x]
86+
87+
(PluginId pId) = pluginId
88+
89+
-- This function captures ide methods registered by the plugin, and then converts it to kv pairs
90+
handlersToGenericDefaultConfig :: DSum.DSum IdeMethod f -> [A.Pair]
91+
handlersToGenericDefaultConfig (IdeMethod m DSum.:=> _) = case m of
92+
STextDocumentCodeAction -> ["codeActionsOn" A..= True]
93+
STextDocumentCodeLens -> ["codeLensOn" A..= True]
94+
STextDocumentRename -> ["renameOn" A..= True]
95+
STextDocumentHover -> ["hoverOn" A..= True]
96+
STextDocumentDocumentSymbol -> ["symbolsOn" A..= True]
97+
STextDocumentCompletion -> ["completionOn" A..= True]
98+
_ -> []
99+
100+
-- | Generates json schema used in haskell vscode extension
101+
-- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure
102+
pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value
103+
pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap
104+
where
105+
singlePlugin PluginDescriptor {..} = genericSchema <> dedicatedSchema
106+
where
107+
(PluginHandlers (DMap.toList -> handlers)) = pluginHandlers
108+
customConfigToDedicatedSchema (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p
109+
(PluginId pId) = pluginId
110+
genericSchema = withIdPrefix "globalOn" A..= schemaEntry "plugin" : mconcat (handlersToGenericSchema <$> handlers)
111+
dedicatedSchema = customConfigToDedicatedSchema pluginCustomConfig
112+
handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of
113+
STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= schemaEntry "code actions"]
114+
STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= schemaEntry "code lenses"]
115+
STextDocumentRename -> [withIdPrefix "renameOn" A..= schemaEntry "rename"]
116+
STextDocumentHover -> [withIdPrefix "hoverOn" A..= schemaEntry "hover"]
117+
STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= schemaEntry "symbols"]
118+
STextDocumentCompletion -> [withIdPrefix "completionOn" A..= schemaEntry "completions"]
119+
_ -> []
120+
schemaEntry desc =
121+
A.object
122+
[ "scope" A..= A.String "resource",
123+
"type" A..= A.String "boolean",
124+
"default" A..= True,
125+
"description" A..= A.String ("Enables " <> pId <> " " <> desc)
126+
]
127+
withIdPrefix x = "haskell.plugin." <> pId <> "." <> x

0 commit comments

Comments
 (0)