Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit fbb7574

Browse files
alanzalanz
authored
Merge pull request #1164 from haskell/diagnostics-on-save
Only run diagnostics onSave
2 parents 3e38e39 + 7cd1ab8 commit fbb7574

File tree

6 files changed

+112
-36
lines changed

6 files changed

+112
-36
lines changed

‎hie-plugin-api/Haskell/Ide/Engine/Config.hs

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams
2121
data Config =
2222
Config
2323
{ hlintOn :: Bool
24+
, diagnosticsOnChange :: Bool
2425
, maxNumberOfProblems :: Int
2526
, diagnosticsDebounceDuration :: Int
2627
, liquidOn :: Bool
@@ -32,6 +33,7 @@ data Config =
3233
instance Default Config where
3334
def = Config
3435
{ hlintOn = True
36+
, diagnosticsOnChange = True
3537
, maxNumberOfProblems = 100
3638
, diagnosticsDebounceDuration = 350000
3739
, liquidOn = False
@@ -46,6 +48,7 @@ instance FromJSON Config where
4648
s <- v .: "languageServerHaskell"
4749
flip (withObject "Config.settings") s $ \o -> Config
4850
<$> o .:? "hlintOn" .!= hlintOn def
51+
<*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def
4952
<*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def
5053
<*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def
5154
<*> o .:? "liquidOn" .!= liquidOn def
@@ -63,9 +66,10 @@ instance FromJSON Config where
6366
-- ,("maxNumberOfProblems",Number 100.0)]))])}}
6467

6568
instance ToJSON Config where
66-
toJSON (Config h m d l c f fp) = object [ "languageServerHaskell" .= r ]
69+
toJSON (Config h diag m d l c f fp) = object [ "languageServerHaskell" .= r ]
6770
where
6871
r = object [ "hlintOn" .= h
72+
, "diagnosticsOnChange" .= diag
6973
, "maxNumberOfProblems" .= m
7074
, "diagnosticsDebounceDuration" .= d
7175
, "liquidOn" .= l

‎src/Haskell/Ide/Engine/LSP/Reactor.hs

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,12 +11,15 @@ module Haskell.Ide.Engine.LSP.Reactor
1111
, updateDocumentRequest
1212
, cancelRequest
1313
, asksLspFuncs
14+
, getClientConfig
1415
, REnv(..)
1516
)
1617
where
1718

1819
import Control.Monad.Reader
1920
import qualified Data.Map as Map
21+
import qualified Data.Default
22+
import Data.Maybe ( fromMaybe )
2023
import Haskell.Ide.Engine.Compat
2124
import Haskell.Ide.Engine.Config
2225
import Haskell.Ide.Engine.PluginsIdeMonads
@@ -69,6 +72,17 @@ runReactor lf sc dps hps sps fps f = do
6972
asksLspFuncs :: MonadReader REnv m => (Core.LspFuncs Config -> a) -> m a
7073
asksLspFuncs f = asks (f . lspFuncs)
7174

75+
-- | Returns the current client configuration. It is not wise to permanently
76+
-- cache the returned value of this function, as clients can at runitime change
77+
-- their configuration.
78+
--
79+
-- If no custom configuration has been set by the client, this function returns
80+
-- our own defaults.
81+
getClientConfig :: (MonadIO m, MonadReader REnv m) => m Config
82+
getClientConfig = do
83+
lf <- asks lspFuncs
84+
liftIO $ fromMaybe Data.Default.def <$> Core.config lf
85+
7286
-- ---------------------------------------------------------------------
7387
-- reactor monad functions
7488
-- ---------------------------------------------------------------------

‎src/Haskell/Ide/Engine/Transport/LspStdio.hs

Lines changed: 19 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -193,11 +193,8 @@ type ReactorInput
193193

194194
-- ---------------------------------------------------------------------
195195

196-
configVal :: c -> (Config -> c) -> R c
197-
configVal defVal field = do
198-
gmc <- asksLspFuncs Core.config
199-
mc <- liftIO gmc
200-
return $ maybe defVal field mc
196+
configVal :: (Config -> c) -> R c
197+
configVal field = field <$> getClientConfig
201198

