diff --git a/hls-test-utils.cabal b/hls-test-utils.cabal --- a/hls-test-utils.cabal +++ b/hls-test-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils -version: 1.3.0.0 +version: 1.4.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -41,13 +41,13 @@ , directory , extra , filepath - , ghcide ^>=1.6 || ^>=1.7 + , ghcide ^>=1.8 , hls-graph - , hls-plugin-api ^>=1.3 || ^>=1.4 + , hls-plugin-api ^>=1.5 , lens - , lsp ^>=1.4 + , lsp ^>=1.6.0.0 , lsp-test ^>=0.14 - , lsp-types ^>=1.4.0.1 + , lsp-types ^>=1.6.0.0 , tasty , tasty-expected-failure , tasty-golden diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -47,8 +47,8 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Default (def) -import Data.Maybe (fromMaybe) import qualified Data.Map as M +import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -69,7 +69,8 @@ import Development.IDE.Types.Options import GHC.IO.Handle import GHC.Stack (emptyCallStack) -import Ide.Plugin.Config (Config, formattingProvider, PluginConfig, plugins) +import Ide.Plugin.Config (Config, PluginConfig, + formattingProvider, plugins) import Ide.PluginUtils (idePluginsToPluginDesc, pluginDescToIdePlugins) import Ide.Types @@ -188,57 +189,56 @@ Session a -> IO a runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do - (inR, inW) <- createPipe - (outR, outW) <- createPipe + (inR, inW) <- createPipe + (outR, outW) <- createPipe - docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug + docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug - logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" - let - docWithFilteredPriorityRecorder@Recorder{ logger_ } = - if logStdErr == "0" then mempty - else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder + let + docWithFilteredPriorityRecorder@Recorder{ logger_ } = + if logStdErr == "0" then mempty + else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder - -- exists until old logging style is phased out - logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) + -- exists until old logging style is phased out + logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) - recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder + recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder - arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger - hlsPlugins = - idePluginsToPluginDesc argsHlsPlugins - ++ [Test.blockCommandDescriptor "block-command", Test.plugin] - ++ plugins - ideOptions = \config ghcSession -> - let defIdeOptions = argsIdeOptions config ghcSession - in defIdeOptions - { optTesting = IdeTesting True - , optCheckProject = pure False - } + hlsPlugins = + plugins + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ++ idePluginsToPluginDesc argsHlsPlugins + ideOptions config ghcSession = + let defIdeOptions = argsIdeOptions config ghcSession + in defIdeOptions + { optTesting = IdeTesting True + , optCheckProject = pure False + } - server <- - async $ - Ghcide.defaultMain - (cmapWithPrio LogIDEMain recorder) - arguments - { argsHandleIn = pure inR - , argsHandleOut = pure outW - , argsDefaultHlsConfig = conf - , argsLogger = argsLogger - , argsIdeOptions = ideOptions - , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins } + server <- async $ + Ghcide.defaultMain (cmapWithPrio LogIDEMain recorder) + arguments + { argsHandleIn = pure inR + , argsHandleOut = pure outW + , argsDefaultHlsConfig = conf + , argsLogger = argsLogger + , argsIdeOptions = ideOptions + , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins + } - x <- runSessionWithHandles inW outR sconf caps root s - hClose inW - timeout 3 (wait server) >>= \case - Just () -> pure () - Nothing -> do - putStrLn "Server does not exit in 3s, canceling the async task..." - (t, _) <- duration $ cancel server - putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" - pure x + x <- runSessionWithHandles inW outR sconf caps root s + hClose inW + timeout 3 (wait server) >>= \case + Just () -> pure () + Nothing -> do + putStrLn "Server does not exit in 3s, canceling the async task..." + (t, _) <- duration $ cancel server + putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" + pure x -- | Wait for the next progress end step waitForProgressDone :: Session () diff --git a/src/Test/Hls/Util.hs b/src/Test/Hls/Util.hs --- a/src/Test/Hls/Util.hs +++ b/src/Test/Hls/Util.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Test.Hls.Util @@ -25,12 +24,14 @@ , noLiteralCaps , ignoreForGhcVersions , ignoreInEnv + , onlyRunForGhcVersions , inspectCodeAction , inspectCommand , inspectDiagnostic , knownBrokenOnWindows , knownBrokenForGhcVersions , knownBrokenInEnv + , onlyWorkForGhcVersions , setupBuildToolFiles , SymbolLocation , waitForDiagnosticsFrom @@ -38,12 +39,13 @@ , waitForDiagnosticsFromSourceWithTimeout , withCurrentDirectoryInTmp , withCurrentDirectoryInTmp' + , withCanonicalTempDir ) where import Control.Applicative.Combinators (skipManyTill, (<|>)) import Control.Exception (catch, throwIO) -import Control.Lens ((^.)) +import Control.Lens ((&), (?~), (^.)) import Control.Monad import Control.Monad.IO.Class import qualified Data.Aeson as A @@ -52,16 +54,18 @@ import Data.List.Extra (find) import qualified Data.Set as Set import qualified Data.Text as T -import Development.IDE (GhcVersion(..), ghcVersion) +import Development.IDE (GhcVersion (..), ghcVersion) import qualified Language.LSP.Test as Test import Language.LSP.Types hiding (Reason (..)) import qualified Language.LSP.Types.Capabilities as C +import Language.LSP.Types.Lens (textDocument) import qualified Language.LSP.Types.Lens as L import System.Directory import System.Environment import System.FilePath -import System.IO.Temp import System.Info.Extra (isMac, isWindows) +import qualified System.IO.Extra +import System.IO.Temp import System.Time.Extra (Seconds, sleep) import Test.Tasty (TestTree) import Test.Tasty.ExpectedFailure (expectFailBecause, @@ -70,13 +74,13 @@ (@?=)) noLiteralCaps :: C.ClientCapabilities -noLiteralCaps = def { C._textDocument = Just textDocumentCaps } +noLiteralCaps = def & textDocument ?~ textDocumentCaps where textDocumentCaps = def { C._codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing codeActionSupportCaps :: C.ClientCapabilities -codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } +codeActionSupportCaps = def & textDocument ?~ textDocumentCaps where textDocumentCaps = def { C._codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing @@ -148,6 +152,20 @@ ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree ignoreForGhcVersions vers = ignoreInEnv (map GhcVer vers) +-- | Mark as broken if GHC does not match only work versions. +onlyWorkForGhcVersions :: (GhcVersion -> Bool) -> String -> TestTree -> TestTree +onlyWorkForGhcVersions p reason = + if p ghcVersion + then id + else expectFailBecause reason + +-- | Ignore the test if GHC does not match only work versions. +onlyRunForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +onlyRunForGhcVersions vers = + if ghcVersion `elem` vers + then const id + else ignoreTestBecause + -- --------------------------------------------------------------------- hieYamlCradleDirectContents :: String @@ -237,7 +255,7 @@ onMatch as predicate err = maybe (fail err) return (find predicate as) noMatch :: [a] -> (a -> Bool) -> String -> IO () -noMatch [] _ _ = pure () +noMatch [] _ _ = pure () noMatch as predicate err = bool (pure ()) (fail err) (any predicate as) inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic @@ -279,16 +297,7 @@ else return diags waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic] -waitForDiagnosticsFromSource doc src = do - diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics) - let (List diags) = diagsNot ^. L.params . L.diagnostics - let res = filter matches diags - if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res - then waitForDiagnosticsFromSource doc src - else return res - where - matches :: Diagnostic -> Bool - matches d = d ^. L.source == Just (T.pack src) +waitForDiagnosticsFromSource = waitForDiagnosticsFromSourceWithTimeout 5 -- | wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period @@ -304,38 +313,31 @@ -- If timeout is 0 it will wait until the session timeout waitForDiagnosticsFromSourceWithTimeout :: Seconds -> TextDocumentIdentifier -> String -> Test.Session [Diagnostic] waitForDiagnosticsFromSourceWithTimeout timeout document source = do - when (timeout > 0) $ do + when (timeout > 0) $ -- Give any further diagnostic messages time to arrive. liftIO $ sleep timeout -- Send a dummy message to provoke a response from the server. -- This guarantees that we have at least one message to -- process, so message won't block or timeout. - void $ Test.sendNotification (SCustomMethod "non-existent-method") A.Null - handleMessages + testId <- Test.sendRequest (SCustomMethod "test") A.Null + handleMessages testId where matches :: Diagnostic -> Bool matches d = d ^. L.source == Just (T.pack source) - handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers - handleDiagnostic = do + handleMessages testId = handleDiagnostic testId <|> handleCustomMethodResponse testId <|> ignoreOthers testId + handleDiagnostic testId = do diagsNot <- Test.message STextDocumentPublishDiagnostics let fileUri = diagsNot ^. L.params . L.uri (List diags) = diagsNot ^. L.params . L.diagnostics res = filter matches diags if fileUri == document ^. L.uri && not (null res) - then return diags else handleMessages - handleCustomMethodResponse = - -- the CustomClientMethod triggers a RspCustomServer - -- handle that and then exit - void (Test.satisfyMaybe responseForNonExistentMethod) >> return [] - - responseForNonExistentMethod :: FromServerMessage -> Maybe FromServerMessage - responseForNonExistentMethod notif - | FromServerMess SWindowLogMessage logMsg <- notif, - "non-existent-method" `T.isInfixOf` (logMsg ^. L.params . L.message) = Just notif - | otherwise = Nothing + then return res else handleMessages testId + handleCustomMethodResponse testId = do + _ <- Test.responseForId (SCustomMethod "test") testId + pure [] - ignoreOthers = void Test.anyMessage >> handleMessages + ignoreOthers testId = void Test.anyMessage >> handleMessages testId failIfSessionTimeout :: IO a -> IO a failIfSessionTimeout action = action `catch` errorHandler @@ -362,9 +364,16 @@ -- --------------------------------------------------------------------- getCompletionByLabel :: MonadIO m => T.Text -> [CompletionItem] -> m CompletionItem -getCompletionByLabel desiredLabel compls = +getCompletionByLabel desiredLabel compls = case find (\c -> c ^. L.label == desiredLabel) compls of Just c -> pure c Nothing -> liftIO . assertFailure $ "Completion with label " <> show desiredLabel <> " not found in " <> show (fmap (^. L.label) compls) + +-- --------------------------------------------------------------------- +-- Run with a canonicalized temp dir +withCanonicalTempDir :: (FilePath -> IO a) -> IO a +withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir'