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.2.0.0 +version: 2.3.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -28,6 +28,7 @@ exposed-modules: Test.Hls Test.Hls.Util + Test.Hls.FileSystem hs-source-dirs: src build-depends: @@ -41,9 +42,9 @@ , directory , extra , filepath - , ghcide == 2.2.0.0 + , ghcide == 2.3.0.0 , hls-graph - , hls-plugin-api == 2.2.0.0 + , hls-plugin-api == 2.3.0.0 , lens , lsp ^>=2.2 , lsp-test ^>=0.16 diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -21,15 +21,22 @@ 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.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 @@ 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,12 +128,27 @@ 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 () defaultTestRunner = defaultMainWithRerun . adjustOption (const $ NumThreads 1) . adjustOption (const $ mkTimeout 600000000) @@ -145,6 +172,19 @@ -> 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 @@ 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 @@ 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 @@ 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 +-- @ +-- +-- 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 @@ 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 @@ 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 @@ 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 diff --git a/src/Test/Hls/FileSystem.hs b/src/Test/Hls/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hls/FileSystem.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.Hls.FileSystem + ( FileSystem(..) + , VirtualFileTree(..) + , FileTree + , Content + -- * init + , materialise + , materialiseVFT + -- * Interaction + , readFileFS + , writeFileFS + -- * Test helpers + , mkVirtualFileTree + , toNfp + , toAbsFp + -- * Builders + , file + , copy + , directory + , text + , ref + -- * Cradle helpers + , directCradle + , simpleCabalCradle + -- * Full project setups + , directProject + , directProjectMulti + , simpleCabalProject + , simpleCabalProject' + ) where + +import Data.Foldable (traverse_) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Development.IDE (NormalizedFilePath) +import Language.LSP.Protocol.Types (toNormalizedFilePath) +import System.Directory +import System.FilePath as FP + +-- ---------------------------------------------------------------------------- +-- Top Level definitions +-- ---------------------------------------------------------------------------- + +-- | Representation of a 'VirtualFileTree' that has been 'materialise'd to disk. +-- +data FileSystem = + FileSystem + { fsRoot :: FilePath + , fsTree :: [FileTree] + , fsOriginalRoot :: FilePath + } deriving (Eq, Ord, Show) + +-- | Virtual representation of a filesystem tree. +-- +-- Operations of 'vftTree' are relative to 'vftOriginalRoot'. +-- In particular, any 'copy' etc. operation looks for the sources in 'vftOriginalRoot'. +-- +-- To persist a 'VirtualFileTree', look at 'materialise' and 'materialiseVFT'. +data VirtualFileTree = + VirtualFileTree + { vftTree :: [FileTree] + , vftOriginalRoot :: FilePath + } deriving (Eq, Ord, Show) + +data FileTree + = File FilePath Content + | Directory FilePath [FileTree] + deriving (Show, Eq, Ord) + +data Content + = Inline T.Text + | Ref FilePath + deriving (Show, Eq, Ord) + +-- ---------------------------------------------------------------------------- +-- API with side effects +-- ---------------------------------------------------------------------------- + +readFileFS :: FileSystem -> FilePath -> IO T.Text +readFileFS fs fp = do + T.readFile (fsRoot fs FP.normalise fp) + +writeFileFS :: FileSystem -> FilePath -> Content -> IO () +writeFileFS fs fp content = do + contents <- case content of + Inline txt -> pure txt + Ref path -> T.readFile (fsOriginalRoot fs FP.normalise path) + T.writeFile (fsRoot fs FP.normalise fp) contents + +-- | Materialise a virtual file tree in the 'rootDir' directory. +-- +-- Synopsis: @'materialise' rootDir fileTree testDataDir@ +-- +-- File references in '[FileTree]' are resolved relative to the @testDataDir@. +materialise :: FilePath -> [FileTree] -> FilePath -> IO FileSystem +materialise rootDir' fileTree testDataDir' = do + let testDataDir = FP.normalise testDataDir' + rootDir = FP.normalise rootDir' + + persist :: FilePath -> FileTree -> IO () + persist fp (File name cts) = case cts of + Inline txt -> T.writeFile (fp name) txt + Ref path -> copyFile (testDataDir FP.normalise path) (fp takeFileName name) + persist fp (Directory name nodes) = do + createDirectory (fp name) + mapM_ (persist (fp name)) nodes + + traverse_ (persist rootDir) fileTree + pure $ FileSystem rootDir fileTree testDataDir + +-- | Materialise a virtual file tree in the 'rootDir' directory. +-- +-- Synopsis: @'materialiseVFT' rootDir virtualFileTree@ +-- +-- File references in 'virtualFileTree' are resolved relative to the @vftOriginalRoot@. +materialiseVFT :: FilePath -> VirtualFileTree -> IO FileSystem +materialiseVFT root fs = + materialise root (vftTree fs) (vftOriginalRoot fs) + +-- ---------------------------------------------------------------------------- +-- Test definition helpers +-- ---------------------------------------------------------------------------- + +mkVirtualFileTree :: FilePath -> [FileTree] -> VirtualFileTree +mkVirtualFileTree testDataDir tree = + VirtualFileTree + { vftTree = tree + , vftOriginalRoot = testDataDir + } + +toAbsFp :: FileSystem -> FilePath -> FilePath +toAbsFp fs fp = fsRoot fs FP.normalise fp + +toNfp :: FileSystem -> FilePath -> NormalizedFilePath +toNfp fs fp = + toNormalizedFilePath $ toAbsFp fs fp + +-- ---------------------------------------------------------------------------- +-- Builders +-- ---------------------------------------------------------------------------- + +-- | Create a file in the test project with some content. +-- +-- Only the filename will be used, and any directory components are *not* +-- reflected in the test project. +file :: FilePath -> Content -> FileTree +file fp cts = File fp cts + +-- | Copy a filepath into a test project. The name of the file is also used +-- in the test project. +-- +-- The filepath is always resolved to the root of the test data dir. +copy :: FilePath -> FileTree +copy fp = File fp (Ref fp) + +directory :: FilePath -> [FileTree] -> FileTree +directory name nodes = Directory name nodes + +-- | Write the given test directly into a file. +text :: T.Text -> Content +text = Inline + +-- | Read the contents of the given file +-- The filepath is always resolved to the root of the test data dir. +ref :: FilePath -> Content +ref = Ref + +-- ---------------------------------------------------------------------------- +-- Cradle Helpers +-- ---------------------------------------------------------------------------- + +-- | Set up a simple direct cradle. +-- +-- All arguments are added to the direct cradle file. +-- Arguments will not be escaped. +directCradle :: [T.Text] -> FileTree +directCradle args = + file "hie.yaml" + ( Inline $ T.unlines $ + [ "cradle:" + , " direct:" + , " arguments:" + ] <> + [ " - " <> arg | arg <- args] + ) + +-- | Set up a simple cabal cradle. +-- +-- Prefer simple cabal cradle, over custom multi cabal cradles if possible. +simpleCabalCradle :: FileTree +simpleCabalCradle = + file "hie.yaml" + (Inline $ T.unlines + [ "cradle:" + , " cabal:" + ] + ) + + +-- ---------------------------------------------------------------------------- +-- Project setup builders +-- ---------------------------------------------------------------------------- + +-- | Set up a test project with a single haskell file. +directProject :: FilePath -> [FileTree] +directProject fp = + [ directCradle [T.pack fp] + , file fp (Ref fp) + ] + +-- | Set up a test project with multiple haskell files. +-- +directProjectMulti :: [FilePath] -> [FileTree] +directProjectMulti fps = + [ directCradle $ fmap T.pack fps + ] <> fmap copy fps + +-- | Set up a simple cabal cradle project and copy all the given filepaths +-- into the test directory. +simpleCabalProject :: [FilePath] -> [FileTree] +simpleCabalProject fps = + [ simpleCabalCradle + ] <> fmap copy fps + +-- | Set up a simple cabal cradle project. +simpleCabalProject' :: [FileTree] -> [FileTree] +simpleCabalProject' fps = + [ simpleCabalCradle + ] <> fps