202199
-- ---------------------------------------------------------------------
203200

@@ -508,7 +505,11 @@ reactor inp diagIn = do
508505
-- Important - Call this before requestDiagnostics
509506
updatePositionMap uri changes
510507

511-
queueDiagnosticsRequest diagIn DiagnosticOnChange tn uri ver
508+
-- By default we don't run diagnostics on each change, unless configured
509+
-- by the clietn explicitly
510+
shouldRunDiag <- configVal diagnosticsOnChange
511+
when shouldRunDiag
512+
(queueDiagnosticsRequest diagIn DiagnosticOnChange tn uri ver)
512513

513514
-- -------------------------------
514515

@@ -658,7 +659,7 @@ reactor inp diagIn = do
658659
case mprefix of
659660
Nothing -> callback []
660661
Just prefix -> do
661-
snippets <- Hie.WithSnippets <$> configVal True completionSnippetsOn
662+
snippets <- Hie.WithSnippets <$> configVal completionSnippetsOn
662663
let hreq = IReq tn (req ^. J.id) callback
663664
$ lift $ Hie.getCompletions doc prefix snippets
664665
makeRequest hreq
@@ -786,8 +787,8 @@ reactor inp diagIn = do
786787
NotDidChangeConfiguration notif -> do
787788
liftIO $ U.logs $ "reactor:didChangeConfiguration notification:" ++ show notif
788789
-- if hlint has been turned off, flush the diagnostics
789-
diagsOn <- configVal True hlintOn
790-
maxDiagnosticsToSend <- configVal 50 maxNumberOfProblems
790+
diagsOn <- configVal hlintOn
791+
maxDiagnosticsToSend <- configVal maxNumberOfProblems
791792
liftIO $ U.logs $ "reactor:didChangeConfiguration diagsOn:" ++ show diagsOn
792793
-- If hlint is off, remove the diags. But make sure they get sent, in
793794
-- case maxDiagnosticsToSend has changed.
@@ -808,18 +809,17 @@ reactor inp diagIn = do
808809
getFormattingProvider :: R FormattingProvider
809810
getFormattingProvider = do
810811
providers <- asks formattingProviders
811-
lf <- asks lspFuncs
812-
mc <- liftIO $ Core.config lf
812+
clientConfig <- getClientConfig
813813
-- LL: Is this overengineered? Do we need a pluginFormattingProvider
814814
-- or should we just call plugins straight from here based on the providerType?
815-
let providerName = formattingProvider (fromMaybe def mc)
815+
let providerName = formattingProvider clientConfig
816816
mProvider = Map.lookup providerName providers
817817
case mProvider of
818818
Nothing -> do
819819
unless (providerName == "none") $ do
820820
let msg = providerName <> " is not a recognised plugin for formatting. Check your config"
821821
reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
822-
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
822+
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
823823
return (\_ _ _ -> return (IdeResultOk [])) -- nop formatter
824824
Just provider -> return provider
825825

@@ -846,20 +846,20 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
846846

847847
diagFuncs <- asks diagnosticSources
848848
lf <- asks lspFuncs
849-
mc <- liftIO $ Core.config lf
849+
clientConfig <- getClientConfig
850850
case Map.lookup trigger diagFuncs of
851851
Nothing -> do
852852
debugm $ "requestDiagnostics: no diagFunc for:" ++ show trigger
853853
return ()
854854
Just dss -> do
855-
dpsEnabled <- configVal (Map.fromList [("liquid",False)]) getDiagnosticProvidersConfig
855+
dpsEnabled <- configVal getDiagnosticProvidersConfig
856856
debugm $ "requestDiagnostics: got diagFunc for:" ++ show trigger
857857
forM_ dss $ \(pid,ds) -> do
858858
debugm $ "requestDiagnostics: calling diagFunc for plugin:" ++ show pid
859859
let
860860
enabled = Map.findWithDefault True pid dpsEnabled
861861
publishDiagnosticsIO = Core.publishDiagnosticsFunc lf
862-
maxToSend = maybe 50 maxNumberOfProblems mc
862+
maxToSend = maxNumberOfProblems clientConfig
863863
sendOne (fileUri,ds') = do
864864
debugm $ "LspStdio.sendone:(fileUri,ds')=" ++ show(fileUri,ds')
865865
publishDiagnosticsIO maxToSend fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds')])
@@ -896,8 +896,7 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
896896
-- | get hlint and GHC diagnostics and loads the typechecked module into the cache
897897
requestDiagnosticsNormal :: TrackingNumber -> J.Uri -> J.TextDocumentVersion -> R ()
898898
requestDiagnosticsNormal tn file mVer = do
899-
lf <- asks lspFuncs
900-
mc <- liftIO $ Core.config lf
899+
clientConfig <- getClientConfig
901900
let
902901
ver = fromMaybe 0 mVer
903902

@@ -915,9 +914,9 @@ requestDiagnosticsNormal tn file mVer = do
915914
hasSeverity sev (J.Diagnostic _ (Just s) _ _ _ _) = s == sev
916915
hasSeverity _ _ = False
917916
sendEmpty = publishDiagnostics maxToSend file Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])
918-
maxToSend = maybe 50 maxNumberOfProblems mc
917+
maxToSend = maxNumberOfProblems clientConfig
919918

