haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-20 05:07:28 +03:00
Code Issues Projects Releases Wiki Activity

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

Browse Source 
Introduce generic config for plugins
This commit is contained in:
Alan Zimmerman 2020-12-23 13:47:23 +00:00 committed by GitHub
commit cc23521ac6
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 275 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
CONTRIBUTING.md Normal file
View File

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

1
haskell-language-server.cabal
View File

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

79
hls-plugin-api/src/Ide/Plugin.hs
View File

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

86
hls-plugin-api/src/Ide/Plugin/Config.hs
View File

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

10
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
View File

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

78
test/functional/Config.hs Normal file
View File

@ -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) }

18
test/functional/FunctionalCodeAction.hs
View File

@ -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"
@ -146,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"

2
test/functional/Main.hs
View File

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