diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index 279bdfb2c9..756df5e158 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/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: diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 5d7ab2e8ce..0bbdbc0b72 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/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 +-- @ +-- +-- 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 diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs new file mode 100644 index 0000000000..b6742c4b83 --- /dev/null +++ b/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 diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 29d7ffa279..af51fdd04c 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 905ed97673..795d41bb6d 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -20,8 +20,8 @@ extra-source-files: LICENSE README.md test/cabal.project - test/info-util/*.cabal - test/info-util/*.hs + test/testdata/info-util/*.cabal + test/testdata/info-util/*.hs test/testdata/*.cabal test/testdata/*.hs test/testdata/*.lhs diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 1546f90160..998ee81a88 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -27,8 +27,9 @@ import Ide.Types (IdePlugins (IdePlugins)) import Language.LSP.Protocol.Lens (arguments, command, range, title) import Language.LSP.Protocol.Message hiding (error) -import System.FilePath (()) +import System.FilePath ((<.>), ()) import Test.Hls +import qualified Test.Hls.FileSystem as FS main :: IO () main = defaultTestRunner tests @@ -40,27 +41,27 @@ tests :: TestTree tests = testGroup "eval" [ testCase "Produces Evaluate code lenses" $ - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] , testCase "Produces Refresh code lenses" $ - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] , testCase "Code lenses have ranges" $ - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Multi-line expressions have a multi-line range" $ do - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T3.hs") $ do doc <- openDoc "T3.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] , testCase "Executed expressions range covers only the expression" $ do - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] @@ -122,15 +123,15 @@ tests = ] , goldenWithEval ":kind! treats a multilined result properly" "T24" "hs" , goldenWithEval ":kind treats a multilined result properly" "T25" "hs" - , goldenWithEval "local imports" "T26" "hs" + , goldenWithEvalAndFs "local imports" (FS.directProjectMulti ["T26.hs", "Util.hs"]) "T26" "hs" , goldenWithEval "Preserves one empty comment line after prompt" "T27" "hs" , goldenWithEval "Multi line comments" "TMulti" "hs" , goldenWithEval "Multi line comments, with the last test line ends without newline" "TEndingMulti" "hs" , goldenWithEval "Evaluate expressions in Plain comments in both single line and multi line format" "TPlainComment" "hs" , goldenWithEval "Evaluate expressions in Haddock comments in both single line and multi line format" "THaddock" "hs" , goldenWithEval "Compare results (for Haddock tests only)" "TCompare" "hs" - , goldenWithEval "Local Modules imports are accessible in a test" "TLocalImport" "hs" - , goldenWithEval "Transitive local dependency" "TTransitive" "hs" + , goldenWithEvalAndFs "Local Modules imports are accessible in a test" (FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) "TLocalImport" "hs" + , goldenWithEvalAndFs "Transitive local dependency" (FS.directProjectMulti ["TTransitive.hs", "TLocalImport.hs", "Util.hs"]) "TTransitive" "hs" -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs" , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs" , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") @@ -142,8 +143,8 @@ tests = else "-- id :: forall {a}. a -> a") , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs" , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs" - , goldenWithEval "Property checking" "TProperty" "hs" - , goldenWithEval' "Property checking with exception" "TPropertyError" "hs" ( + , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs" + , goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" ( if ghcVersion >= GHC96 then "ghc96.expected" else if ghcVersion >= GHC94 && hostOS == Windows then @@ -212,7 +213,7 @@ tests = not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" ] , testCase "Interfaces are reused after Eval" $ do - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) $ do doc <- openDoc "TLocalImport.hs" "haskell" waitForTypecheck doc lenses <- getCodeLenses doc @@ -231,13 +232,22 @@ tests = goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree goldenWithEval title path ext = - goldenWithHaskellDoc def evalPlugin title testDataDir path "expected" ext executeLensesBackwards + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path "expected" ext executeLensesBackwards + +goldenWithEvalAndFs :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> TestTree +goldenWithEvalAndFs title tree path ext = + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path "expected" ext executeLensesBackwards -- | Similar function as 'goldenWithEval' with an alternate reference file -- naming. Useful when reference file may change because of GHC version. goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree goldenWithEval' title path ext expected = - goldenWithHaskellDoc def evalPlugin title testDataDir path expected ext executeLensesBackwards + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path expected ext executeLensesBackwards + +goldenWithEvalAndFs' :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> FilePath -> TestTree +goldenWithEvalAndFs' title tree path ext expected = + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path expected ext executeLensesBackwards + -- | Execute lenses backwards, to avoid affecting their position in the source file executeLensesBackwards :: TextDocumentIdentifier -> Session () @@ -264,7 +274,7 @@ executeCmd cmd = do pure () evalLenses :: FilePath -> IO [CodeLens] -evalLenses path = runSessionWithServer def evalPlugin testDataDir $ do +evalLenses path = runSessionWithServerInTmpDir def evalPlugin (mkFs cabalProjectFS) $ do doc <- openDoc path "haskell" executeLensesBackwards doc getCodeLenses doc @@ -298,10 +308,11 @@ exceptionConfig exCfg = changeConfig ["exception" .= exCfg] goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree goldenWithEvalConfig' title path ext expected cfg = - goldenWithHaskellDoc cfg evalPlugin title testDataDir path expected ext executeLensesBackwards + goldenWithHaskellDocInTmpDir cfg evalPlugin title (mkFs $ FS.directProject $ path <.> ext) path expected ext $ \doc -> do + executeLensesBackwards doc evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO () -evalInFile fp e expected = runSessionWithServer def evalPlugin testDataDir $ do +evalInFile fp e expected = runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject fp) $ do doc <- openDoc fp "haskell" origin <- documentContents doc let withEval = origin <> e @@ -309,3 +320,30 @@ evalInFile fp e expected = runSessionWithServer def evalPlugin testDataDir $ do executeLensesBackwards doc result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc liftIO $ result @?= Just (T.strip expected) + +-- ---------------------------------------------------------------------------- +-- File system definitions +-- Used for declaring a test file tree +-- ---------------------------------------------------------------------------- + +mkFs :: [FS.FileTree] -> FS.VirtualFileTree +mkFs = FS.mkVirtualFileTree testDataDir + +cabalProjectFS :: [FS.FileTree] +cabalProjectFS = FS.simpleCabalProject' + [ FS.copy "test.cabal" + , FS.file "cabal.project" + (FS.text "packages: ./info-util .\n" + ) + , FS.copy "TProperty.hs" + , FS.copy "TPropertyError.hs" + , FS.copy "TI_Info.hs" + , FS.copy "TInfo.hs" + , FS.copy "TInfoBang.hs" + , FS.copy "TInfoBangMany.hs" + , FS.copy "TInfoMany.hs" + , FS.directory "info-util" + [ FS.copy "info-util/info-util.cabal" + , FS.copy "info-util/InfoUtil.hs" + ] + ] diff --git a/plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs b/plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs new file mode 100644 index 0000000000..63d0ed8a07 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T11.ghc94.expected.hs @@ -0,0 +1,4 @@ +module T11 where + +-- >>> :kind! A +-- Not in scope: type constructor or class `A' diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs index 2ee96ac131..8bf91c7118 100644 --- a/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs @@ -1,6 +1,8 @@ -- Support for language options {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + module TFlags where -- Language options set in the module source (ScopedTypeVariables) diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs index 2cc5c96e66..2c8e0ef92a 100644 --- a/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs @@ -1,6 +1,8 @@ -- Support for language options {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + module TFlags where -- Language options set in the module source (ScopedTypeVariables) diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.hs index 7218f3d7bf..075a04dc86 100644 --- a/plugins/hls-eval-plugin/test/testdata/TFlags.hs +++ b/plugins/hls-eval-plugin/test/testdata/TFlags.hs @@ -1,6 +1,8 @@ -- Support for language options {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + module TFlags where -- Language options set in the module source (ScopedTypeVariables) diff --git a/plugins/hls-eval-plugin/test/info-util/InfoUtil.hs b/plugins/hls-eval-plugin/test/testdata/info-util/InfoUtil.hs similarity index 100% rename from plugins/hls-eval-plugin/test/info-util/InfoUtil.hs rename to plugins/hls-eval-plugin/test/testdata/info-util/InfoUtil.hs diff --git a/plugins/hls-eval-plugin/test/info-util/info-util.cabal b/plugins/hls-eval-plugin/test/testdata/info-util/info-util.cabal similarity index 100% rename from plugins/hls-eval-plugin/test/info-util/info-util.cabal rename to plugins/hls-eval-plugin/test/testdata/info-util/info-util.cabal diff --git a/plugins/hls-eval-plugin/test/testdata/test.cabal b/plugins/hls-eval-plugin/test/testdata/test.cabal index 08856be2e2..00ed0aaf18 100644 --- a/plugins/hls-eval-plugin/test/testdata/test.cabal +++ b/plugins/hls-eval-plugin/test/testdata/test.cabal @@ -12,51 +12,8 @@ cabal-version: >=1.10 library exposed-modules: - T1 - T2 - T3 - T4 - T5 - T6 - T7 - T8 - T9 - T10 - T11 - T12 - T13 - T14 - T15 - T16 - T17 - T18 - T19 - T20 - T21 - T22 - T23 - T24 - T25 - T26 - T27 - TEndingMulti - TMulti - TPlainComment - THaddock - TCompare - TLocalImport - TLocalImportInTest - TFlags - TLanguageOptionsTupleSections - TIO TProperty - TSameDefaultLanguageExtensionsAsGhci - TPrelude - TCPP - TLHS - TSetup - Util - TNested + TPropertyError TInfo TInfoMany TInfoBang