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.4.0.0 +version: 1.5.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -41,9 +41,9 @@ , directory , extra , filepath - , ghcide ^>=1.8 + , ghcide ^>=1.9 , hls-graph - , hls-plugin-api ^>=1.5 + , hls-plugin-api ^>=1.6 , lens , lsp ^>=1.6.0.0 , lsp-test ^>=0.14 diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -16,15 +16,22 @@ defaultTestRunner, goldenGitDiff, goldenWithHaskellDoc, + goldenWithCabalDoc, goldenWithHaskellDocFormatter, + goldenWithCabalDocFormatter, def, + -- * Running HLS for integration tests runSessionWithServer, + runSessionWithServerAndCaps, runSessionWithServerFormatter, + runSessionWithCabalServerFormatter, runSessionWithServer', - waitForProgressDone, - waitForAllProgressDone, + -- * Helpful re-exports PluginDescriptor, IdeState, + -- * Assertion helper functions + waitForProgressDone, + waitForAllProgressDone, waitForBuildQueue, waitForTypecheck, waitForAction, @@ -32,6 +39,16 @@ getLastBuildKeys, waitForKickDone, waitForKickStart, + -- * Plugin descriptor helper functions for tests + PluginTestDescriptor, + pluginTestRecorder, + mkPluginTestDescriptor, + mkPluginTestDescriptor', + -- * Re-export logger types + -- Avoids slightly annoying ghcide imports when they are unnecessary. + WithPriority(..), + Recorder, + Priority(..), ) where @@ -40,6 +57,7 @@ import Control.Concurrent.Extra import Control.Exception.Base import Control.Monad (guard, unless, void) +import Control.Monad.Extra (forM) import Control.Monad.IO.Class import Data.Aeson (Result (Success), Value (Null), fromJSON, @@ -59,7 +77,7 @@ import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Logger (Logger (Logger), +import Development.IDE.Types.Logger (Doc, Logger (Logger), Pretty (pretty), Priority (Debug), Recorder (Recorder, logger_), @@ -69,10 +87,6 @@ import Development.IDE.Types.Options import GHC.IO.Handle import GHC.Stack (emptyCallStack) -import Ide.Plugin.Config (Config, PluginConfig, - formattingProvider, plugins) -import Ide.PluginUtils (idePluginsToPluginDesc, - pluginDescToIdePlugins) import Ide.Types import Language.LSP.Test import Language.LSP.Types hiding @@ -94,6 +108,7 @@ import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun +import Test.Tasty.Runners (NumThreads (..)) newtype Log = LogIDEMain IDEMain.Log @@ -103,7 +118,7 @@ -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () -defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) +defaultTestRunner = defaultMainWithRerun . adjustOption (const $ NumThreads 1) . adjustOption (const $ mkTimeout 600000000) gitDiff :: FilePath -> FilePath -> [String] gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "--no-index", "--text", "--exit-code", fRef, fNew] @@ -112,7 +127,8 @@ goldenGitDiff name = goldenVsStringDiff name gitDiff goldenWithHaskellDoc - :: PluginDescriptor IdeState + :: Pretty b + => PluginTestDescriptor b -> TestName -> FilePath -> FilePath @@ -120,25 +136,161 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithHaskellDoc plugin title testDataDir path desc ext act = +goldenWithHaskellDoc = goldenWithDoc "haskell" + +goldenWithCabalDoc + :: Pretty b + => PluginTestDescriptor b + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithCabalDoc = goldenWithDoc "cabal" + +goldenWithDoc + :: Pretty b + => T.Text + -> PluginTestDescriptor b + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithDoc fileType plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) $ runSessionWithServer plugin testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do - doc <- openDoc (path <.> ext) "haskell" + doc <- openDoc (path <.> ext) fileType void waitForBuildQueue act doc documentContents doc +-- ------------------------------------------------------------ +-- Helper function for initialising plugins under test +-- ------------------------------------------------------------ + +-- | Plugin under test where a fitting recorder is injected. +type PluginTestDescriptor b = Recorder (WithPriority b) -> PluginDescriptor IdeState + +-- | Wrap a plugin you want to test, and inject a fitting recorder as required. +-- +-- If you want to write the logs to stderr, run your tests with +-- "HLS_TEST_PLUGIN_LOG_STDERR=1", e.g. +-- +-- @ +-- HLS_TEST_PLUGIN_LOG_STDERR=1 cabal test +-- @ +-- +-- +-- To write all logs to stderr, including logs of the server, use: +-- +-- @ +-- HLS_TEST_LOG_STDERR=1 cabal test +-- @ +mkPluginTestDescriptor + :: (Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState) + -> PluginId + -> PluginTestDescriptor b +mkPluginTestDescriptor pluginDesc plId recorder = pluginDesc recorder plId + +-- | Wrap a plugin you want to test. +-- +-- Ideally, try to migrate this plugin to co-log logger style architecture. +-- Therefore, you should prefer 'mkPluginTestDescriptor' to this if possible. +mkPluginTestDescriptor' + :: (PluginId -> PluginDescriptor IdeState) + -> PluginId + -> PluginTestDescriptor b +mkPluginTestDescriptor' pluginDesc plId _recorder = pluginDesc plId + +-- | Initialise a recorder that can be instructed to write to stderr by +-- setting the environment variable "HLS_TEST_PLUGIN_LOG_STDERR=1" before +-- running the tests. +-- +-- On the cli, use for example: +-- +-- @ +-- HLS_TEST_PLUGIN_LOG_STDERR=1 cabal test +-- @ +-- +-- To write all logs to stderr, including logs of the server, use: +-- +-- @ +-- HLS_TEST_LOG_STDERR=1 cabal test +-- @ +pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a)) +pluginTestRecorder = do + (recorder, _) <- initialiseTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"] + pure recorder + +-- | Generic recorder initialisation for plugins and the HLS server for test-cases. +-- +-- The created recorder writes to stderr if any of the given environment variables +-- have been set to a value different to @0@. +-- We allow multiple values, to make it possible to define a single environment variable +-- that instructs all recorders in the test-suite to write to stderr. +-- +-- We have to return the base logger function for HLS server logging initialisation. +-- See 'runSessionWithServer'' for details. +initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ()) +initialiseTestRecorder envVars = do + docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug + -- There are potentially multiple environment variables that enable this logger + definedEnvVars <- forM envVars (\var -> fromMaybe "0" <$> lookupEnv var) + let logStdErr = any (/= "0") definedEnvVars + + docWithFilteredPriorityRecorder = + if logStdErr then cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder + else mempty + + Recorder {logger_} = docWithFilteredPriorityRecorder + + pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_) + +-- ------------------------------------------------------------ +-- Run an HLS server testing a specific plugin +-- ------------------------------------------------------------ + +runSessionWithServer :: Pretty b => PluginTestDescriptor b -> FilePath -> Session a -> IO a +runSessionWithServer plugin fp act = do + recorder <- pluginTestRecorder + runSessionWithServer' [plugin recorder] def def fullCaps fp act + +runSessionWithServerAndCaps :: Pretty b => PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a +runSessionWithServerAndCaps plugin caps fp act = do + recorder <- pluginTestRecorder + runSessionWithServer' [plugin recorder] def def caps fp act + +runSessionWithServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a +runSessionWithServerFormatter plugin formatter conf fp act = do + recorder <- pluginTestRecorder + runSessionWithServer' + [plugin recorder] + def + { formattingProvider = T.pack formatter + , plugins = M.singleton (PluginId $ T.pack formatter) conf + } + def + fullCaps + fp + act + goldenWithHaskellDocFormatter - :: PluginDescriptor IdeState - -> String + :: Pretty b + => PluginTestDescriptor b -- ^ Formatter plugin to be used + -> String -- ^ Name of the formatter to be used -> PluginConfig - -> TestName - -> FilePath - -> FilePath - -> FilePath - -> FilePath + -> TestName -- ^ Title of the test + -> FilePath -- ^ Directory of the test data to be used + -> FilePath -- ^ Path to the testdata to be used within the directory + -> FilePath -- ^ Additional suffix to be appended to the output file + -> FilePath -- ^ Extension of the output file -> (TextDocumentIdentifier -> Session ()) -> TestTree goldenWithHaskellDocFormatter plugin formatter conf title testDataDir path desc ext act = @@ -151,19 +303,40 @@ act doc documentContents doc -runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a -runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps +goldenWithCabalDocFormatter + :: Pretty b + => PluginTestDescriptor b -- ^ Formatter plugin to be used + -> String -- ^ Name of the formatter to be used + -> PluginConfig + -> TestName -- ^ Title of the test + -> FilePath -- ^ Directory of the test data to be used + -> FilePath -- ^ Path to the testdata to be used within the directory + -> FilePath -- ^ Additional suffix to be appended to the output file + -> FilePath -- ^ Extension of the output file + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithCabalDocFormatter plugin formatter conf title testDataDir path desc ext act = + goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithCabalServerFormatter plugin formatter conf testDataDir + $ TL.encodeUtf8 . TL.fromStrict + <$> do + doc <- openDoc (path <.> ext) "cabal" + void waitForBuildQueue + act doc + documentContents doc -runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a -runSessionWithServerFormatter plugin formatter conf = +runSessionWithCabalServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a +runSessionWithCabalServerFormatter plugin formatter conf fp act = do + recorder <- pluginTestRecorder runSessionWithServer' - [plugin] + [plugin recorder] def - { formattingProvider = T.pack formatter - , plugins = M.singleton (T.pack formatter) conf + { cabalFormattingProvider = T.pack formatter + , plugins = M.singleton (PluginId $ T.pack formatter) conf } def fullCaps + fp act -- | Restore cwd after running an action keepCurrentDirectory :: IO a -> IO a @@ -174,11 +347,13 @@ lock :: Lock lock = unsafePerformIO newLock - -- | Host a server, and run a test session on it -- Note: cwd will be shifted into @root@ in @Session a@ runSessionWithServer' :: - -- | plugins to load on the server + -- | Plugins to load on the server. + -- + -- For improved logging, make sure these plugins have been initalised with + -- the recorder produced by @pluginTestRecorder@. [PluginDescriptor IdeState] -> -- | lsp config for the server Config -> @@ -192,26 +367,24 @@ (inR, inW) <- createPipe (outR, outW) <- createPipe - docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug - - logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + -- Allow three environment variables, because "LSP_TEST_LOG_STDERR" has been used before, + -- (thus, backwards compatibility) and "HLS_TEST_SERVER_LOG_STDERR" because it + -- uses a more descriptive name. + -- It is also in better accordance with 'pluginTestRecorder' which uses "HLS_TEST_PLUGIN_LOG_STDERR". + -- At last, "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins + -- under test. + (recorder, logger_) <- initialiseTestRecorder + ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR", "HLS_TEST_LOG_STDERR"] 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)) - recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder + hlsPlugins = IdePlugins $ Test.blockCommandDescriptor "block-command" : plugins - arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger + arguments@Arguments{ argsIdeOptions, argsLogger } = + testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins - hlsPlugins = - plugins - ++ [Test.blockCommandDescriptor "block-command", Test.plugin] - ++ idePluginsToPluginDesc argsHlsPlugins ideOptions config ghcSession = let defIdeOptions = argsIdeOptions config ghcSession in defIdeOptions @@ -227,7 +400,6 @@ , argsDefaultHlsConfig = conf , argsLogger = argsLogger , argsIdeOptions = ideOptions - , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins } x <- runSessionWithHandles inW outR sconf caps root s 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 @@ -6,37 +6,40 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Test.Hls.Util - ( + ( -- * Test Capabilities codeActionSupportCaps , expectCodeAction - , dontExpectCodeAction - , expectDiagnostic - , expectNoMoreDiagnostics - , expectSameLocations - , failIfSessionTimeout - , flushStackEnvironment - , fromAction - , fromCommand - , getCompletionByLabel + -- * Environment specifications + -- for ignoring tests , ghcVersion, GhcVersion(..) , hostOS, OS(..) , matchesCurrentEnv, EnvSpec(..) - , noLiteralCaps , ignoreForGhcVersions , ignoreInEnv , onlyRunForGhcVersions - , inspectCodeAction - , inspectCommand - , inspectDiagnostic , knownBrokenOnWindows , knownBrokenForGhcVersions , knownBrokenInEnv , onlyWorkForGhcVersions - , setupBuildToolFiles + -- * Extract code actions + , fromAction + , fromCommand + -- * Session Assertion Helpers + , dontExpectCodeAction + , expectDiagnostic + , expectNoMoreDiagnostics + , expectSameLocations + , failIfSessionTimeout + , getCompletionByLabel + , noLiteralCaps + , inspectCodeAction + , inspectCommand + , inspectDiagnostic , SymbolLocation , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout + -- * Temporary directories , withCurrentDirectoryInTmp , withCurrentDirectoryInTmp' , withCanonicalTempDir @@ -61,7 +64,6 @@ 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.Info.Extra (isMac, isWindows) import qualified System.IO.Extra @@ -87,34 +89,9 @@ literalSupport = CodeActionLiteralSupport def -- --------------------------------------------------------------------- - -setupBuildToolFiles :: IO () -setupBuildToolFiles = do - forM_ files setupDirectFilesIn - -setupDirectFilesIn :: FilePath -> IO () -setupDirectFilesIn f = - writeFile (f ++ "hie.yaml") hieYamlCradleDirectContents - - +-- Environment specification for ignoring tests -- --------------------------------------------------------------------- -files :: [FilePath] -files = - [ "./test/testdata/" - -- , "./test/testdata/addPackageTest/cabal-exe/" - -- , "./test/testdata/addPackageTest/hpack-exe/" - -- , "./test/testdata/addPackageTest/cabal-lib/" - -- , "./test/testdata/addPackageTest/hpack-lib/" - -- , "./test/testdata/addPragmas/" - -- , "./test/testdata/badProjects/cabal/" - -- , "./test/testdata/completion/" - -- , "./test/testdata/definition/" - -- , "./test/testdata/gototest/" - -- , "./test/testdata/redundantImportTest/" - -- , "./test/testdata/wErrorTest/" - ] - data EnvSpec = HostOS OS | GhcVer GhcVersion deriving (Show, Eq) @@ -165,30 +142,6 @@ if ghcVersion `elem` vers then const id else ignoreTestBecause - --- --------------------------------------------------------------------- - -hieYamlCradleDirectContents :: String -hieYamlCradleDirectContents = unlines - [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" - , "cradle:" - , " direct:" - , " arguments:" - , " - -i." - ] - - --- --------------------------------------------------------------------- - -flushStackEnvironment :: IO () -flushStackEnvironment = do - -- We need to clear these environment variables to prevent - -- collisions with stack usages - -- See https://github.com/commercialhaskell/stack/issues/4875 - unsetEnv "GHC_PACKAGE_PATH" - unsetEnv "GHC_ENVIRONMENT" - unsetEnv "HASKELL_PACKAGE_SANDBOX" - unsetEnv "HASKELL_PACKAGE_SANDBOXES" -- ---------------------------------------------------------------------