Merge branch 'master' into wip/2.2.0.0

Author: fendor

hls-test-utils/hls-test-utils.cabal

@@ -28,6 +28,7 @@ library
  exposed-modules:
  Test.Hls
  Test.Hls.Util
+ Test.Hls.FileSystem
 
  hs-source-dirs: src
  build-depends:

hls-test-utils/src/Test/Hls.hs

@@ -21,15 +21,22 @@ module Test.Hls
  defaultTestRunner,
  goldenGitDiff,
  goldenWithHaskellDoc,
+ goldenWithHaskellDocInTmpDir,
  goldenWithHaskellAndCaps,
+ goldenWithHaskellAndCapsInTmpDir,
  goldenWithCabalDoc,
  goldenWithHaskellDocFormatter,
+ goldenWithHaskellDocFormatterInTmpDir,
  goldenWithCabalDocFormatter,
+ goldenWithCabalDocFormatterInTmpDir,
  def,
  -- * Running HLS for integration tests
  runSessionWithServer,
  runSessionWithServerAndCaps,
+ runSessionWithServerInTmpDir,
+ runSessionWithServerAndCapsInTmpDir,
  runSessionWithServer',
+ runSessionWithServerInTmpDir',
  -- * Helpful re-exports
  PluginDescriptor,
  IdeState,
@@ -90,11 +97,13 @@ import GHC.Stack (emptyCallStack)
 import GHC.TypeLits
 import Ide.Logger (Doc, Logger (Logger),
  Pretty (pretty),
- Priority (Debug),
+ Priority (..),
  Recorder (Recorder, logger_),
  WithPriority (WithPriority, priority),
  cfilter, cmapWithPrio,
- makeDefaultStderrRecorder)
+ logWith,
+ makeDefaultStderrRecorder,
+ (<+>))
 import Ide.Types
 import Language.LSP.Protocol.Capabilities
 import Language.LSP.Protocol.Message
@@ -105,9 +114,12 @@ import System.Directory (getCurrentDirectory,
  setCurrentDirectory)
 import System.Environment (lookupEnv)
 import System.FilePath
+import System.IO.Extra (newTempDir, withTempDir)
 import System.IO.Unsafe (unsafePerformIO)
 import System.Process.Extra (createPipe)
 import System.Time.Extra
+import qualified Test.Hls.FileSystem as FS
+import Test.Hls.FileSystem
 import Test.Hls.Util
 import Test.Tasty hiding (Timeout)
 import Test.Tasty.ExpectedFailure
@@ -116,11 +128,26 @@ import Test.Tasty.HUnit
 import Test.Tasty.Ingredients.Rerun
 import Test.Tasty.Runners (NumThreads (..))
 
-newtype Log = LogIDEMain IDEMain.Log
+data Log
+ = LogIDEMain IDEMain.Log
+ | LogTestHarness LogTestHarness
 
 instance Pretty Log where
  pretty = \case
- LogIDEMain log -> pretty log
+ LogIDEMain log -> pretty log
+ LogTestHarness log -> pretty log
+
+data LogTestHarness
+ = LogTestDir FilePath
+ | LogCleanup
+ | LogNoCleanup
+
+
+instance Pretty LogTestHarness where
+ pretty = \case
+ LogTestDir dir -> "Test Project located in directory:" <+> pretty dir
+ LogCleanup -> "Cleaned up temporary directory"
+ LogNoCleanup -> "No cleanup of temporary directory"
 
 -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
 defaultTestRunner :: TestTree -> IO ()
@@ -145,6 +172,19 @@ goldenWithHaskellDoc
  -> TestTree
 goldenWithHaskellDoc = goldenWithDoc "haskell"
 
+goldenWithHaskellDocInTmpDir
+ :: Pretty b
+ => Config
+ -> PluginTestDescriptor b
+ -> TestName
+ -> VirtualFileTree
+ -> FilePath
+ -> FilePath
+ -> FilePath
+ -> (TextDocumentIdentifier -> Session ())
+ -> TestTree
+goldenWithHaskellDocInTmpDir = goldenWithDocInTmpDir "haskell"
+
 goldenWithHaskellAndCaps
  :: Pretty b
  => Config
@@ -167,6 +207,28 @@ goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ex
  act doc
  documentContents doc
 
+goldenWithHaskellAndCapsInTmpDir
+ :: Pretty b
+ => Config
+ -> ClientCapabilities
+ -> PluginTestDescriptor b
+ -> TestName
+ -> VirtualFileTree
+ -> FilePath
+ -> FilePath
+ -> FilePath
+ -> (TextDocumentIdentifier -> Session ())
+ -> TestTree
+goldenWithHaskellAndCapsInTmpDir config clientCaps plugin title tree path desc ext act =
+ goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)
+ $ runSessionWithServerAndCapsInTmpDir config plugin clientCaps tree
+ $ TL.encodeUtf8 . TL.fromStrict
+ <$> do
+ doc <- openDoc (path <.> ext) "haskell"
+ void waitForBuildQueue
+ act doc
+ documentContents doc
+
 goldenWithCabalDoc
  :: Pretty b
  => Config
@@ -202,6 +264,28 @@ goldenWithDoc fileType config plugin title testDataDir path desc ext act =
  act doc
  documentContents doc
 
