Introduce declarative test project definition

Test data is currently often in some 'testdata' directory in 'test/'.
It can easily get quite messy with many files.
Especially since 'lsp-test' should load only exactly what is needed to
speed up tests and avoid test flakiness.

A subdirectory per test file is quite overkill and increases the
required boilerplate to write tests.

Thus, we introduce a declarative test project specification that runs
lsp-test in a temporary directory. The first advantage is that we can load
only exactly what we need, and create more accurate projects.

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
 

hls-test-utils/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

plugins/hls-call-hierarchy-plugin/test/Main.hs

@@ -8,7 +8,7 @@ module Main (main) where
 
 import           Control.Lens               (set, (^.))
 import           Control.Monad.Extra
-import           Data.Aeson
+import qualified Data.Aeson                 as Aeson
 import           Data.Functor               ((<&>))
 import           Data.List                  (sort, tails)
 import qualified Data.Map                   as M
@@ -527,9 +527,9 @@ mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem na
     assertHierarchyItem selRange selRange'
     case xdata' of
       Nothing -> assertFailure ("In " ++ show c ++ ", got Nothing for data but wanted " ++ show xdata)
-      Just v -> case fromJSON v of
-        Success v -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v)
-        Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err)
+      Just v -> case Aeson.fromJSON v of
+        Aeson.Success v -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v)
+        Aeson.Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err)
   where
     tags = Nothing
     detail = Just "Main"