diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 19e0f40e24..2a594c1021 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -29,6 +29,7 @@ import Development.IDE.Graph import Control.Concurrent.STM.Stats (atomically, modifyTVar') import Data.Aeson (toJSON) +import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 921dfe3e6d..e37c3741c7 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -73,7 +73,8 @@ module Development.IDE.Core.Shake( garbageCollectDirtyKeysOlderThan, Log(..), VFSModified(..), getClientConfigAction, - ThreadQueue(..) + ThreadQueue(..), + runWithSignal ) where import Control.Concurrent.Async @@ -123,6 +124,10 @@ import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes +import Development.IDE.Types.Options as Options +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Server as LSP + import Development.IDE.Core.Tracing import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, @@ -147,11 +152,11 @@ import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location import Development.IDE.Types.Monitoring (Monitoring (..)) -import Development.IDE.Types.Options import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownSymbol) import HieDb.Types import Ide.Logger hiding (Priority) import qualified Ide.Logger as Logger @@ -165,7 +170,6 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Server as LSP import Language.LSP.VFS hiding (start) import qualified "list-t" ListT import OpenTelemetry.Eventlog hiding (addEvent) @@ -1350,9 +1354,9 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti let uri' = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do - join $ mask_ $ do - lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics - let action = when (lastPublish /= newDiags) $ case lspEnv of + join $ mask_ $ do + lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics + let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) Just env -> LSP.runLspT env $ do @@ -1360,19 +1364,18 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti liftIO $ tag "key" (show k) LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $ LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) newDiags - return action + return action where diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} | coerce ideTesting = c & L.relatedInformation ?~ - [ - DiagnosticRelatedInformation + [ DiagnosticRelatedInformation (Location (filePathToUri $ fromNormalizedFilePath fp) _range ) (T.pack $ show k) - ] + ] | otherwise = c @@ -1444,3 +1447,19 @@ updatePositionMappingHelper ver changes mappingForUri = snd $ EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc))) zeroMapping (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri) + +-- | sends a signal whenever shake session is run/restarted +-- being used in cabal and hlint plugin tests to know when its time +-- to look for file diagnostics +kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action () +kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ + toJSON $ map fromNormalizedFilePath files + +-- | Add kick start/done signal to rule +runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action () +runWithSignal msgStart msgEnd files rule = do + ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras + kickSignal testing lspEnv files msgStart + void $ uses rule files + kickSignal testing lspEnv files msgEnd diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 4beffcc5de..c79d714fc3 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -716,7 +716,6 @@ library hls-hlint-plugin , hlint >= 3.5 && < 3.9 , hls-plugin-api == 2.9.0.1 , lens - , lsp , mtl , refact , regex-tdfa @@ -727,6 +726,8 @@ library hls-hlint-plugin , unordered-containers , ghc-lib-parser-ex , apply-refact + -- + , lsp-types if flag(ghc-lib) cpp-options: -DGHC_LIB diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 479f1b04d6..2ca477d896 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -61,7 +61,9 @@ module Test.Hls WithPriority(..), Recorder, Priority(..), - TestConfig(..), + captureKickDiagnostics, + kick, + TestConfig(..) ) where @@ -69,6 +71,7 @@ import Control.Applicative.Combinators import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Safe +import Control.Lens ((^.)) import Control.Lens.Extras (is) import Control.Monad (guard, unless, void) import Control.Monad.Extra (forM) @@ -80,7 +83,7 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Default (Default, def) import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -114,6 +117,7 @@ import Ide.PluginUtils (idePluginsToPluginDes pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types hiding (Null) @@ -231,14 +235,14 @@ goldenWithTestConfig :: Pretty b => TestConfig b -> TestName - -> FilePath + -> VirtualFileTree -> FilePath -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithTestConfig config title testDataDir path desc ext act = - goldenGitDiff title (testDataDir path <.> desc <.> ext) +goldenWithTestConfig config title tree path desc ext act = + goldenGitDiff title (vftOriginalRoot tree path <.> desc <.> ext) $ runSessionWithTestConfig config $ const $ TL.encodeUtf8 . TL.fromStrict <$> do @@ -869,6 +873,17 @@ setHlsConfig config = do -- requests! skipManyTill anyMessage (void configurationRequest) +captureKickDiagnostics :: Session () -> Session () -> Session [Diagnostic] +captureKickDiagnostics start done = do + _ <- skipManyTill anyMessage start + messages <- manyTill anyMessage done + pure $ concat $ mapMaybe diagnostics messages + where + diagnostics :: FromServerMessage' a -> Maybe [Diagnostic] + diagnostics = \msg -> case msg of + FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just (diags ^. L.params . L.diagnostics) + _ -> Nothing + waitForKickDone :: Session () waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone @@ -881,9 +896,11 @@ nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null nonTrivialKickStart :: Session () nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null + kick :: KnownSymbol k => Proxy k -> Session [FilePath] kick proxyMsg = do NotMess TNotificationMessage{_params} <- customNotification proxyMsg case fromJSON _params of Success x -> return x other -> error $ "Failed to parse kick/done details: " <> show other + diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index a28cdd1436..7d23cea6c9 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -231,7 +231,7 @@ function invocation. kick :: Action () kick = do files <- HashMap.keys <$> getCabalFilesOfInterestUntracked - void $ uses Types.ParseCabalFile files + Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile -- ---------------------------------------------------------------- -- Code Actions diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index f39792fad7..ddc197c4ae 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -85,6 +85,7 @@ codeActionUnitTests = where maxCompletions = 100 + -- ------------------------ ------------------------------------------------ -- Integration Tests -- ------------------------------------------------------------------------ @@ -96,8 +97,8 @@ pluginTests = [ testGroup "Diagnostics" [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do - doc <- openDoc "invalid.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" + _ <- openDoc "invalid.cabal" "cabal" + diags <- cabalCaptureKick unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 @@ -105,14 +106,14 @@ pluginTests = unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error , runCabalTestCaseSession "Clears diagnostics" "" $ do doc <- openDoc "invalid.cabal" "cabal" - diags <- waitForDiagnosticsFrom doc + diags <- cabalCaptureKick unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n" - newDiags <- waitForDiagnosticsFrom doc + newDiags <- cabalCaptureKick liftIO $ newDiags @?= [] , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do hsDoc <- openDoc "A.hs" "haskell" diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs index c69b229c09..bcafa01fac 100644 --- a/plugins/hls-cabal-plugin/test/Utils.hs +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module Utils where +import Control.Monad (guard) import Data.List (sort) +import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import Ide.Plugin.Cabal (descriptor) import qualified Ide.Plugin.Cabal @@ -52,6 +55,18 @@ runCabalGoldenSession title subdir fp act = goldenWithCabalDoc def cabalPlugin t testDataDir :: FilePath testDataDir = "plugins" "hls-cabal-plugin" "test" "testdata" +-- | these functions are used to detect cabal kicks +-- and look at diagnostics for cabal files +-- kicks are run everytime there is a shake session run/restart +cabalKickDone :: Session () +cabalKickDone = kick (Proxy @"kick/done/cabal") >>= guard . not . null + +cabalKickStart :: Session () +cabalKickStart = kick (Proxy @"kick/start/cabal") >>= guard . not . null + +cabalCaptureKick :: Session [Diagnostic] +cabalCaptureKick = captureKickDiagnostics cabalKickStart cabalKickDone + -- | list comparison where the order in the list is irrelevant (@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion (@?==) l1 l2 = sort l1 @?= sort l2 diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index ec20569b9d..23a5683c29 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -29,7 +29,6 @@ import Control.Concurrent.STM import Control.DeepSeq import Control.Exception import Control.Lens ((?~), (^.)) -import Control.Monad import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) @@ -119,6 +118,7 @@ import System.Environment (setEnv, #endif import Development.IDE.Core.PluginUtils as PluginUtils import Text.Regex.TDFA.Text () + -- --------------------------------------------------------------------- data Log @@ -134,7 +134,7 @@ instance Pretty Log where LogShake log -> pretty log LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas - LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts + LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <> line <> indent 4 (pretty exts) LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp LogResolve msg -> pretty msg @@ -183,12 +183,12 @@ instance NFData GetHlintDiagnostics type instance RuleResult GetHlintDiagnostics = () -- | Hlint rules to generate file diagnostics based on hlint hints --- | This rule is recomputed when: --- | - A file has been edited via --- | - `getIdeas` -> `getParsedModule` in any case --- | - `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` +-- This rule is recomputed when: +-- - A file has been edited via +-- - `getIdeas` -> `getParsedModule` in any case +-- - `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 :: Recorder (WithPriority Log) -> PluginId -> Rules () rules recorder plugin = do define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do @@ -202,8 +202,8 @@ rules recorder plugin = do liftIO $ argsSettings flags action $ do - files <- getFilesOfInterestUntracked - void $ uses GetHlintDiagnostics $ Map.keys files + files <- Map.keys <$> getFilesOfInterestUntracked + Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") files GetHlintDiagnostics where diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 17f83e291a..5db5d485a4 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main @@ -5,19 +7,21 @@ module Main ) where import Control.Lens ((^.)) -import Control.Monad (when) +import Control.Monad (guard, when) import Data.Aeson (Value (..), object, (.=)) import Data.Functor (void) import Data.List (find) import qualified Data.Map as Map import Data.Maybe (fromJust, isJust) +import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import Ide.Plugin.Config (Config (..)) import qualified Ide.Plugin.Config as Plugin import qualified Ide.Plugin.Hlint as HLint import qualified Language.LSP.Protocol.Lens as L -import System.FilePath (()) +import System.FilePath ((<.>), ()) import Test.Hls +import Test.Hls.FileSystem main :: IO () main = defaultTestRunner tests @@ -86,7 +90,7 @@ suggestionsTests = testGroup "hlint suggestions" [ testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do doc <- openDoc "Base.hs" "haskell" - diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint" + diags@(reduceDiag:_) <- hlintCaptureKick liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" @@ -124,7 +128,7 @@ suggestionsTests = , testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc "hlint" + _ <- hlintCaptureKick cars <- getAllCodeActions doc etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] @@ -136,7 +140,7 @@ suggestionsTests = , testCase ".hlint.yaml fixity rules are applied" $ runHlintSession "fixity" $ do doc <- openDoc "FixityUse.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do doc <- openDoc "Base.hs" "haskell" @@ -150,7 +154,8 @@ suggestionsTests = } changeDoc doc [change] - expectNoMoreDiagnostics 3 doc "hlint" + -- We need to wait until hlint has been rerun and clears the diagnostic + [] <- waitForDiagnosticsFrom doc let change' = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial @@ -166,7 +171,7 @@ suggestionsTests = testHlintDiagnostics doc , knownBrokenForHlintOnGhcLib "hlint doesn't take in account cpp flag as ghc -D argument" $ - testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "" $ do + testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "cpp" $ do doc <- openDoc "CppCond.hs" "haskell" testHlintDiagnostics doc @@ -186,27 +191,27 @@ suggestionsTests = testRefactor "LambdaCase.hs" "Redundant bracket" ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase) - , expectFailBecause "apply-refact doesn't work with cpp" $ + , ignoreTestBecause "apply-refact doesn't work with cpp" $ testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do testRefactor "CppCond.hs" "Redundant bracket" expectedCPP - , expectFailBecause "apply-refact doesn't work with cpp" $ + , ignoreTestBecause "apply-refact doesn't work with cpp" $ testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do testRefactor "CppCond.hs" "Redundant bracket" ("{-# LANGUAGE CPP #-}" : expectedCPP) , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do doc <- openDoc "CamelCase.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do doc <- openDoc "IgnoreAnn.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do doc <- openDoc "IgnoreAnnHlint.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do testRefactor "Comments.hs" "Redundant bracket" expectedComments @@ -216,7 +221,7 @@ suggestionsTests = , testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession "" $ do doc <- openDoc "TwoHints.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc "hlint" + _ <- hlintCaptureKick firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0) secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0) @@ -231,22 +236,20 @@ suggestionsTests = liftIO $ hasApplyAll multiLine @? "Missing apply all code action" , testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do - doc <- openDoc "UnusedExtension.hs" "haskell" - diags@(unusedExt:_) <- waitForDiagnosticsFromSource doc "hlint" + _ <- openDoc "UnusedExtension.hs" "haskell" + diags@(unusedExt:_) <- hlintCaptureKick liftIO $ do length diags @?= 1 unusedExt ^. L.code @?= Just (InR "refact:Unused LANGUAGE pragma") - , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do + , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do doc <- openDoc "PatternKeyword.hs" "haskell" - -- hlint will report a parse error if PatternSynonyms is enabled - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do doc <- openDoc "StrictData.hs" "haskell" - - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc ] where testRefactor file caTitle expected = do @@ -301,9 +304,7 @@ configTests = testGroup "hlint plugin config" [ disableHlint - diags' <- waitForDiagnosticsFrom doc - - liftIO $ noHlintDiagnostics diags' + testNoHlintDiagnostics doc , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do setIgnoringConfigurationRequests False @@ -315,9 +316,7 @@ configTests = testGroup "hlint plugin config" [ let config' = hlintConfigWithFlags ["--ignore=Redundant id", "--hint=test-hlint-config.yaml"] setHlsConfig config' - diags' <- waitForDiagnosticsFrom doc - - liftIO $ noHlintDiagnostics diags' + testNoHlintDiagnostics doc , testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do setIgnoringConfigurationRequests False @@ -325,12 +324,12 @@ configTests = testGroup "hlint plugin config" [ doc <- openDoc "Generalise.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc let config' = hlintConfigWithFlags ["--with-group=generalise"] setHlsConfig config' - diags' <- waitForDiagnosticsFromSource doc "hlint" + diags' <- hlintCaptureKick d <- liftIO $ inspectDiagnostic diags' ["Use <>"] liftIO $ do @@ -352,14 +351,39 @@ runHlintSession subdir = failIfSessionTimeout . } . const -noHlintDiagnostics :: [Diagnostic] -> Assertion +hlintKickDone :: Session () +hlintKickDone = kick (Proxy @"kick/done/hlint") >>= guard . not . null + +hlintKickStart :: Session () +hlintKickStart = kick (Proxy @"kick/start/hlint") >>= guard . not . null + +hlintCaptureKick :: Session [Diagnostic] +hlintCaptureKick = captureKickDiagnostics hlintKickStart hlintKickDone + +noHlintDiagnostics :: HasCallStack => [Diagnostic] -> Assertion noHlintDiagnostics diags = - Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" + all (not . isHlintDiagnostic) diags @? "There are hlint diagnostics" + +isHlintDiagnostic :: Diagnostic -> Bool +isHlintDiagnostic diag = + Just "hlint" == diag ^. L.source -testHlintDiagnostics :: TextDocumentIdentifier -> Session () +testHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session () testHlintDiagnostics doc = do - diags <- waitForDiagnosticsFromSource doc "hlint" - liftIO $ length diags > 0 @? "There are hlint diagnostics" + diags <- captureKickNonEmptyDiagnostics doc + liftIO $ length diags > 0 @? "There are no hlint diagnostics" + +captureKickNonEmptyDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session [Diagnostic] +captureKickNonEmptyDiagnostics doc = do + diags <- hlintCaptureKick + if null diags + then captureKickNonEmptyDiagnostics doc + else pure diags + +testNoHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session () +testNoHlintDiagnostics _doc = do + diags <- hlintCaptureKick + liftIO $ noHlintDiagnostics diags hlintConfigWithFlags :: [T.Text] -> Config hlintConfigWithFlags flags = @@ -385,7 +409,7 @@ disableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", de -- Although a given hlint version supports one direct ghc, we could use several versions of hlint -- each one supporting a different ghc version. It should be a temporary situation though. knownBrokenForHlintOnGhcLib :: String -> TestTree -> TestTree -knownBrokenForHlintOnGhcLib = expectFailBecause +knownBrokenForHlintOnGhcLib = ignoreTestBecause -- 1's based data Point = Point { @@ -408,6 +432,10 @@ makeCodeActionNotFoundAtString :: Point -> String makeCodeActionNotFoundAtString Point {..} = "CodeAction not found at line: " <> show line <> ", column: " <> show column +-- ------------------------------------------------------------------------ +-- Test runner helpers +-- ------------------------------------------------------------------------ + ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenTest testCaseName goldenFilename point hintName = goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName) @@ -418,8 +446,8 @@ applyHintGoldenTest testCaseName goldenFilename point hintName = do goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenTest testCaseName goldenFilename point hintText = - setupGoldenHlintTest testCaseName goldenFilename $ \document -> do - _ <- waitForDiagnosticsFromSource document "hlint" + setupGoldenHlintTest testCaseName goldenFilename codeActionNoResolveCaps $ \document -> do + _ <- hlintCaptureKick actions <- getCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> do @@ -429,16 +457,15 @@ goldenTest testCaseName goldenFilename point hintText = _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point -setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -setupGoldenHlintTest testName path = +setupGoldenHlintTest :: TestName -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree +setupGoldenHlintTest testName path config = goldenWithTestConfig def - { testConfigCaps = codeActionNoResolveCaps + { testConfigCaps = config , testShiftRoot = True , testPluginDescriptor = hlintPlugin - , testDirLocation = Left testDir - } - testName testDir path "expected" "hs" - + , testDirLocation = Right tree + } testName tree path "expected" "hs" + where tree = mkVirtualFileTree testDir (directProject (path <.> "hs")) ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = @@ -450,19 +477,9 @@ applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenResolveTest testCaseName goldenFilename point hintText = - setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do - _ <- waitForDiagnosticsFromSource document "hlint" + setupGoldenHlintTest testCaseName goldenFilename codeActionResolveCaps $ \document -> do + _ <- hlintCaptureKick actions <- getAndResolveCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> executeCodeAction codeAction _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point - -setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -setupGoldenHlintResolveTest testName path = - goldenWithTestConfig def - { testConfigCaps = codeActionResolveCaps - , testShiftRoot = True - , testPluginDescriptor = hlintPlugin - , testDirLocation = Left testDir - } - testName testDir path "expected" "hs"