+goldenWithDocInTmpDir
+ :: Pretty b
+ => T.Text
+ -> Config
+ -> PluginTestDescriptor b
+ -> TestName
+ -> VirtualFileTree
+ -> FilePath
+ -> FilePath
+ -> FilePath
+ -> (TextDocumentIdentifier -> Session ())
+ -> TestTree
+goldenWithDocInTmpDir fileType config plugin title tree path desc ext act =
+ goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)
+ $ runSessionWithServerInTmpDir config plugin tree
+ $ TL.encodeUtf8 . TL.fromStrict
+ <$> do
+ doc <- openDoc (path <.> ext) fileType
+ void waitForBuildQueue
+ act doc
+ documentContents doc
+
 -- ------------------------------------------------------------
 -- Helper function for initialising plugins under test
 -- ------------------------------------------------------------
@@ -298,6 +382,76 @@ runSessionWithServerAndCaps config plugin caps fp act = do
  recorder <- pluginTestRecorder
  runSessionWithServer' (plugin recorder) config def caps fp act
 
+runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a
+runSessionWithServerInTmpDir config plugin tree act = do
+ recorder <- pluginTestRecorder
+ runSessionWithServerInTmpDir' (plugin recorder) config def fullCaps tree act
+
+runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a
+runSessionWithServerAndCapsInTmpDir config plugin caps tree act = do
+ recorder <- pluginTestRecorder
+ runSessionWithServerInTmpDir' (plugin recorder) config def caps tree act
+
+-- | Host a server, and run a test session on it.
+--
+-- Creates a temporary directory, and materializes the VirtualFileTree
+-- in the temporary directory.
+--
+-- To debug test cases and verify the file system is correctly set up,
+-- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'.
+-- Further, we log the temporary directory location on startup. To view
+-- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'.
+--
+-- Example invocation to debug test cases:
+--
+-- @
+-- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test <plugin-name>
+-- @
+--
+-- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests.
+--
+-- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'.
+--
+-- Note: cwd will be shifted into a temporary directory in @Session a@
+runSessionWithServerInTmpDir' ::
+ -- | Plugins to load on the server.
+ --
+ -- For improved logging, make sure these plugins have been initalised with
+ -- the recorder produced by @pluginTestRecorder@.
+ IdePlugins IdeState ->
+ -- | lsp config for the server
+ Config ->
+ -- | config for the test session
+ SessionConfig ->
+ ClientCapabilities ->
+ VirtualFileTree ->
+ Session a ->
+ IO a
+runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do
+ (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
+ Just val
+ | val /= "0" -> \action -> do
+ (tempDir, _) <- newTempDir
+ a <- action tempDir
+ logWith recorder Debug $ LogNoCleanup
+ pure a
+
+ _ -> \action -> do
+ a <- withTempDir action
+ logWith recorder Debug $ LogCleanup
+ pure a
+
+ runTestInDir $ \tmpDir -> do
+ logWith recorder Info $ LogTestDir tmpDir
+ _fs <- FS.materialiseVFT tmpDir tree
+ runSessionWithServer' plugins conf sessConf caps tmpDir act
+
 goldenWithHaskellDocFormatter
  :: Pretty b
  => Config
@@ -346,6 +500,54 @@ goldenWithCabalDocFormatter config plugin formatter conf title testDataDir path
  act doc
  documentContents doc
 
+goldenWithHaskellDocFormatterInTmpDir
+ :: Pretty b
+ => Config
+ -> PluginTestDescriptor b -- ^ Formatter plugin to be used
+ -> String -- ^ Name of the formatter to be used
+ -> PluginConfig
+ -> TestName -- ^ Title of the test
+ -> VirtualFileTree -- ^ Virtual representation of the test project
+ -> 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
+goldenWithHaskellDocFormatterInTmpDir config plugin formatter conf title tree path desc ext act =
+ let config' = config { formattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }
+ in goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)
+ $ runSessionWithServerInTmpDir config' plugin tree
+ $ TL.encodeUtf8 . TL.fromStrict
+ <$> do
+ doc <- openDoc (path <.> ext) "haskell"
+ void waitForBuildQueue
+ act doc
+ documentContents doc
+
+goldenWithCabalDocFormatterInTmpDir
+ :: Pretty b
+ => Config
+ -> PluginTestDescriptor b -- ^ Formatter plugin to be used
+ -> String -- ^ Name of the formatter to be used
+ -> PluginConfig
+ -> TestName -- ^ Title of the test
+ -> VirtualFileTree -- ^ Virtual representation of the test project
+ -> 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
+goldenWithCabalDocFormatterInTmpDir config plugin formatter conf title tree path desc ext act =
+ let config' = config { cabalFormattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }
+ in goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)
+ $ runSessionWithServerInTmpDir config' plugin tree
+ $ TL.encodeUtf8 . TL.fromStrict
+ <$> do
+ doc <- openDoc (path <.> ext) "cabal"
+ void waitForBuildQueue
+ act doc
+ documentContents doc
+
 -- | Restore cwd after running an action
 keepCurrentDirectory :: IO a -> IO a
 keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const
@@ -355,6 +557,12 @@ keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const
 lock :: Lock
 lock = unsafePerformIO newLock
 
+
+{-# NOINLINE lockForTempDirs #-}
+-- | Never run in parallel
+lockForTempDirs :: Lock
+lockForTempDirs = unsafePerformIO newLock
+
 -- | Host a server, and run a test session on it
 -- Note: cwd will be shifted into @root@ in @Session a@
 runSessionWithServer' ::
@@ -371,7 +579,7 @@ runSessionWithServer' ::
  FilePath ->
  Session a ->
  IO a
-runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do
+runSessionWithServer' plugins conf sconf caps root s =  withLock lock $ keepCurrentDirectory $ do
  (inR, inW) <- createPipe
  (outR, outW) <- createPipe