From 4f333872f02cbefda59034c88c91861db4f954c7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 6 Apr 2024 00:13:52 +0800 Subject: [PATCH] do ReferenceTests --- ghcide/ghcide.cabal | 1 - ghcide/test/data/hover/Bar.hs | 4 - ghcide/test/data/hover/Foo.hs | 6 - ghcide/test/data/hover/GotoHover.hs | 70 -------- ghcide/test/data/hover/RecordDotSyntax.hs | 18 --- ghcide/test/data/hover/hie.yaml | 1 - ghcide/test/exe/Main.hs | 2 - haskell-language-server.cabal | 3 + hls-test-utils/src/Test/Hls.hs | 152 ++++++++++-------- hls-test-utils/src/Test/Hls/FileSystem.hs | 26 ++- plugins/hls-core-plugin/test/CoreTest.hs | 2 + .../test/exe/FindDefinitionAndHoverTests.hs | 32 ++-- .../test/exe/ReferenceTests.hs | 58 ++++--- plugins/hls-core-plugin/test/exe/Util.hs | 32 +++- .../test/testdata/references/Main.hs | 14 ++ .../test/testdata/references/OtherModule.hs | 9 ++ .../testdata/references/OtherOtherModule.hs | 3 + .../test/testdata/references/References.hs | 25 +++ .../test/testdata/references/hie.yaml | 1 + 19 files changed, 230 insertions(+), 229 deletions(-) delete mode 100644 ghcide/test/data/hover/Bar.hs delete mode 100644 ghcide/test/data/hover/Foo.hs delete mode 100644 ghcide/test/data/hover/GotoHover.hs delete mode 100644 ghcide/test/data/hover/RecordDotSyntax.hs delete mode 100644 ghcide/test/data/hover/hie.yaml rename {ghcide => plugins/hls-core-plugin}/test/exe/ReferenceTests.hs (82%) create mode 100644 plugins/hls-core-plugin/test/testdata/references/Main.hs create mode 100644 plugins/hls-core-plugin/test/testdata/references/OtherModule.hs create mode 100644 plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs create mode 100644 plugins/hls-core-plugin/test/testdata/references/References.hs create mode 100644 plugins/hls-core-plugin/test/testdata/references/hie.yaml diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 28299c85970..4efa0cf67ae 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -388,7 +388,6 @@ test-suite ghcide-tests PositionMappingTests PreprocessorTests Progress - ReferenceTests RootUriTests SafeTests SymlinkTests diff --git a/ghcide/test/data/hover/Bar.hs b/ghcide/test/data/hover/Bar.hs deleted file mode 100644 index f9fde2a7ccb..00000000000 --- a/ghcide/test/data/hover/Bar.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Bar (Bar(..)) where - --- | Bar Haddock -data Bar = Bar diff --git a/ghcide/test/data/hover/Foo.hs b/ghcide/test/data/hover/Foo.hs deleted file mode 100644 index 489a6ccd6b2..00000000000 --- a/ghcide/test/data/hover/Foo.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Foo (Bar, foo) where - -import Bar - --- | foo Haddock -foo = Bar diff --git a/ghcide/test/data/hover/GotoHover.hs b/ghcide/test/data/hover/GotoHover.hs deleted file mode 100644 index 6ff3eeffedd..00000000000 --- a/ghcide/test/data/hover/GotoHover.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -{- HLINT ignore -} -module GotoHover ( module GotoHover) where -import Data.Text (Text, pack) -import Foo (Bar, foo) - - -data TypeConstructor = DataConstructor - { fff :: Text - , ggg :: Int } -aaa :: TypeConstructor -aaa = DataConstructor - { fff = "dfgy" - , ggg = 832 - } -bbb :: TypeConstructor -bbb = DataConstructor "mjgp" 2994 -ccc :: (Text, Int) -ccc = (fff bbb, ggg aaa) -ddd :: Num a => a -> a -> a -ddd vv ww = vv +! ww -a +! b = a - b -hhh (Just a) (><) = a >< a -iii a b = a `b` a -jjj s = pack $ s <> s -class MyClass a where - method :: a -> Int -instance MyClass Int where - method = succ -kkk :: MyClass a => Int -> a -> Int -kkk n c = n + method c - -doBind :: Maybe () -doBind = do unwrapped <- Just () - return unwrapped - -listCompBind :: [Char] -listCompBind = [ succ c | c <- "ptfx" ] - -multipleClause :: Bool -> Char -multipleClause True = 't' -multipleClause False = 'f' - --- | Recognizable docs: kpqz -documented :: Monad m => Either Int (m a) -documented = Left 7518 - -listOfInt = [ 8391 :: Int, 6268 ] - -outer :: Bool -outer = undefined inner where - - inner :: Char - inner = undefined - -imported :: Bar -imported = foo - -aa2 :: Bool -aa2 = $(id [| True |]) - -hole :: Int -hole = _ - -hole2 :: a -> Maybe a -hole2 = _ - --- A comment above a type defnition with a deriving clause -data Example = Example - deriving (Eq) diff --git a/ghcide/test/data/hover/RecordDotSyntax.hs b/ghcide/test/data/hover/RecordDotSyntax.hs deleted file mode 100644 index 3680d08a3ce..00000000000 --- a/ghcide/test/data/hover/RecordDotSyntax.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} - -module RecordDotSyntax ( module RecordDotSyntax) where - -import qualified Data.Maybe as M - -data MyRecord = MyRecord - { a :: String - , b :: Integer - , c :: MyChild - } deriving (Eq, Show) - -newtype MyChild = MyChild - { z :: String - } deriving (Eq, Show) - -x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } -y = x.a ++ show x.b ++ x.c.z diff --git a/ghcide/test/data/hover/hie.yaml b/ghcide/test/data/hover/hie.yaml deleted file mode 100644 index e2b3e97c5d2..00000000000 --- a/ghcide/test/data/hover/hie.yaml +++ /dev/null @@ -1 +0,0 @@ -cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 82be67998ae..b64213e1df1 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -67,7 +67,6 @@ import BootTests import RootUriTests import AsyncTests import ClientSettingsTests -import ReferenceTests import GarbageCollectionTests import ExceptionTests @@ -108,7 +107,6 @@ main = do , RootUriTests.tests , AsyncTests.tests , ClientSettingsTests.tests - , ReferenceTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests , ExceptionTests.tests recorder logger diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c389d14cb8d..20a0e62ddb7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1665,6 +1665,7 @@ test-suite hls-core-plugin-tests OutlineTests CompletionTests HighlightTests + ReferenceTests build-depends: @@ -1690,6 +1691,8 @@ test-suite hls-core-plugin-tests , extra , hls-test-utils , regex-tdfa + , directory + , tasty-expected-failure ----------------------------- diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 38c4b9b7aed..02e4b0819e6 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -29,6 +29,7 @@ module Test.Hls -- * Running HLS for integration tests runSessionWithServer, runSessionWithServerAndCaps, + TestRunner, runSessionWithServerInTmpDir, runSessionWithServerAndCapsInTmpDir, runSessionWithServer', @@ -368,6 +369,86 @@ initialiseTestRecorder envVars = do -- ------------------------------------------------------------ -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ +class TestRunner cont res where + runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> cont -> IO res + runSessionWithServerInTmpDir config plugin tree act = do + recorder <- pluginTestRecorder + runSessionWithServerInTmpDir' (plugin recorder) config def fullCaps tree act + runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> cont -> IO res + 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 -> + cont -> IO res + runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do + testRoot <- setupTestEnvironment + (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 action = case cleanupTempDir of + Just val | val /= "0" -> do + (tempDir, _) <- newTempDirWithin testRoot + a <- action tempDir + logWith recorder Debug LogNoCleanup + pure a + + _ -> do + (tempDir, cleanup) <- newTempDirWithin testRoot + a <- action tempDir `finally` cleanup + 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 (contToSessionRes fs act) + contToSessionRes :: FileSystem -> cont -> Session res + + +instance TestRunner (Session a) a where + contToSessionRes _ act = act + + +instance TestRunner (FileSystem -> Session a) a where + contToSessionRes fs act = act fs + + runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer config plugin fp act = do @@ -379,77 +460,6 @@ 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 - testRoot <- setupTestEnvironment - (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 action = case cleanupTempDir of - Just val - | val /= "0" -> do - (tempDir, _) <- newTempDirWithin testRoot - a <- action tempDir - logWith recorder Debug LogNoCleanup - pure a - - _ -> do - (tempDir, cleanup) <- newTempDirWithin testRoot - a <- action tempDir `finally` cleanup - 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 -- | Setup the test environment for isolated tests. -- diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index b6742c4b838..1f6541e35eb 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -20,6 +20,7 @@ module Test.Hls.FileSystem , directory , text , ref + , copyDir -- * Cradle helpers , directCradle , simpleCabalCradle @@ -66,6 +67,7 @@ data VirtualFileTree = data FileTree = File FilePath Content | Directory FilePath [FileTree] + | CopiedDirectory FilePath deriving (Show, Eq, Ord) data Content @@ -99,12 +101,15 @@ materialise rootDir' fileTree testDataDir' = do 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 + persist root (File name cts) = case cts of + Inline txt -> T.writeFile (root name) txt + Ref path -> copyFile (testDataDir FP.normalise path) (root takeFileName name) + persist root (Directory name nodes) = do + createDirectory (root name) + mapM_ (persist (root name)) nodes + persist root (CopiedDirectory name) = do + nodes <- copyDir' testDataDir' name + mapM_ (persist root) nodes traverse_ (persist rootDir) fileTree pure $ FileSystem rootDir fileTree testDataDir @@ -154,6 +159,15 @@ file fp cts = File fp cts copy :: FilePath -> FileTree copy fp = File fp (Ref fp) +copyDir :: FilePath -> FileTree +copyDir dir = CopiedDirectory dir + +-- | Copy a directory into a test project. +copyDir' :: FilePath -> FilePath -> IO [FileTree] +copyDir' root dir = do + files <- listDirectory (root dir) + traverse (\f -> pure $ copy (dir f)) files + directory :: FilePath -> [FileTree] -> FileTree directory name nodes = Directory name nodes diff --git a/plugins/hls-core-plugin/test/CoreTest.hs b/plugins/hls-core-plugin/test/CoreTest.hs index fccfaa8028d..453d2e5e7cd 100644 --- a/plugins/hls-core-plugin/test/CoreTest.hs +++ b/plugins/hls-core-plugin/test/CoreTest.hs @@ -7,6 +7,7 @@ import qualified FindDefinitionAndHoverTests import qualified HighlightTests import qualified InitializeResponseTests import qualified OutlineTests +import qualified ReferenceTests import Test.Hls (defaultTestRunner, testGroup) @@ -21,4 +22,5 @@ main = , CompletionTests.tests , HighlightTests.tests , FindDefinitionAndHoverTests.tests + , ReferenceTests.tests ] diff --git a/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs b/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs index b333ded190d..498cb4ab339 100644 --- a/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs +++ b/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs @@ -9,7 +9,6 @@ import Data.Foldable import Data.Maybe import qualified Data.Text as T import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) -import Development.IDE.GHC.Util -- import Development.IDE.Test (expectDiagnostics, -- standardizeQuotes) import qualified Language.LSP.Protocol.Lens as L @@ -19,45 +18,34 @@ import qualified Language.LSP.Protocol.Lens as L -- SemanticTokensEdit (..), -- mkRange) -import Language.LSP.Protocol.Types (DiagnosticSeverity (..), - Hover (..), MarkupContent (..), +import Language.LSP.Protocol.Types (Hover (..), MarkupContent (..), Position (..), Range, TextDocumentIdentifier, mkRange, type (|?) (..)) import Language.LSP.Test -import System.FilePath import System.Info.Extra (isWindows) import Control.Lens ((^.)) import Test.Tasty import Test.Tasty.HUnit -- import TestUtils -import Test.Hls (knownBrokenForGhcVersions, - waitForProgressDone, +import Test.Hls (waitForProgressDone, waitForTypecheck) -import Test.Hls.FileSystem (copy, directProjectMulti) +import Test.Hls.FileSystem (copyDir) import Text.Regex.TDFA ((=~)) import Util tests :: TestTree tests = let tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree - tst (get, check) pos sfp targetRange title = testSessionWithCorePlugin title (mkFs $ fmap (copy . ("hover" )) ["Bar.hs", "Foo.hs", "GotoHover.hs", "hie.yaml", "RecordDotSyntax.hs"]) $ do - -- Dirty the cache to check that definitions work even in the presence of iface files - -- let fooPath = "Foo.hs" - -- fooSource <- liftIO $ readFileUtf8 fooPath - -- fooDoc <- createDoc fooPath "haskell" fooSource - -- _ <- getHover fooDoc $ Position 4 3 - -- closeDoc fooDoc - - doc <- openDoc sfp "haskell" - waitForProgressDone - x <- waitForTypecheck doc - - - found <- get doc pos - check found targetRange + tst (get, check) pos sfp targetRange title = + testSessionWithCorePlugin title (mkFs [copyDir "hover"]) $ do + doc <- openDoc sfp "haskell" + waitForProgressDone + x <- waitForTypecheck doc + found <- get doc pos + check found targetRange diff --git a/ghcide/test/exe/ReferenceTests.hs b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs similarity index 82% rename from ghcide/test/exe/ReferenceTests.hs rename to plugins/hls-core-plugin/test/exe/ReferenceTests.hs index 5abb18bfe80..031ecdda91a 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module ReferenceTests (tests) where @@ -7,8 +8,6 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.List.Extra import qualified Data.Set as Set -import Development.IDE.Test (configureCheckProject, - referenceReady) import Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types hiding @@ -20,12 +19,18 @@ import Language.LSP.Test import System.Directory import System.FilePath -- import Test.QuickCheck.Instances () +import Control.Concurrent (threadDelay) import Control.Lens ((^.)) import Data.Tuple.Extra +import Test.Hls (waitForAllProgressDone, + waitForBuildQueue, + waitForProgressDone) +import Test.Hls.FileSystem (copy, copyDir, + directProjectMulti, toAbsFp) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit -import TestUtils +import Util tests :: TestTree @@ -156,36 +161,43 @@ getReferences' (file, l, c) includeDeclaration = do where toBool YesIncludeDeclaration = True toBool NoExcludeDeclaration = False -referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree -referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do - -- needed to build whole project indexing - configureCheckProject True - let docs = map (dir ) $ delete thisDoc $ nubOrd docs' - -- Initial Index - docid <- openDoc thisDoc "haskell" - let - loop :: [FilePath] -> Session () - loop [] = pure () - loop docs = do - doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) - loop (delete doc docs) - loop docs - f dir - closeDoc docid +referenceTestSession :: HasCallStack => String -> FilePath -> [FilePath] -> Session () -> TestTree +referenceTestSession name thisDoc docs' f = do + testSessionWithCorePlugin name (mkFs [copyDir "references"]) $ \fs -> do + -- needed to build whole project indexing + configureCheckProject True + + -- Initial Index + docid <- openDoc thisDoc "haskell" + + -- need to get the real paths through links + docs <- mapM (liftIO . canonicalizePath . toAbsFp fs) $ delete thisDoc $ nubOrd docs' + liftIO $ putStrLn $ "docs:" <> show docs + let + -- todo wait for docs + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f + closeDoc docid -- | Given a location, lookup the symbol and all references to it. Make sure -- they are the ones we expect. -referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ \dir -> do + referenceTestSession name (fst3 loc) docs $ do actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + liftIO $ actual `expectSameLocations` expected where docs = map fst3 expected type SymbolLocation = (FilePath, UInt, UInt) -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +expectSameLocations :: (HasCallStack) => [Location] -> [SymbolLocation] -> Assertion expectSameLocations actual expected = do let actual' = Set.map (\location -> (location ^. L.uri diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs index 38b40813b2a..b7224b19423 100644 --- a/plugins/hls-core-plugin/test/exe/Util.hs +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -7,15 +7,20 @@ module Util where +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Aeson as A import Data.Default (Default (..)) import Data.Foldable (traverse_) import Data.Maybe (fromJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text as Text +import Debug.Trace (traceShow) import Development.IDE (GhcVersion, ghcVersion) +import GHC.TypeLits (symbolVal) import qualified Ide.Plugin.Core as Core +import Ide.Types (Config (..)) import Language.LSP.Protocol.Types (Definition (..), DefinitionLink (..), Location (..), LocationLink (..), @@ -28,12 +33,16 @@ import Language.LSP.Test (Session) import System.Directory.Extra (canonicalizePath) import System.FilePath (()) import System.Info.Extra -import Test.Hls (PluginTestDescriptor, TestName, - TestTree, assertBool, - expectFailBecause, +import Test.Hls (FromServerMessage' (..), + PluginTestDescriptor, + SMethod (..), TCustomMessage (..), + TNotificationMessage (..), + TestName, TestRunner, TestTree, + assertBool, expectFailBecause, ignoreTestBecause, mkPluginTestDescriptor, runSessionWithServerInTmpDir, + satisfyMaybe, setConfigSection, testCase) import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (copy, file, text) @@ -44,10 +53,10 @@ import Test.Tasty.HUnit (Assertion, assertFailure, (@=?), pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') -testSessionWithCorePlugin :: TestName -> FS.VirtualFileTree -> Session () -> TestTree +testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree testSessionWithCorePlugin caseName vfs = testCase caseName . runSessionWithCorePlugin vfs -runSessionWithCorePlugin :: FS.VirtualFileTree -> Session a -> IO a +runSessionWithCorePlugin :: (TestRunner cont res) => FS.VirtualFileTree -> cont -> IO res runSessionWithCorePlugin = runSessionWithServerInTmpDir def corePlugin runSessionWithCorePluginEmpty :: [Text] -> Session a -> IO a @@ -162,3 +171,16 @@ standardizeQuotes msg = let repl c = c in T.map repl msg + +configureCheckProject :: Bool -> Session () +configureCheckProject overrideCheckProject = setConfigSection "haskell" (A.toJSON $ def{checkProject = overrideCheckProject}) + + +referenceReady :: (FilePath -> Bool) -> Session FilePath +referenceReady pred = satisfyMaybe $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) + | A.Success fp <- A.fromJSON _params + , pred fp + , symbolVal p == "ghcide/reference/ready" + -> traceShow ("referenceReady", fp) $ Just fp + _ -> Nothing diff --git a/plugins/hls-core-plugin/test/testdata/references/Main.hs b/plugins/hls-core-plugin/test/testdata/references/Main.hs new file mode 100644 index 00000000000..4a976f3fd01 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import References + +main :: IO () +main = return () + + + +a = 2 :: Int +b = a + 1 + +acc :: Account +acc = Savings diff --git a/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs b/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs new file mode 100644 index 00000000000..4840f46d8ef --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs @@ -0,0 +1,9 @@ +module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where + +import OtherOtherModule + +symbolDefinedInOtherModule = 1 + +symbolLocalToOtherModule = 2 + +someFxn x = x + symbolLocalToOtherModule diff --git a/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs b/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs new file mode 100644 index 00000000000..d567b8cb974 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs @@ -0,0 +1,3 @@ +module OtherOtherModule where + +symbolDefinedInOtherOtherModule = "asdf" diff --git a/plugins/hls-core-plugin/test/testdata/references/References.hs b/plugins/hls-core-plugin/test/testdata/references/References.hs new file mode 100644 index 00000000000..ac76b4de406 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/References.hs @@ -0,0 +1,25 @@ +module References where + +import OtherModule + +foo = bar + +bar = let x = bar 42 in const "hello" + +baz = do + x <- bar 23 + return $ bar 14 + +data Account = + Checking + | Savings + +bobsAccount = Checking + +bobHasChecking = case bobsAccount of + Checking -> True + Savings -> False + +x = symbolDefinedInOtherModule + +y = symbolDefinedInOtherOtherModule diff --git a/plugins/hls-core-plugin/test/testdata/references/hie.yaml b/plugins/hls-core-plugin/test/testdata/references/hie.yaml new file mode 100644 index 00000000000..db42bad0c0b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}}