920-
let sendHlint = maybe True hlintOn mc
919+
let sendHlint = hlintOn clientConfig
921920
when sendHlint $ do
922921
-- get hlint diagnostics
923922
let reql = GReq tn (Just file) (Just (file,ver)) Nothing callbackl

‎test/functional/DiagnosticsSpec.hs

Lines changed: 36 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -4,11 +4,14 @@ module DiagnosticsSpec where
44

55
import Control.Lens hiding (List)
66
import Control.Monad.IO.Class
7+
import Data.Aeson (toJSON)
78
import qualified Data.Text as T
9+
import qualified Data.Default
810
import Haskell.Ide.Engine.MonadFunctions
11+
import Haskell.Ide.Engine.Config
912
import Language.Haskell.LSP.Test hiding (message)
10-
import Language.Haskell.LSP.Types as LSP
11-
import Language.Haskell.LSP.Types.Lens as LSP hiding (contents, error )
13+
import Language.Haskell.LSP.Types
14+
import qualified Language.Haskell.LSP.Types.Lens as LSP
1215
import Test.Hspec
1316
import TestUtils
1417
import Utils
@@ -30,10 +33,10 @@ spec = describe "diagnostics providers" $ do
3033

3134
liftIO $ do
3235
length diags `shouldBe` 2
33-
reduceDiag ^. range `shouldBe` Range (Position 1 0) (Position 1 12)
34-
reduceDiag ^. severity `shouldBe` Just DsInfo
35-
reduceDiag ^. code `shouldBe` Just "Eta reduce"
36-
reduceDiag ^. source `shouldBe` Just "hlint"
36+
reduceDiag ^. LSP.range `shouldBe` Range (Position 1 0) (Position 1 12)
37+
reduceDiag ^. LSP.severity `shouldBe` Just DsInfo
38+
reduceDiag ^. LSP.code `shouldBe` Just "Eta reduce"
39+
reduceDiag ^. LSP.source `shouldBe` Just "hlint"
3740

3841
diags2a <- waitForDiagnostics
3942
-- liftIO $ show diags2a `shouldBe` ""
@@ -51,24 +54,44 @@ spec = describe "diagnostics providers" $ do
5154
-- liftIO $ show diags3 `shouldBe` ""
5255
liftIO $ do
5356
length diags3 `shouldBe` 3
54-
d ^. range `shouldBe` Range (Position 0 0) (Position 1 0)
55-
d ^. severity `shouldBe` Nothing
56-
d ^. code `shouldBe` Nothing
57-
d ^. source `shouldBe` Just "eg2"
58-
d ^. message `shouldBe` T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave"
57+
d ^. LSP.range `shouldBe` Range (Position 0 0) (Position 1 0)
58+
d ^. LSP.severity `shouldBe` Nothing
59+
d ^. LSP.code `shouldBe` Nothing
60+
d ^. LSP.source `shouldBe` Just "eg2"
61+
d ^. LSP.message `shouldBe` T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave"
5962

