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 ())