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: 2.7.0.0 +version: 2.8.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -41,11 +41,12 @@ , directory , extra , filepath - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp-test ^>=0.17 , lsp-types ^>=2.1 + , safe-exceptions , 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 @@ -63,7 +63,7 @@ import Control.Applicative.Combinators import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra -import Control.Exception.Base +import Control.Exception.Safe import Control.Lens.Extras (is) import Control.Monad (guard, unless, void) import Control.Monad.Extra (forM) @@ -80,23 +80,21 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE (IdeState) +import Development.IDE (IdeState, + LoggingColumn (ThreadIdColumn)) import Development.IDE.Main hiding (Log) -import qualified Development.IDE.Main as Ghcide import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import GHC.IO.Handle -import GHC.Stack (emptyCallStack) import GHC.TypeLits -import Ide.Logger (Doc, Logger (Logger), - Pretty (pretty), - Priority (..), - Recorder (Recorder, logger_), +import Ide.Logger (Pretty (pretty), + Priority (..), Recorder, WithPriority (WithPriority, priority), cfilter, cmapWithPrio, + defaultLoggingColumns, logWith, makeDefaultStderrRecorder, (<+>)) @@ -106,11 +104,13 @@ import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Test import Prelude hiding (log) -import System.Directory (getCurrentDirectory, +import System.Directory (createDirectoryIfMissing, + getCurrentDirectory, + getTemporaryDirectory, setCurrentDirectory) -import System.Environment (lookupEnv) +import System.Environment (lookupEnv, setEnv) import System.FilePath -import System.IO.Extra (newTempDir, withTempDir) +import System.IO.Extra (newTempDirWithin) import System.IO.Unsafe (unsafePerformIO) import System.Process.Extra (createPipe) import System.Time.Extra @@ -336,8 +336,7 @@ -- @ pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a)) pluginTestRecorder = do - (recorder, _) <- initialiseTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"] - pure recorder + initialiseTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"] -- | Generic recorder initialisation for plugins and the HLS server for test-cases. -- @@ -348,9 +347,9 @@ -- -- 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 :: Pretty a => [String] -> IO (Recorder (WithPriority a)) initialiseTestRecorder envVars = do - docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just $ ThreadIdColumn : defaultLoggingColumns) -- There are potentially multiple environment variables that enable this logger definedEnvVars <- forM envVars (\var -> fromMaybe "0" <$> lookupEnv var) let logStdErr = any (/= "0") definedEnvVars @@ -359,9 +358,7 @@ if logStdErr then cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder else mempty - Recorder {logger_} = docWithFilteredPriorityRecorder - - pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_) + pure (cmapWithPrio pretty docWithFilteredPriorityRecorder) -- ------------------------------------------------------------ -- Run an HLS server testing a specific plugin @@ -423,22 +420,24 @@ Session a -> IO a runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do - (recorder, _) <- initialiseTestRecorder + testRoot <- setupTestEnvironment + recorder <- initialiseTestRecorder ["LSP_TEST_LOG_STDERR", "HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"] -- Do not clean up the temporary directory if this variable is set to anything but '0'. -- Aids debugging. cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" - let runTestInDir = case cleanupTempDir of + let runTestInDir action = case cleanupTempDir of Just val - | val /= "0" -> \action -> do - (tempDir, _) <- newTempDir + | val /= "0" -> do + (tempDir, _) <- newTempDirWithin testRoot a <- action tempDir logWith recorder Debug LogNoCleanup pure a - _ -> \action -> do - a <- withTempDir action + _ -> do + (tempDir, cleanup) <- newTempDirWithin testRoot + a <- action tempDir `finally` cleanup logWith recorder Debug LogCleanup pure a @@ -447,6 +446,26 @@ _fs <- FS.materialiseVFT tmpDir tree runSessionWithServer' plugins conf sessConf caps tmpDir act +-- | Setup the test environment for isolated tests. +-- +-- This creates a directory in the temporary directory that will be +-- reused for running isolated tests. +-- It returns the root to the testing directory that tests should use. +-- This directory is not fully cleaned between reruns. +-- However, it is totally safe to delete the directory between runs. +-- +-- Additionally, this overwrites the 'XDG_CACHE_HOME' variable to isolate +-- the tests from existing caches. 'hie-bios' and 'ghcide' honour the +-- 'XDG_CACHE_HOME' environment variable and generate their caches there. +setupTestEnvironment :: IO FilePath +setupTestEnvironment = do + tmpDirRoot <- getTemporaryDirectory + let testRoot = tmpDirRoot "hls-test-root" + testCacheDir = testRoot ".cache" + createDirectoryIfMissing True testCacheDir + setEnv "XDG_CACHE_HOME" testCacheDir + pure testRoot + goldenWithHaskellDocFormatter :: Pretty b => Config @@ -584,18 +603,16 @@ -- 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 + recorder <- initialiseTestRecorder ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR", "HLS_TEST_LOG_STDERR"] let sconf' = sconf { lspConfig = hlsConfigToClientConfig conf } - -- exists until old logging style is phased out - logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins - arguments@Arguments{ argsIdeOptions, argsLogger } = - testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins + arguments@Arguments{ argsIdeOptions } = + testing (cmapWithPrio LogIDEMain recorder) hlsPlugins ideOptions config ghcSession = let defIdeOptions = argsIdeOptions config ghcSession @@ -605,12 +622,11 @@ } server <- async $ - Ghcide.defaultMain (cmapWithPrio LogIDEMain recorder) + IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments { argsHandleIn = pure inR , argsHandleOut = pure outW , argsDefaultHlsConfig = conf - , argsLogger = argsLogger , argsIdeOptions = ideOptions , argsProjectRoot = Just root }