From a3369d40d2841160083e6d24fffc5a0f0ef62e4b Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Tue, 2 Apr 2019 15:11:27 +0100 Subject: [PATCH 1/4] Make diagnostics on change configurable Part of the way to fixing #522 --- hie-plugin-api/Haskell/Ide/Engine/Config.hs | 6 +++++- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 5 ++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Config.hs b/hie-plugin-api/Haskell/Ide/Engine/Config.hs index e271d7ca6..c141b8567 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 = False , 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/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index d87d58b9f..2b22a1445 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -508,7 +508,10 @@ reactor inp diagIn = do -- Important - Call this before requestDiagnostics updatePositionMap uri changes - queueDiagnosticsRequest diagIn DiagnosticOnChange tn uri ver + lf <- asks lspFuncs + mc <- liftIO $ Core.config lf + when (maybe False diagnosticsOnChange mc) + (queueDiagnosticsRequest diagIn DiagnosticOnChange tn uri ver) -- ------------------------------- From e5f9cfc0de7cedf92b9449e85140cd0c66c9898b Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Sat, 6 Apr 2019 13:56:02 +0200 Subject: [PATCH 2/4] Refactoring calls to get config inside the reactor previous calls had defaults scattered all over the place and they often were contradictory. --- src/Haskell/Ide/Engine/LSP/Reactor.hs | 14 +++++++ src/Haskell/Ide/Engine/Transport/LspStdio.hs | 40 +++++++++----------- test/unit/JsonSpec.hs | 11 +++++- 3 files changed, 42 insertions(+), 23 deletions(-) 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 2b22a1445..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,9 +505,10 @@ reactor inp diagIn = do -- Important - Call this before requestDiagnostics updatePositionMap uri changes - lf <- asks lspFuncs - mc <- liftIO $ Core.config lf - when (maybe False diagnosticsOnChange mc) + -- 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) -- ------------------------------- @@ -661,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 @@ -789,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. @@ -811,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 @@ -849,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')]) @@ -899,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 @@ -918,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/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 From c54efd3a74004ab3e7963423550a130e88d130e7 Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Sat, 6 Apr 2019 19:09:39 +0200 Subject: [PATCH 3/4] Adding tests --- test/functional/FunctionalCodeActionsSpec.hs | 39 ++++++++++++++++++-- 1 file changed, 36 insertions(+), 3 deletions(-) diff --git a/test/functional/FunctionalCodeActionsSpec.hs b/test/functional/FunctionalCodeActionsSpec.hs index 70bedf488..a842fa2eb 100644 --- a/test/functional/FunctionalCodeActionsSpec.hs +++ b/test/functional/FunctionalCodeActionsSpec.hs @@ -20,12 +20,18 @@ import qualified Language.Haskell.LSP.Types.Capabilities as C import Test.Hspec import TestUtils +runSessionWithOnChange :: String -> C.ClientCapabilities -> FilePath -> Session a -> IO a +runSessionWithOnChange cmd caps name test = runSession cmd caps name $ do + let config = def { diagnosticsOnChange = True } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + test + 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" + it "provides 3.8 code actions" $ runSessionWithOnChange hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "ApplyRefact2.hs" "haskell" diags@(reduceDiag:_) <- waitForDiagnostics liftIO $ do @@ -49,7 +55,7 @@ spec = describe "code actions" $ do -- --------------------------------- - it "falls back to pre 3.8 code actions" $ runSession hieCommand noLiteralCaps "test/testdata" $ do + it "falls back to pre 3.8 code actions" $ runSessionWithOnChange hieCommand noLiteralCaps "test/testdata" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" _ <- waitForDiagnostics @@ -66,6 +72,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 From 7cd1ab890148c0e8b81ca9cc67112ff72a9f8af2 Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Mon, 8 Apr 2019 23:46:50 +0200 Subject: [PATCH 4/4] Setting the diagnosticsOnChange default to True --- hie-plugin-api/Haskell/Ide/Engine/Config.hs | 2 +- test/functional/DiagnosticsSpec.hs | 49 ++++++++++++++------ test/functional/FunctionalCodeActionsSpec.hs | 10 +--- 3 files changed, 39 insertions(+), 22 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Config.hs b/hie-plugin-api/Haskell/Ide/Engine/Config.hs index c141b8567..9f625023c 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Config.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Config.hs @@ -33,7 +33,7 @@ data Config = instance Default Config where def = Config { hlintOn = True - , diagnosticsOnChange = False + , diagnosticsOnChange = True , maxNumberOfProblems = 100 , diagnosticsDebounceDuration = 350000 , liquidOn = False 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 a842fa2eb..752651ef0 100644 --- a/test/functional/FunctionalCodeActionsSpec.hs +++ b/test/functional/FunctionalCodeActionsSpec.hs @@ -20,16 +20,10 @@ import qualified Language.Haskell.LSP.Types.Capabilities as C import Test.Hspec import TestUtils -runSessionWithOnChange :: String -> C.ClientCapabilities -> FilePath -> Session a -> IO a -runSessionWithOnChange cmd caps name test = runSession cmd caps name $ do - let config = def { diagnosticsOnChange = True } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) - test - spec :: Spec spec = describe "code actions" $ do describe "hlint suggestions" $ do - it "provides 3.8 code actions" $ runSessionWithOnChange hieCommand fullCaps "test/testdata" $ do + it "provides 3.8 code actions" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" diags@(reduceDiag:_) <- waitForDiagnostics @@ -55,7 +49,7 @@ spec = describe "code actions" $ do -- --------------------------------- - it "falls back to pre 3.8 code actions" $ runSessionWithOnChange hieCommand noLiteralCaps "test/testdata" $ do + it "falls back to pre 3.8 code actions" $ runSession hieCommand noLiteralCaps "test/testdata" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" _ <- waitForDiagnostics