hls-test-utils 2.2.0.0 → 2.3.0.0

raw patch · 3 files changed

+447/−8 lines, 3 filesdep ~ghcidedep ~hls-plugin-apiPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghcide, hls-plugin-api

API changes (from Hackage documentation)

Files

• hls-test-utils.cabal +4/−3
• src/Test/Hls.hs +213/−5
• src/Test/Hls/FileSystem.hs +230/−0

@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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

@@ -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 <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 @@     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 

@@ -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