Only run diagnostics onSave

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

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

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

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

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

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