From 1cbe1fd0d88ad95cf66b4fc84dafd9a5590062b4 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 21 Dec 2020 13:13:46 +0000 Subject: [PATCH 1/4] Introduce generic config for plugins Make it possible to provide config for a plugin in a regular way, by using a namespace in the json config space. So we have ``` haskell.plugin.hlint.globalOn haskell.plugin.importLens.globalOn ``` It is also possible to have finer-grain config, so the individual parts of a plugin can also be separately enabled/disabled. Closes #513 --- hls-plugin-api/src/Ide/Plugin.hs | 79 ++++++++++++++--- hls-plugin-api/src/Ide/Plugin/Config.hs | 86 ++++++++++++++++--- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 10 ++- 3 files changed, 149 insertions(+), 26 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin.hs b/hls-plugin-api/src/Ide/Plugin.hs index caf86d9d13..7913c54778 100644 --- a/hls-plugin-api/src/Ide/Plugin.hs +++ b/hls-plugin-api/src/Ide/Plugin.hs @@ -19,6 +19,9 @@ module Ide.Plugin , responseError , getClientConfig , getClientConfigAction + , getPluginConfig + , configForPlugin + , pluginEnabled ) where import Control.Exception(SomeException, catch) @@ -121,7 +124,12 @@ makeCodeAction :: [(PluginId, CodeActionProvider)] makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do let caps = LSP.clientCapabilities lf unL (List ls) = ls - r <- mapM (\(pid,provider) -> provider lf ideState pid docId range context) cas + makeAction (pid,provider) = do + pluginConfig <- getPluginConfig lf pid + if pluginEnabled pluginConfig plcCodeActionsOn + then provider lf ideState pid docId range context + else return $ Right (List []) + r <- mapM makeAction cas let actions = filter wasRequested . concat $ map unL $ rights r res <- send caps actions return $ Right res @@ -181,7 +189,10 @@ makeCodeLens cas lf ideState params = do logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ let makeLens (pid, provider) = do - r <- provider lf ideState pid params + pluginConfig <- getPluginConfig lf pid + r <- if pluginEnabled pluginConfig plcCodeLensOn + then provider lf ideState pid params + else return $ Right (List []) return (pid, r) breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) @@ -409,9 +420,15 @@ makeHover :: [(PluginId, HoverProvider)] -> LSP.LspFuncs Config -> IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -makeHover hps _lf ideState params +makeHover hps lf ideState params = do - mhs <- mapM (\(_,p) -> p ideState params) hps + let + makeHover(pid,p) = do + pluginConfig <- getPluginConfig lf pid + if pluginEnabled pluginConfig plcHoverOn + then p ideState params + else return $ Right Nothing + mhs <- mapM makeHover hps -- TODO: We should support ServerCapabilities and declare that -- we don't support hover requests during initialization if we -- don't have any hover providers @@ -462,7 +479,12 @@ makeSymbols sps lf ideState params si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent in [si] <> children' - mhs <- mapM (\(_,p) -> p lf ideState params) sps + makeSymbols (pid,p) = do + pluginConfig <- getPluginConfig lf pid + if pluginEnabled pluginConfig plcSymbolsOn + then p lf ideState params + else return $ Right [] + mhs <- mapM makeSymbols sps case rights mhs of [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs hs -> return $ Right $ convertSymbols $ concat hs @@ -485,7 +507,14 @@ renameWith :: RenameParams -> IO (Either ResponseError WorkspaceEdit) renameWith providers lspFuncs state params = do - results <- mapM (\(_,p) -> p lspFuncs state params) providers + let + makeAction (pid,p) = do + pluginConfig <- getPluginConfig lspFuncs pid + if pluginEnabled pluginConfig plcRenameOn + then p lspFuncs state params + else return $ Right $ WorkspaceEdit Nothing Nothing + -- TODO:AZ: we need to consider the right way to combine possible renamers + results <- mapM makeAction providers case partitionEithers results of (errors, []) -> return $ Left $ responseError $ T.pack $ show $ errors (_, edits) -> return $ Right $ mconcat edits @@ -530,7 +559,7 @@ makeCompletions :: [(PluginId, CompletionProvider)] makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) = do mprefix <- getPrefixAtPos lf doc pos - _snippets <- WithSnippets <$> completionSnippetsOn <$> (getClientConfig lf) + _snippets <- WithSnippets <$> completionSnippetsOn <$> getClientConfig lf let combine :: [CompletionResponseResult] -> CompletionResponseResult @@ -545,11 +574,16 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest) = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest + makeAction (pid,p) = do + pluginConfig <- getPluginConfig lf pid + if pluginEnabled pluginConfig plcCompletionOn + then p lf ideState params + else return $ Right $ Completions $ List [] case mprefix of Nothing -> return $ Right $ Completions $ List [] Just _prefix -> do - mhs <- mapM (\(_,p) -> p lf ideState params) sps + mhs <- mapM makeAction sps case rights mhs of [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs hs -> return $ Right $ combine hs @@ -583,15 +617,15 @@ getPrefixAtPos lf uri pos = do -- --------------------------------------------------------------------- -- | Returns the current client configuration. It is not wise to permanently --- cache the returned value of this function, as clients can at runitime change --- their configuration. +-- cache the returned value of this function, as clients can change their +-- configuration at runtime. -- -- If no custom configuration has been set by the client, this function returns -- our own defaults. getClientConfig :: LSP.LspFuncs Config -> IO Config getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf --- | Returns the client configurarion stored in the IdeState. +-- | Returns the client configuration stored in the IdeState. -- You can use this function to access it from shake Rules getClientConfigAction :: Action Config getClientConfigAction = do @@ -600,4 +634,27 @@ getClientConfigAction = do case J.fromJSON <$> mbVal of Just (J.Success c) -> return c _ -> return Data.Default.def + -- --------------------------------------------------------------------- + +-- | Returns the current plugin configuration. It is not wise to permanently +-- cache the returned value of this function, as clients can change their +-- configuration at runtime. +-- +-- If no custom configuration has been set by the client, this function returns +-- our own defaults. +getPluginConfig :: LSP.LspFuncs Config -> PluginId -> IO PluginConfig +getPluginConfig lf plugin = do + config <- getClientConfig lf + return $ configForPlugin config plugin + +configForPlugin :: Config -> PluginId -> PluginConfig +configForPlugin config (PluginId plugin) + = Map.findWithDefault Data.Default.def plugin (plugins config) + +-- --------------------------------------------------------------------- + +-- | Checks that a given plugin is both enabled and the specific feature is +-- enabled +pluginEnabled :: PluginConfig -> (PluginConfig -> Bool) -> Bool +pluginEnabled pluginConfig f = plcGlobalOn pluginConfig && f pluginConfig diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index c28f2e489a..8f05a70f64 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -8,6 +6,7 @@ module Ide.Plugin.Config getInitialConfig , getConfigFromNotification , Config(..) + , PluginConfig(..) ) where import Control.Applicative @@ -16,6 +15,7 @@ import Data.Aeson hiding ( Error ) import Data.Default import qualified Data.Text as T import Language.Haskell.LSP.Types +import qualified Data.Map as Map -- --------------------------------------------------------------------- @@ -43,14 +43,15 @@ getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = -- will be surprises relating to config options being ignored, initially though. data Config = Config - { hlintOn :: Bool - , diagnosticsOnChange :: Bool - , maxNumberOfProblems :: Int - , diagnosticsDebounceDuration :: Int - , liquidOn :: Bool - , completionSnippetsOn :: Bool - , formatOnImportOn :: Bool - , formattingProvider :: T.Text + { hlintOn :: !Bool + , diagnosticsOnChange :: !Bool + , maxNumberOfProblems :: !Int + , diagnosticsDebounceDuration :: !Int + , liquidOn :: !Bool + , completionSnippetsOn :: !Bool + , formatOnImportOn :: !Bool + , formattingProvider :: !T.Text + , plugins :: !(Map.Map T.Text PluginConfig) } deriving (Show,Eq) instance Default Config where @@ -66,6 +67,7 @@ instance Default Config where , formattingProvider = "ormolu" -- , formattingProvider = "floskell" -- , formattingProvider = "stylish-haskell" + , plugins = Map.empty } -- TODO: Add API for plugins to expose their own LSP config options @@ -83,6 +85,7 @@ instance A.FromJSON Config where <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def <*> o .:? "formatOnImportOn" .!= formatOnImportOn def <*> o .:? "formattingProvider" .!= formattingProvider 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: @@ -94,7 +97,7 @@ instance A.FromJSON Config where -- ,("maxNumberOfProblems",Number 100.0)]))])}} instance A.ToJSON Config where - toJSON (Config h diag m d l c f fp) = object [ "haskell" .= r ] + toJSON (Config h diag m d l c f fp p) = object [ "haskell" .= r ] where r = object [ "hlintOn" .= h , "diagnosticsOnChange" .= diag @@ -104,4 +107,65 @@ instance A.ToJSON Config where , "completionSnippetsOn" .= c , "formatOnImportOn" .= f , "formattingProvider" .= fp + , "plugin" .= p ] + +-- --------------------------------------------------------------------- + +-- | A PluginConfig is a generic configuration for a given HLS plugin. It +-- provides a "big switch" to turn it on or off as a whole, as well as small +-- switches per feature, and a slot for custom config. +-- This provides a regular naming scheme for all plugin config. +data PluginConfig = + PluginConfig + { plcGlobalOn :: !Bool + , plcCodeActionsOn :: !Bool + , plcCodeLensOn :: !Bool + , plcDiagnosticsOn :: !Bool + , plcHoverOn :: !Bool + , plcSymbolsOn :: !Bool + , plcCompletionOn :: !Bool + , plcRenameOn :: !Bool + , plcConfig :: !A.Object + } deriving (Show,Eq) + +instance Default PluginConfig where + def = PluginConfig + { plcGlobalOn = True + , plcCodeActionsOn = True + , plcCodeLensOn = True + , plcDiagnosticsOn = True + , plcHoverOn = True + , plcSymbolsOn = True + , plcCompletionOn = True + , plcRenameOn = True + , plcConfig = mempty + } + +instance A.ToJSON PluginConfig where + toJSON (PluginConfig g ca cl d h s c rn cfg) = r + where + r = object [ "globalOn" .= g + , "codeActionsOn" .= ca + , "codeLensOn" .= cl + , "diagnosticsOn" .= d + , "hoverOn" .= h + , "symbolsOn" .= s + , "completionOn" .= c + , "renameOn" .= rn + , "config" .= cfg + ] + +instance A.FromJSON PluginConfig where + parseJSON = A.withObject "PluginConfig" $ \o -> PluginConfig + <$> o .:? "globalOn" .!= plcGlobalOn def + <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def + <*> o .:? "codeLensOn" .!= plcCodeLensOn def + <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ + <*> o .:? "hoverOn" .!= plcHoverOn def + <*> o .:? "symbolsOn" .!= plcSymbolsOn def + <*> o .:? "completionOn" .!= plcCompletionOn def + <*> o .:? "renameOn" .!= plcRenameOn def + <*> o .:? "config" .!= plcConfig def + +-- --------------------------------------------------------------------- diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 6dcc384119..db618c74ff 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -67,7 +67,7 @@ import GHC.Generics (Generic) descriptor :: PluginId -> PluginDescriptor descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = rules + { pluginRules = rules plId , pluginCommands = [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd @@ -93,10 +93,12 @@ type instance RuleResult GetHlintDiagnostics = () -- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc -- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` -- | - The hlint specific settings have changed, via `getHlintSettingsRule` -rules :: Rules () -rules = do +rules :: PluginId -> Rules () +rules plugin = do define $ \GetHlintDiagnostics file -> do - hlintOn' <- hlintOn <$> getClientConfigAction + config <- getClientConfigAction + let pluginConfig = configForPlugin config plugin + let hlintOn' = hlintOn config && pluginEnabled pluginConfig plcDiagnosticsOn ideas <- if hlintOn' then getIdeas file else return (Right []) return (diagnostics file ideas, Just ()) From 2e829f5bc93a7e50055d822e3a7ff69df68da37e Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 22 Dec 2020 13:13:38 +0000 Subject: [PATCH 2/4] Add tests for Plugin global enable via config And a CONTRIBUTING.md, for help on running tests --- CONTRIBUTING.md | 45 ++++++++++++++++++++ haskell-language-server.cabal | 1 + test/functional/Config.hs | 78 +++++++++++++++++++++++++++++++++++ test/functional/Main.hs | 2 + 4 files changed, 126 insertions(+) create mode 100644 CONTRIBUTING.md create mode 100644 test/functional/Config.hs diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000000..f9a88b47da --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,45 @@ +# Contributors Guide + +## Testing + +The tests make use of the [Tasty](https://github.com/feuerbach/tasty) test framework. + +There are two test suites, functional tests, and wrapper tests. + +### Testing with Cabal + +Running all the tests + +```bash +$ cabal test +``` + +Running just the functional tests + +```bash +$ cabal test func-test +``` + +Running just the wrapper tests + +```bash +$ cabal test wrapper-test +``` + +Running a subset of tests + +Tasty supports providing +[Patterns](https://github.com/feuerbach/tasty#patterns) as command +line arguments, to select the specific tests to run. + +```bash +$ cabal test func-test --test-option "-p hlint" +``` + +The above recompiles everything every time you use a different test option though. + +An alternative is + +```bash +$ cabal run haskell-language-server:func-test -- -p "hlint enables" +``` diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 839bde8335..1a41727cd1 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -381,6 +381,7 @@ test-suite func-test other-modules: Command Completion + Config Deferred Definition Diagnostic diff --git a/test/functional/Config.hs b/test/functional/Config.hs new file mode 100644 index 0000000000..0ad1e1e41a --- /dev/null +++ b/test/functional/Config.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Config (tests) where + +import Control.Lens hiding (List) +import Control.Monad.IO.Class +import Data.Aeson +import Data.Default +import qualified Data.Map as Map +import qualified Data.Text as T +import Ide.Plugin.Config +import Language.Haskell.LSP.Test as Test +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as L +import System.FilePath (()) +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + +{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} + +tests :: TestTree +tests = testGroup "plugin config" [ + -- Note: because the flag is treated generically in the plugin handler, we + -- do not have to test each individual plugin + hlintTests + ] + +hlintTests :: TestTree +hlintTests = testGroup "hlint plugin enables" [ + + testCase "changing hlintOn configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do + let config = def { hlintOn = True } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + + doc <- openDoc "ApplyRefact2.hs" "haskell" + testHlintDiagnostics doc + + let config' = def { hlintOn = False } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + + diags' <- waitForDiagnosticsFrom doc + + liftIO $ noHlintDiagnostics diags' + + , testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do + let config = def { hlintOn = True } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + + doc <- openDoc "ApplyRefact2.hs" "haskell" + testHlintDiagnostics doc + + let config' = pluginGlobalOn config "hlint" False + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + + diags' <- waitForDiagnosticsFrom doc + + liftIO $ noHlintDiagnostics diags' + + ] + where + runHlintSession :: FilePath -> Session a -> IO a + runHlintSession subdir = + failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" subdir) + + noHlintDiagnostics :: [Diagnostic] -> Assertion + noHlintDiagnostics diags = + Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" + + testHlintDiagnostics doc = do + diags <- waitForDiagnosticsFromSource doc "hlint" + liftIO $ length diags > 0 @? "There are hlint diagnostics" + +pluginGlobalOn :: Config -> T.Text -> Bool -> Config +pluginGlobalOn config pid state = config' + where + pluginConfig = def { plcGlobalOn = state } + config' = def { plugins = Map.insert pid pluginConfig (plugins config) } diff --git a/test/functional/Main.hs b/test/functional/Main.hs index 4e2965d9ad..fb393aa944 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -8,6 +8,7 @@ import Test.Tasty.Ingredients.Rerun import Test.Tasty.Runners.AntXML import Command +import Config import Completion import Deferred import Definition @@ -37,6 +38,7 @@ main = "haskell-language-server" [ Command.tests , Completion.tests + , Config.tests , Deferred.tests , Definition.tests , Diagnostic.tests From 37da7ab2ae808ae4e03a93ac3c62f57d218483ed Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 23 Dec 2020 11:21:20 +0000 Subject: [PATCH 3/4] Remove duplicated test --- test/functional/FunctionalCodeAction.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 9d0a8b453f..882adc3874 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -81,20 +81,6 @@ hlintTests = testGroup "hlint suggestions" [ contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo = id\n" - , testCase "changing configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do - let config = def { hlintOn = True } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) - - doc <- openDoc "ApplyRefact2.hs" "haskell" - testHlintDiagnostics doc - - let config' = def { hlintOn = False } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) - - diags' <- waitForDiagnosticsFrom doc - - liftIO $ noHlintDiagnostics diags' - , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $ testCase "hlint diagnostics works with CPP via ghc -XCPP argument (#554)" $ runHlintSession "cpp" $ do doc <- openDoc "ApplyRefact3.hs" "haskell" From 501b8f9cadc9451f5d6c9e5ca1136b9e0f64b17a Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 23 Dec 2020 11:48:20 +0000 Subject: [PATCH 4/4] Fix compiler warning that only shows up in CI More argument for #693, in my opinion --- test/functional/FunctionalCodeAction.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 882adc3874..23a356d1ec 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -132,10 +132,6 @@ hlintTests = testGroup "hlint suggestions" [ runHlintSession subdir = failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" subdir) - noHlintDiagnostics :: [Diagnostic] -> Assertion - noHlintDiagnostics diags = - Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" - testHlintDiagnostics doc = do diags <- waitForDiagnosticsFromSource doc "hlint" liftIO $ length diags > 0 @? "There are hlint diagnostics"