6063
describe "typed hole errors" $
6164
it "is deferred" $
6265
runSession hieCommand fullCaps "test/testdata" $ do
6366
_ <- openDoc "TypedHoles.hs" "haskell"
6467
[diag] <- waitForDiagnosticsSource "ghcmod"
65-
liftIO $ diag ^. severity `shouldBe` Just DsWarning
68+
liftIO $ diag ^. LSP.severity `shouldBe` Just DsWarning
6669

6770
describe "Warnings are warnings" $
6871
it "Overrides -Werror" $
6972
runSession hieCommand fullCaps "test/testdata/wErrorTest" $ do
7073
_ <- openDoc "src/WError.hs" "haskell"
7174
[diag] <- waitForDiagnosticsSource "ghcmod"
72-
liftIO $ diag ^. severity `shouldBe` Just DsWarning
75+
liftIO $ diag ^. LSP.severity `shouldBe` Just DsWarning
76+
77+
describe "only diagnostics on save" $
78+
it "Respects diagnosticsOnChange setting" $
79+
runSession hieCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
80+
let config = Data.Default.def { diagnosticsOnChange = False } :: Config
81+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
82+
doc <- openDoc "Hover.hs" "haskell"
83+
diags <- waitForDiagnostics
84+
85+
liftIO $ do
86+
length diags `shouldBe` 0
87+
88+
let te = TextEdit (Range (Position 0 0) (Position 0 13)) ""
89+
_ <- applyEdit doc te
90+
noDiagnostics
91+
92+
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
93+
diags2 <- waitForDiagnostics
94+
liftIO $
95+
length diags2 `shouldBe` 1
7396

7497
-- ---------------------------------------------------------------------

‎test/functional/FunctionalCodeActionsSpec.hs

Lines changed: 28 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -24,8 +24,8 @@ spec :: Spec
2424
spec = describe "code actions" $ do
2525
describe "hlint suggestions" $ do
2626
it "provides 3.8 code actions" $ runSession hieCommand fullCaps "test/testdata" $ do
27-
doc <- openDoc "ApplyRefact2.hs" "haskell"
2827

28+
doc <- openDoc "ApplyRefact2.hs" "haskell"
2929
diags@(reduceDiag:_) <- waitForDiagnostics
3030

3131
liftIO $ do
@@ -66,6 +66,33 @@ spec = describe "code actions" $ do
6666

6767
noDiagnostics
6868

69+
it "runs diagnostics on save" $ runSession hieCommand fullCaps "test/testdata" $ do
70+
let config = def { diagnosticsOnChange = False }
71+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
72+
73+
doc <- openDoc "ApplyRefact2.hs" "haskell"
74+
diags@(reduceDiag:_) <- waitForDiagnostics
75+
76+
liftIO $ do
77+
length diags `shouldBe` 2
78+
reduceDiag ^. L.range `shouldBe` Range (Position 1 0) (Position 1 12)
79+
reduceDiag ^. L.severity `shouldBe` Just DsInfo
80+
reduceDiag ^. L.code `shouldBe` Just "Eta reduce"
81+
reduceDiag ^. L.source `shouldBe` Just "hlint"
82+
83+
(CACodeAction ca:_) <- getAllCodeActions doc
84+
85+
-- Evaluate became redundant id in later hlint versions
86+
liftIO $ ["Apply hint:Redundant id", "Apply hint:Evaluate"] `shouldContain` [ca ^. L.title]
87+
88+
executeCodeAction ca
89+
90+
contents <- getDocumentEdit doc
91+
liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"
92+
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
93+
94+
noDiagnostics
95+
6996
-- -----------------------------------
7097

7198
describe "rename suggestions" $ do

‎test/unit/JsonSpec.hs

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -102,4 +102,13 @@ instance Arbitrary Position where
102102
return $ Position l c
103103

104104
instance Arbitrary Config where
105-
arbitrary = Config <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
105+
arbitrary =
106+
Config
107+
<$> arbitrary
108+
<*> arbitrary
109+
<*> arbitrary
110+
<*> arbitrary
111+
<*> arbitrary
112+
<*> arbitrary
113+
<*> arbitrary
114+
<*> arbitrary

0 commit comments

Comments
 (0)