diff --git a/hie-plugin-api/Haskell/Ide/Engine/Config.hs b/hie-plugin-api/Haskell/Ide/Engine/Config.hs index e271d7ca6..9f625023c 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Config.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Config.hs @@ -21,6 +21,7 @@ getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams data Config = Config { hlintOn :: Bool + , diagnosticsOnChange :: Bool , maxNumberOfProblems :: Int , diagnosticsDebounceDuration :: Int , liquidOn :: Bool @@ -32,6 +33,7 @@ data Config = instance Default Config where def = Config { hlintOn = True + , diagnosticsOnChange = True , maxNumberOfProblems = 100 , diagnosticsDebounceDuration = 350000 , liquidOn = False @@ -46,6 +48,7 @@ instance FromJSON Config where s <- v .: "languageServerHaskell" flip (withObject "Config.settings") s $ \o -> Config <$> o .:? "hlintOn" .!= hlintOn def + <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def <*> o .:? "liquidOn" .!= liquidOn def @@ -63,9 +66,10 @@ instance FromJSON Config where -- ,("maxNumberOfProblems",Number 100.0)]))])}} instance ToJSON Config where - toJSON (Config h m d l c f fp) = object [ "languageServerHaskell" .= r ] + toJSON (Config h diag m d l c f fp) = object [ "languageServerHaskell" .= r ] where r = object [ "hlintOn" .= h + , "diagnosticsOnChange" .= diag , "maxNumberOfProblems" .= m , "diagnosticsDebounceDuration" .= d , "liquidOn" .= l diff --git a/src/Haskell/Ide/Engine/LSP/Reactor.hs b/src/Haskell/Ide/Engine/LSP/Reactor.hs index 99662172e..c96ffa00e 100644 --- a/src/Haskell/Ide/Engine/LSP/Reactor.hs +++ b/src/Haskell/Ide/Engine/LSP/Reactor.hs @@ -11,12 +11,15 @@ module Haskell.Ide.Engine.LSP.Reactor , updateDocumentRequest , cancelRequest , asksLspFuncs + , getClientConfig , REnv(..) ) where import Control.Monad.Reader import qualified Data.Map as Map +import qualified Data.Default +import Data.Maybe ( fromMaybe ) import Haskell.Ide.Engine.Compat import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.PluginsIdeMonads @@ -69,6 +72,17 @@ runReactor lf sc dps hps sps fps f = do asksLspFuncs :: MonadReader REnv m => (Core.LspFuncs Config -> a) -> m a asksLspFuncs f = asks (f . lspFuncs) +-- | 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. +-- +-- If no custom configuration has been set by the client, this function returns +-- our own defaults. +getClientConfig :: (MonadIO m, MonadReader REnv m) => m Config +getClientConfig = do + lf <- asks lspFuncs + liftIO $ fromMaybe Data.Default.def <$> Core.config lf + -- --------------------------------------------------------------------- -- reactor monad functions -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index d87d58b9f..062c9d390 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -193,11 +193,8 @@ type ReactorInput -- --------------------------------------------------------------------- -configVal :: c -> (Config -> c) -> R c -configVal defVal field = do - gmc <- asksLspFuncs Core.config - mc <- liftIO gmc - return $ maybe defVal field mc +configVal :: (Config -> c) -> R c +configVal field = field <$> getClientConfig -- --------------------------------------------------------------------- @@ -508,7 +505,11 @@ reactor inp diagIn = do -- Important - Call this before requestDiagnostics updatePositionMap uri changes - queueDiagnosticsRequest diagIn DiagnosticOnChange tn uri ver + -- By default we don't run diagnostics on each change, unless configured + -- by the clietn explicitly + shouldRunDiag <- configVal diagnosticsOnChange + when shouldRunDiag + (queueDiagnosticsRequest diagIn DiagnosticOnChange tn uri ver) -- ------------------------------- @@ -658,7 +659,7 @@ reactor inp diagIn = do case mprefix of Nothing -> callback [] Just prefix -> do - snippets <- Hie.WithSnippets <$> configVal True completionSnippetsOn + snippets <- Hie.WithSnippets <$> configVal completionSnippetsOn let hreq = IReq tn (req ^. J.id) callback $ lift $ Hie.getCompletions doc prefix snippets makeRequest hreq @@ -786,8 +787,8 @@ reactor inp diagIn = do NotDidChangeConfiguration notif -> do liftIO $ U.logs $ "reactor:didChangeConfiguration notification:" ++ show notif -- if hlint has been turned off, flush the diagnostics - diagsOn <- configVal True hlintOn - maxDiagnosticsToSend <- configVal 50 maxNumberOfProblems + diagsOn <- configVal hlintOn + maxDiagnosticsToSend <- configVal maxNumberOfProblems liftIO $ U.logs $ "reactor:didChangeConfiguration diagsOn:" ++ show diagsOn -- If hlint is off, remove the diags. But make sure they get sent, in -- case maxDiagnosticsToSend has changed. @@ -808,18 +809,17 @@ reactor inp diagIn = do getFormattingProvider :: R FormattingProvider getFormattingProvider = do providers <- asks formattingProviders - lf <- asks lspFuncs - mc <- liftIO $ Core.config lf + clientConfig <- getClientConfig -- LL: Is this overengineered? Do we need a pluginFormattingProvider -- or should we just call plugins straight from here based on the providerType? - let providerName = formattingProvider (fromMaybe def mc) + let providerName = formattingProvider clientConfig mProvider = Map.lookup providerName providers case mProvider of Nothing -> do unless (providerName == "none") $ do let msg = providerName <> " is not a recognised plugin for formatting. Check your config" reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg - reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg + reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg return (\_ _ _ -> return (IdeResultOk [])) -- nop formatter Just provider -> return provider @@ -846,20 +846,20 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer diagFuncs <- asks diagnosticSources lf <- asks lspFuncs - mc <- liftIO $ Core.config lf + clientConfig <- getClientConfig case Map.lookup trigger diagFuncs of Nothing -> do debugm $ "requestDiagnostics: no diagFunc for:" ++ show trigger return () Just dss -> do - dpsEnabled <- configVal (Map.fromList [("liquid",False)]) getDiagnosticProvidersConfig + dpsEnabled <- configVal getDiagnosticProvidersConfig debugm $ "requestDiagnostics: got diagFunc for:" ++ show trigger forM_ dss $ \(pid,ds) -> do debugm $ "requestDiagnostics: calling diagFunc for plugin:" ++ show pid let enabled = Map.findWithDefault True pid dpsEnabled publishDiagnosticsIO = Core.publishDiagnosticsFunc lf - maxToSend = maybe 50 maxNumberOfProblems mc + maxToSend = maxNumberOfProblems clientConfig sendOne (fileUri,ds') = do debugm $ "LspStdio.sendone:(fileUri,ds')=" ++ show(fileUri,ds') publishDiagnosticsIO maxToSend fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds')]) @@ -896,8 +896,7 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer -- | get hlint and GHC diagnostics and loads the typechecked module into the cache requestDiagnosticsNormal :: TrackingNumber -> J.Uri -> J.TextDocumentVersion -> R () requestDiagnosticsNormal tn file mVer = do - lf <- asks lspFuncs - mc <- liftIO $ Core.config lf + clientConfig <- getClientConfig let ver = fromMaybe 0 mVer @@ -915,9 +914,9 @@ requestDiagnosticsNormal tn file mVer = do hasSeverity sev (J.Diagnostic _ (Just s) _ _ _ _) = s == sev hasSeverity _ _ = False sendEmpty = publishDiagnostics maxToSend file Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])]) - maxToSend = maybe 50 maxNumberOfProblems mc + maxToSend = maxNumberOfProblems clientConfig - let sendHlint = maybe True hlintOn mc + let sendHlint = hlintOn clientConfig when sendHlint $ do -- get hlint diagnostics let reql = GReq tn (Just file) (Just (file,ver)) Nothing callbackl diff --git a/test/functional/DiagnosticsSpec.hs b/test/functional/DiagnosticsSpec.hs index 95f941cd3..bfd613e1b 100644 --- a/test/functional/DiagnosticsSpec.hs +++ b/test/functional/DiagnosticsSpec.hs @@ -4,11 +4,14 @@ module DiagnosticsSpec where import Control.Lens hiding (List) import Control.Monad.IO.Class +import Data.Aeson (toJSON) import qualified Data.Text as T +import qualified Data.Default import Haskell.Ide.Engine.MonadFunctions +import Haskell.Ide.Engine.Config import Language.Haskell.LSP.Test hiding (message) -import Language.Haskell.LSP.Types as LSP -import Language.Haskell.LSP.Types.Lens as LSP hiding (contents, error ) +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as LSP import Test.Hspec import TestUtils import Utils @@ -30,10 +33,10 @@ spec = describe "diagnostics providers" $ do liftIO $ do length diags `shouldBe` 2 - reduceDiag ^. range `shouldBe` Range (Position 1 0) (Position 1 12) - reduceDiag ^. severity `shouldBe` Just DsInfo - reduceDiag ^. code `shouldBe` Just "Eta reduce" - reduceDiag ^. source `shouldBe` Just "hlint" + reduceDiag ^. LSP.range `shouldBe` Range (Position 1 0) (Position 1 12) + reduceDiag ^. LSP.severity `shouldBe` Just DsInfo + reduceDiag ^. LSP.code `shouldBe` Just "Eta reduce" + reduceDiag ^. LSP.source `shouldBe` Just "hlint" diags2a <- waitForDiagnostics -- liftIO $ show diags2a `shouldBe` "" @@ -51,24 +54,44 @@ spec = describe "diagnostics providers" $ do -- liftIO $ show diags3 `shouldBe` "" liftIO $ do length diags3 `shouldBe` 3 - d ^. range `shouldBe` Range (Position 0 0) (Position 1 0) - d ^. severity `shouldBe` Nothing - d ^. code `shouldBe` Nothing - d ^. source `shouldBe` Just "eg2" - d ^. message `shouldBe` T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" + d ^. LSP.range `shouldBe` Range (Position 0 0) (Position 1 0) + d ^. LSP.severity `shouldBe` Nothing + d ^. LSP.code `shouldBe` Nothing + d ^. LSP.source `shouldBe` Just "eg2" + d ^. LSP.message `shouldBe` T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" describe "typed hole errors" $ it "is deferred" $ runSession hieCommand fullCaps "test/testdata" $ do _ <- openDoc "TypedHoles.hs" "haskell" [diag] <- waitForDiagnosticsSource "ghcmod" - liftIO $ diag ^. severity `shouldBe` Just DsWarning + liftIO $ diag ^. LSP.severity `shouldBe` Just DsWarning describe "Warnings are warnings" $ it "Overrides -Werror" $ runSession hieCommand fullCaps "test/testdata/wErrorTest" $ do _ <- openDoc "src/WError.hs" "haskell" [diag] <- waitForDiagnosticsSource "ghcmod" - liftIO $ diag ^. severity `shouldBe` Just DsWarning + liftIO $ diag ^. LSP.severity `shouldBe` Just DsWarning + + describe "only diagnostics on save" $ + it "Respects diagnosticsOnChange setting" $ + runSession hieCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do + let config = Data.Default.def { diagnosticsOnChange = False } :: Config + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + doc <- openDoc "Hover.hs" "haskell" + diags <- waitForDiagnostics + + liftIO $ do + length diags `shouldBe` 0 + + let te = TextEdit (Range (Position 0 0) (Position 0 13)) "" + _ <- applyEdit doc te + noDiagnostics + + sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + diags2 <- waitForDiagnostics + liftIO $ + length diags2 `shouldBe` 1 -- --------------------------------------------------------------------- diff --git a/test/functional/FunctionalCodeActionsSpec.hs b/test/functional/FunctionalCodeActionsSpec.hs index 70bedf488..752651ef0 100644 --- a/test/functional/FunctionalCodeActionsSpec.hs +++ b/test/functional/FunctionalCodeActionsSpec.hs @@ -24,8 +24,8 @@ spec :: Spec spec = describe "code actions" $ do describe "hlint suggestions" $ do it "provides 3.8 code actions" $ runSession hieCommand fullCaps "test/testdata" $ do - doc <- openDoc "ApplyRefact2.hs" "haskell" + doc <- openDoc "ApplyRefact2.hs" "haskell" diags@(reduceDiag:_) <- waitForDiagnostics liftIO $ do @@ -66,6 +66,33 @@ spec = describe "code actions" $ do noDiagnostics + it "runs diagnostics on save" $ runSession hieCommand fullCaps "test/testdata" $ do + let config = def { diagnosticsOnChange = False } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + + doc <- openDoc "ApplyRefact2.hs" "haskell" + diags@(reduceDiag:_) <- waitForDiagnostics + + liftIO $ do + length diags `shouldBe` 2 + reduceDiag ^. L.range `shouldBe` Range (Position 1 0) (Position 1 12) + reduceDiag ^. L.severity `shouldBe` Just DsInfo + reduceDiag ^. L.code `shouldBe` Just "Eta reduce" + reduceDiag ^. L.source `shouldBe` Just "hlint" + + (CACodeAction ca:_) <- getAllCodeActions doc + + -- Evaluate became redundant id in later hlint versions + liftIO $ ["Apply hint:Redundant id", "Apply hint:Evaluate"] `shouldContain` [ca ^. L.title] + + executeCodeAction ca + + contents <- getDocumentEdit doc + liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" + sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + + noDiagnostics + -- ----------------------------------- describe "rename suggestions" $ do diff --git a/test/unit/JsonSpec.hs b/test/unit/JsonSpec.hs index 526a5e897..cef8e9b13 100644 --- a/test/unit/JsonSpec.hs +++ b/test/unit/JsonSpec.hs @@ -102,4 +102,13 @@ instance Arbitrary Position where return $ Position l c instance Arbitrary Config where - arbitrary = Config <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = + Config + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary