From 57b78e7a4cd0852df9f79767fe575c7e7a5ec7dd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 14 Feb 2021 14:20:22 +0000 Subject: [PATCH] Sanitize the setup of the default Ide.Config (#1361) * Sanitize the setup of the default Ide.Config * fix getClientConfigAction * fix Hlint * update hls-plugin-api min bound * Drop update config test Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com> --- ghcide/ghcide.cabal | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 14 +++-- ghcide/src/Development/IDE/Main.hs | 19 ++----- ghcide/test/exe/Main.hs | 7 +-- hls-plugin-api/hls-plugin-api.cabal | 2 +- hls-plugin-api/src/Ide/Plugin/Config.hs | 55 ++++++++----------- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 2 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 3 +- src/Ide/Main.hs | 3 - 9 files changed, 43 insertions(+), 64 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 2510f04826..38c1c56ff4 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -58,7 +58,7 @@ library haskell-lsp-types == 0.23.*, haskell-lsp == 0.23.*, hie-compat, - hls-plugin-api >= 0.7, + hls-plugin-api >= 0.7.1, lens, hiedb == 0.3.0.1, mtl, diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index fdece3ae2f..c7f67c2b29 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -62,9 +62,8 @@ module Development.IDE.Core.Rules( import Fingerprint -import Data.Aeson (fromJSON,toJSON, Result(Success), FromJSON) +import Data.Aeson (toJSON, Result(Success)) import Data.Binary hiding (get, put) -import Data.Default import Data.Tuple.Extra import Control.Monad.Extra import Control.Monad.Trans.Class @@ -136,6 +135,8 @@ import GHC.IO.Encoding import Data.ByteString.Encoding as T import qualified HieDb +import Ide.Plugin.Config +import qualified Data.Aeson.Types as A -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing @@ -1047,12 +1048,13 @@ getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do -- | Returns the client configurarion stored in the IdeState. -- You can use this function to access it from shake Rules -getClientConfigAction :: (Default a, FromJSON a) => Action a -getClientConfigAction = do +getClientConfigAction :: Config -- ^ default value + -> Action Config +getClientConfigAction defValue = do mbVal <- unhashed <$> useNoFile_ GetClientSettings - case fromJSON <$> mbVal of + case A.parse (parseConfig defValue) <$> mbVal of Just (Success c) -> return c - _ -> return def + _ -> return defValue -- | For now we always use bytecode getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 804a121341..5def0316be 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -4,9 +4,7 @@ import Control.Exception.Safe ( Exception (displayException), catchAny, ) -import Control.Lens ((^.)) import Control.Monad.Extra (concatMapM, unless, when) -import qualified Data.Aeson as J import Data.Default (Default (def)) import qualified Data.HashMap.Strict as HashMap import Data.List.Extra ( @@ -68,17 +66,14 @@ import Development.IDE.Types.Options ( import Development.IDE.Types.Shake (Key (Key)) import Development.Shake (action) import HIE.Bios.Cradle (findCradle) -import Ide.Plugin.Config (CheckParents (NeverCheck), Config) +import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getInitialConfig, getConfigFromNotification) import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) import Ide.Types (IdePlugins) import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages (FromServerMessage) import Language.Haskell.LSP.Types ( - DidChangeConfigurationNotification, - InitializeRequest, LspId (IdInt), ) -import Language.Haskell.LSP.Types.Lens (initializationOptions, params) import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), exitWith) import System.FilePath (takeExtension, takeFileName) @@ -99,8 +94,7 @@ data Arguments = Arguments , argsSessionLoadingOptions :: SessionLoadingOptions , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions , argsLspOptions :: LSP.Options - , argsGetInitialConfig :: InitializeRequest -> Either T.Text Config - , argsOnConfigChange :: DidChangeConfigurationNotification -> Either T.Text Config + , argsDefaultHlsConfig :: Config } defArguments :: HieDb -> IndexQueue -> Arguments @@ -117,12 +111,7 @@ defArguments hiedb hiechan = , argsSessionLoadingOptions = defaultLoadingOptions , argsIdeOptions = const defaultIdeOptions , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} - , argsOnConfigChange = const $ Left "Updating Not supported" - , argsGetInitialConfig = \x -> case x ^. params . initializationOptions of - Nothing -> Right def - Just v -> case J.fromJSON v of - J.Error err -> Left $ T.pack err - J.Success a -> Right a + , argsDefaultHlsConfig = def } defaultMain :: Arguments -> IO () @@ -134,6 +123,8 @@ defaultMain Arguments{..} = do hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands } + argsOnConfigChange = getConfigFromNotification argsDefaultHlsConfig + argsGetInitialConfig = getInitialConfig argsDefaultHlsConfig case argFiles of Nothing -> do diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9ec02dd485..13befffe3d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4762,12 +4762,7 @@ asyncTests = testGroup "async" clientSettingsTest :: TestTree clientSettingsTest = testGroup "client settings handling" - [ - testSession "ghcide does not support update config" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) - logNot <- skipManyTill anyMessage loggingNotification - isMessagePresent "Updating Not supported" [getLogMessage logNot] - , testSession "ghcide restarts shake session on config changes" $ do + [ testSession "ghcide restarts shake session on config changes" $ do void $ skipManyTill anyMessage $ message @RegisterCapabilityRequest sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) nots <- skipManyTill anyMessage $ count 3 loggingNotification diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 2f0b1a1d80..d70ab59752 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hls-plugin-api -version: 0.7.0.0 +version: 0.7.1.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 1ac1eb259a..ef3b799d37 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -10,12 +10,14 @@ module Ide.Plugin.Config getInitialConfig , getConfigFromNotification , Config(..) + , parseConfig , PluginConfig(..) , CheckParents(..) ) where import Control.Applicative import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A import Data.Aeson hiding ( Error ) import Data.Default import qualified Data.Text as T @@ -27,18 +29,18 @@ import GHC.Generics (Generic) -- | Given a DidChangeConfigurationNotification message, this function returns the parsed -- Config object if possible. -getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config -getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) = - case fromJSON p of +getConfigFromNotification :: Config -> DidChangeConfigurationNotification -> Either T.Text Config +getConfigFromNotification defaultValue (NotificationMessage _ _ (DidChangeConfigurationParams p)) = + case A.parse (parseConfig defaultValue) p of A.Success c -> Right c A.Error err -> Left $ T.pack err -- | Given an InitializeRequest message, this function returns the parsed -- Config object if possible. Otherwise, it returns the default configuration -getInitialConfig :: InitializeRequest -> Either T.Text Config -getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right def -getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) = - case fromJSON opts of +getInitialConfig :: Config -> InitializeRequest -> Either T.Text Config +getInitialConfig defaultValue (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right defaultValue +getInitialConfig defaultValue (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) = + case A.parse (parseConfig defaultValue) opts of A.Success c -> Right c A.Error err -> Left $ T.pack err @@ -93,35 +95,26 @@ instance Default Config where } -- TODO: Add API for plugins to expose their own LSP config options -instance A.FromJSON Config where - parseJSON = A.withObject "Config" $ \v -> do +parseConfig :: Config -> Value -> A.Parser Config +parseConfig defValue = A.withObject "Config" $ \v -> do -- Officially, we use "haskell" as the section name but for -- backwards compatibility we also accept "languageServerHaskell" c <- v .: "haskell" <|> v .:? "languageServerHaskell" case c of - Nothing -> return def + Nothing -> return defValue Just s -> flip (A.withObject "Config.settings") s $ \o -> Config - <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents def - <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject def - <*> o .:? "hlintOn" .!= hlintOn def - <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def - <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def - <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def - <*> o .:? "liquidOn" .!= liquidOn def - <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def - <*> o .:? "formatOnImportOn" .!= formatOnImportOn def - <*> o .:? "formattingProvider" .!= formattingProvider def - <*> o .:? "maxCompletions" .!= maxCompletions def - <*> o .:? "plugin" .!= plugins def - --- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"haskell":{"maxNumberOfProblems":100,"hlintOn":true}}}} --- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification: --- NotificationMessage --- {_jsonrpc = "2.0" --- , _method = WorkspaceDidChangeConfiguration --- , _params = DidChangeConfigurationParams --- {_settings = Object (fromList [("haskell",Object (fromList [("hlintOn",Bool True) --- ,("maxNumberOfProblems",Number 100.0)]))])}} + <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents defValue + <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject defValue + <*> o .:? "hlintOn" .!= hlintOn defValue + <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange defValue + <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems defValue + <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration defValue + <*> o .:? "liquidOn" .!= liquidOn defValue + <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn defValue + <*> o .:? "formatOnImportOn" .!= formatOnImportOn defValue + <*> o .:? "formattingProvider" .!= formattingProvider defValue + <*> o .:? "maxCompletions" .!= maxCompletions defValue + <*> o .:? "plugin" .!= plugins defValue instance A.ToJSON Config where toJSON Config{..} = diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 9099bcec2d..5338de266c 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -43,7 +43,7 @@ library , hashable , haskell-lsp , hlint >=3.2 - , hls-plugin-api >=0.7.0.0 + , hls-plugin-api >=0.7.1.0 , hslogger , lens , regex-tdfa diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index e968eb4c53..9c3c6981a5 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -24,6 +24,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..)) import Data.Binary +import Data.Default import Data.Hashable import qualified Data.HashMap.Strict as Map import Data.Maybe @@ -102,7 +103,7 @@ type instance RuleResult GetHlintDiagnostics = () rules :: PluginId -> Rules () rules plugin = do define $ \GetHlintDiagnostics file -> do - config <- getClientConfigAction + config <- getClientConfigAction def let pluginConfig = configForPlugin config plugin let hlintOn' = hlintOn config && pluginEnabled pluginConfig plcDiagnosticsOn ideas <- if hlintOn' then getIdeas file else return (Right []) diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 12a3824bb7..2a9107c495 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -31,7 +31,6 @@ import HieDb.Run import qualified Development.IDE.Main as Main import qualified Development.IDE.Types.Options as Ghcide import Development.Shake (ShakeOptions(shakeThreads)) -import Ide.Plugin.Config (getInitialConfig, getConfigFromNotification) defaultMain :: Arguments -> IdePlugins IdeState -> IO () defaultMain args idePlugins = do @@ -100,8 +99,6 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do { Main.argFiles = if argLSP then Nothing else Just [] , Main.argsHlsPlugins = idePlugins , Main.argsLogger = hlsLogger - , Main.argsGetInitialConfig = getInitialConfig - , Main.argsOnConfigChange = getConfigFromNotification , Main.argsIdeOptions = \_config sessionLoader -> let defOptions = Ghcide.defaultIdeOptions sessionLoader in defOptions