Merge pull request #691 from alanz/switch-for-import-lens

Introduce generic config for plugins

Author: alanz

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"
+```

haskell-language-server.cabal

@@ -381,6 +381,7 @@ test-suite func-test
   other-modules:
     Command
     Completion
+    Config
     Deferred
     Definition
     Diagnostic

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

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
+
+-- ---------------------------------------------------------------------

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