diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 565e6c9ceb..fa33ccefd8 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE PatternSynonyms #-} + module Config where + import Ide.Types (defaultPluginDescriptor) import System.FilePath (()) -import Test.Hls (PluginTestDescriptor, - mkPluginTestDescriptor) +import Test.Hls import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (FileSystem) testDataDir :: FilePath testDataDir = "ghcide" "test" "data" @@ -13,4 +16,20 @@ mkIdeTestFs = FS.mkVirtualFileTree testDataDir -- * A dummy plugin for testing ghcIde dummyPlugin :: PluginTestDescriptor () -dummyPlugin = mkPluginTestDescriptor (\_ pid ->defaultPluginDescriptor pid "dummyTestPlugin") "core" +dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dummyTestPlugin") "core" + +runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a +runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin + +runWithDummyPlugin' :: FS.VirtualFileTree -> (FileSystem -> Session a) -> IO a +runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin + +-- testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree +testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree +testWithDummyPlugin caseName vfs = testCase caseName . runWithDummyPlugin vfs + +testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FileSystem -> Session ()) -> TestTree +testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index ab34bdfd54..83c4657440 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -13,7 +13,8 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Test -import Config (dummyPlugin, mkIdeTestFs) +import Config (dummyPlugin, mkIdeTestFs, + runWithDummyPlugin) import Control.Lens ((^.)) import Development.IDE.Plugin.Test (blockCommandId) import Test.Hls @@ -84,7 +85,7 @@ tests = withResource acquire release tests where innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" acquire :: IO (TResponseMessage Method_Initialize) - acquire = runSessionWithServerInTmpDir def dummyPlugin (mkIdeTestFs []) initializeResponse + acquire = runWithDummyPlugin (mkIdeTestFs []) initializeResponse release :: TResponseMessage Method_Initialize -> IO () release = mempty diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs index 6459e1deca..640e13a907 100644 --- a/ghcide/test/exe/OutlineTests.hs +++ b/ghcide/test/exe/OutlineTests.hs @@ -1,189 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module OutlineTests (tests) where +import Config import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) import qualified Data.Text as T import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test +import Test.Hls.FileSystem (file, text) import Test.Tasty import Test.Tasty.HUnit -import TestUtils -tests :: TestTree -tests = testGroup - "outline" - [ testSessionWait "type class" $ do - let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol "A a" - (R 1 0 1 30) - [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] - ] - ] - , testSessionWait "type class instance " $ do - let source = T.unlines ["class A a where", "instance A () where"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) - ] - , testSessionWait "type family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] - , testSessionWait "type family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "type family A a" - , "type instance A () = ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) - , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) - ] - , testSessionWait "data family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] - , testSessionWait "data family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "data family A a" - , "data instance A () = A ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) - , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) - ] - , testSessionWait "constant" $ do - let source = T.unlines ["a = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] - , testSessionWait "pattern" $ do - let source = T.unlines ["Just foo = Just 21"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] - , testSessionWait "pattern with type signature" $ do - let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] - , testSessionWait "function" $ do - let source = T.unlines ["a _x = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] - , testSessionWait "type synonym" $ do - let source = T.unlines ["type A = Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] - , testSessionWait "datatype" $ do - let source = T.unlines ["data A = C"] - docId <- createDoc "A.hs" "haskell" source +testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text] -> [DocumentSymbol] -> TestTree +testSymbols testName path content expectedSymbols = + testCase testName $ runWithDummyPlugin (mkIdeTestFs [file path (text $ T.unlines content)]) $ do + docId <- openDoc path "haskell" symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolWithChildren "A" - SymbolKind_Struct - (R 0 0 0 10) - [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] - ] - , testSessionWait "record fields" $ do - let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) - [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) - , docSymbol "y" SymbolKind_Field (R 2 4 2 5) + liftIO $ symbols @?= Right expectedSymbols + +testSymbolsA :: (HasCallStack) => TestName -> [Text] -> [DocumentSymbol] -> TestTree +testSymbolsA testName content expectedSymbols = + testSymbols testName "A.hs" content expectedSymbols + +tests :: TestTree +tests = + testGroup + "outline" + [ testSymbolsA + "type class:" + ["module A where", "class A a where a :: a -> Bool"] + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol + "A a" + (R 1 0 1 30) + [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] ] - ] - ] - , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbolWithChildren "imports" - SymbolKind_Module - (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) - ] - ] - , testSessionWait "multiple import" $ do - let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbolWithChildren "imports" - SymbolKind_Module - (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) - , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) - ] - ] - , testSessionWait "foreign import" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign import ccall \"a\" a :: Int" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] - , testSessionWait "foreign export" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign export ccall odd :: Int -> Bool" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SymbolKind_File - Nothing - Nothing - (R 0 0 maxBound 0) - loc - (Just cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SymbolKind_Interface - Nothing - Nothing - loc - loc - (Just cc) + ], + testSymbolsA + "type class instance " + ["class A a where", "instance A () where"] + [ classSymbol "A a" (R 0 0 0 15) [], + docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) + ], + testSymbolsA "type family" ["{-# language TypeFamilies #-}", "type family A"] [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)], + testSymbolsA + "type family instance " + ["{-# language TypeFamilies #-}", "type family A a", "type instance A () = ()"] + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15), + docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) + ], + testSymbolsA "data family" ["{-# language TypeFamilies #-}", "data family A"] [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)], + testSymbolsA + "data family instance " + ["{-# language TypeFamilies #-}", "data family A a", "data instance A () = A ()"] + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11), + docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) + ], + testSymbolsA "constant" ["a = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 6)], + testSymbolsA "pattern" ["Just foo = Just 21"] [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)], + testSymbolsA "pattern with type signature" ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)], + testSymbolsA "function" ["a _x = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 9)], + testSymbolsA "type synonym" ["type A = Bool"] [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)], + testSymbolsA "datatype" ["data A = C"] [docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 0 10) [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)]], + testSymbolsA + "record fields" + ["data A = B {", " x :: Int", " , y :: Int}"] + [ docSymbolWithChildren + "A" + SymbolKind_Struct + (R 0 0 2 13) + [ docSymbolWithChildren' + "B" + SymbolKind_Constructor + (R 0 9 2 13) + (R 0 9 0 10) + [ docSymbol "x" SymbolKind_Field (R 1 2 1 3), + docSymbol "y" SymbolKind_Field (R 2 4 2 5) + ] + ] + ], + testSymbolsA + "import" + ["import Data.Maybe ()"] + [ docSymbolWithChildren + "imports" + SymbolKind_Module + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) + ] + ], + testSymbolsA + "multiple import" + ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + [ docSymbolWithChildren + "imports" + SymbolKind_Module + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20), + docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) + ] + ], + testSymbolsA + "foreign import" + [ "{-# language ForeignFunctionInterface #-}", + "foreign import ccall \"a\" a :: Int" + ] + [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)], + testSymbolsA + "foreign export" + [ "{-# language ForeignFunctionInterface #-}", + "foreign export ccall odd :: Int -> Bool" + ] + [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) + moduleSymbol name loc cc = + DocumentSymbol + name + Nothing + SymbolKind_File + Nothing + Nothing + (R 0 0 maxBound 0) + loc + (Just cc) + classSymbol name loc cc = + DocumentSymbol + name + (Just "class") + SymbolKind_Interface + Nothing + Nothing + loc + loc + (Just cc) diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 5abb18bfe8..3bafb0b20d 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + module ReferenceTests (tests) where @@ -7,8 +10,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 @@ -18,14 +19,22 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import System.Directory -import System.FilePath -- import Test.QuickCheck.Instances () +import Config import Control.Lens ((^.)) +import qualified Data.Aeson as A +import Data.Default (def) import Data.Tuple.Extra +import GHC.TypeLits (symbolVal) +import Ide.Types +import Test.Hls (FromServerMessage' (..), + SMethod (..), + TCustomMessage (..), + TNotificationMessage (..)) +import Test.Hls.FileSystem (copyDir, toAbsFp) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit -import TestUtils tests :: TestTree @@ -156,36 +165,44 @@ 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 :: String -> FilePath -> [FilePath] -> Session () -> TestTree +referenceTestSession name thisDoc docs' f = do + testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do + -- needed to build whole project indexing + configureCheckProject True + -- need to get the real paths through links + docs <- mapM (liftIO . canonicalizePath . toAbsFp fs) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + + 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 @@ -197,3 +214,16 @@ expectSameLocations actual expected = do fp <- canonicalizePath file return (filePathToUri fp, l, c)) actual' @?= expected' + + +-- todo find where to put this in hls +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" + -> Just fp + _ -> Nothing diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 993f08b818..d8aba65f54 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -33,6 +33,8 @@ module Test.Hls runSessionWithServerAndCapsInTmpDir, runSessionWithServer', runSessionWithServerInTmpDir', + -- continuation version that take a FileSystem + runSessionWithServerInTmpDirCont', -- * Helpful re-exports PluginDescriptor, IdeState, @@ -363,26 +365,36 @@ initialiseTestRecorder envVars = do -- ------------------------------------------------------------ -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ +runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a +runSessionWithServerInTmpDir config plugin tree act = runSessionWithServerInTmpDirCont' config plugin tree (const act) -runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a -runSessionWithServer config plugin fp act = do - recorder <- pluginTestRecorder - runSessionWithServer' (plugin recorder) config def fullCaps fp act +runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a +runSessionWithServerAndCapsInTmpDir config plugin caps tree act = runSessionWithServerAndCapsInTmpDirCont config plugin caps tree (const act) -runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a -runSessionWithServerAndCaps config plugin caps fp act = do - recorder <- pluginTestRecorder - runSessionWithServer' (plugin recorder) config def caps fp act +runSessionWithServerInTmpDirCont' :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> (FileSystem -> Session a) -> IO a +runSessionWithServerInTmpDirCont' config plugin tree act = do + recorder <- pluginTestRecorder + runSessionWithServerInTmpDirCont (plugin recorder) config def fullCaps tree 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 +runSessionWithServerAndCapsInTmpDirCont :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> (FileSystem -> Session a) -> IO a +runSessionWithServerAndCapsInTmpDirCont config plugin caps tree act = do + recorder <- pluginTestRecorder + runSessionWithServerInTmpDirCont (plugin recorder) config def caps 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 +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 = runSessionWithServerInTmpDirCont plugins conf sessConf caps tree (const act) -- | Host a server, and run a test session on it. -- @@ -405,46 +417,55 @@ runSessionWithServerAndCapsInTmpDir config plugin caps tree act = do -- 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 +runSessionWithServerInTmpDirCont :: + -- | 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 -> + (FileSystem -> Session a) -> IO a +runSessionWithServerInTmpDirCont 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 fs) + +runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a +runSessionWithServer config plugin fp act = do + recorder <- pluginTestRecorder + runSessionWithServer' (plugin recorder) config def fullCaps fp act + +runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a +runSessionWithServerAndCaps config plugin caps fp act = do + recorder <- pluginTestRecorder + runSessionWithServer' (plugin recorder) config def caps fp 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 b6742c4b83..221fb7c23b 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 @@ -37,6 +38,7 @@ import Development.IDE (NormalizedFilePath) import Language.LSP.Protocol.Types (toNormalizedFilePath) import System.Directory import System.FilePath as FP +import System.Process.Extra (readProcess) -- ---------------------------------------------------------------------------- -- Top Level definitions @@ -64,8 +66,9 @@ data VirtualFileTree = } deriving (Eq, Ord, Show) data FileTree - = File FilePath Content - | Directory FilePath [FileTree] + = File FilePath Content -- ^ Create a file with the given content. + | Directory FilePath [FileTree] -- ^ Create a directory with the given files. + | CopiedDirectory FilePath -- ^ Copy a directory from the test data dir. deriving (Show, Eq, Ord) data Content @@ -99,12 +102,22 @@ 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 + copyDir' root name + + copyDir' :: FilePath -> FilePath -> IO () + copyDir' root dir = do + files <- fmap FP.normalise . lines <$> withCurrentDirectory (testDataDir dir) (readProcess "git" ["ls-files", "--cached", "--modified", "--others"] "") + mapM_ (createDirectoryIfMissing True . ((root ) . takeDirectory)) files + mapM_ (\f -> putStrLn $ (testDataDir dir f) <> ":" <> (root f) ) files + mapM_ (\f -> copyFile (testDataDir dir f) (root f)) files + return () traverse_ (persist rootDir) fileTree pure $ FileSystem rootDir fileTree testDataDir @@ -154,6 +167,11 @@ file fp cts = File fp cts copy :: FilePath -> FileTree copy fp = File fp (Ref fp) +-- | Copy a directory into a test project. +-- The filepath is always resolved to the root of the test data dir. +copyDir :: FilePath -> FileTree +copyDir dir = CopiedDirectory dir + directory :: FilePath -> [FileTree] -> FileTree directory name nodes = Directory name nodes diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index e8a21396ee..f0e7d2f6f8 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -9,15 +9,14 @@ import qualified Data.Aeson.KeyMap as KV import Data.Default import Data.Functor (void) import Data.Map.Strict as Map hiding (map) +import Data.Row ((.==)) +import Data.Row.Records ((.+)) import Data.String (fromString) import Data.Text hiding (length, map, unlines) import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (Pretty) - -import Data.Row ((.==)) -import Data.Row.Records ((.+)) import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) @@ -72,14 +71,16 @@ semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor } } -goldenWithHaskellAndCapsOutPut :: Pretty b => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree +goldenWithHaskellAndCapsOutPut :: (Pretty b) => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree goldenWithHaskellAndCapsOutPut config plugin title tree path desc act = goldenGitDiff title (FS.vftOriginalRoot tree path <.> desc) $ - runSessionWithServerInTmpDir config plugin tree $ - fromString <$> do - doc <- openDoc (path <.> "hs") "haskell" - void waitForBuildQueue - act doc + fromString + <$> ( runSessionWithServerInTmpDir config plugin tree $ + do + doc <- openDoc (path <.> "hs") "haskell" + void waitForBuildQueue + act doc + ) goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree goldenWithSemanticTokensWithDefaultConfig title path = @@ -92,9 +93,9 @@ goldenWithSemanticTokensWithDefaultConfig title path = "expected" (docSemanticTokensString def) -docSemanticTokensString :: SemanticTokensConfig-> TextDocumentIdentifier -> Session String +docSemanticTokensString :: SemanticTokensConfig -> TextDocumentIdentifier -> Session String docSemanticTokensString cf doc = do - xs <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc + xs <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc return $ unlines . map show $ xs docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes] @@ -107,7 +108,6 @@ docLspSemanticTokensString doc = do either (error . show) pure $ recoverLspSemanticTokens vfs tokens _noTokens -> error "No tokens found" - -- | Pass a param and return the response from `semanticTokensFull` -- getSemanticTokensFullDelta :: TextDocumentIdentifier -> Session _ getSemanticTokensFullDelta :: TextDocumentIdentifier -> Text -> Session (SemanticTokens |? (SemanticTokensDelta |? Null)) @@ -118,7 +118,6 @@ getSemanticTokensFullDelta doc lastResultId = do Right x -> return x _ -> error "No tokens found" - semanticTokensClassTests :: TestTree semanticTokensClassTests = testGroup @@ -139,39 +138,41 @@ semanticTokensValuePatternTests = ] mkSemanticConfig :: Object -> Config -mkSemanticConfig setting = def{plugins = Map.insert "SemanticTokens" conf (plugins def)} - where - conf = def{plcConfig = setting } - - +mkSemanticConfig setting = def {plugins = Map.insert "SemanticTokens" conf (plugins def)} + where + conf = def {plcConfig = setting} directFile :: FilePath -> Text -> [FS.FileTree] directFile fp content = - [ FS.directCradle [Text.pack fp] - , file fp (text content) + [ FS.directCradle [Text.pack fp], + file fp (text content) ] semanticTokensConfigTest :: TestTree -semanticTokensConfigTest = testGroup "semantic token config test" [ - testCase "function to variable" $ do - let content = Text.unlines ["module Hello where", "go _ = 1"] - let fs = mkFs $ directFile "Hello.hs" content - let funcVar = KV.fromList ["functionToken" .= var] - var :: String - var = "variable" - do - recorder <- pluginTestRecorder - Test.Hls.runSessionWithServerInTmpDir' (semanticTokensPlugin recorder) - (mkSemanticConfig funcVar) - def {ignoreConfigurationRequests = False} - fullCaps - fs $ do - -- modifySemantic funcVar - void waitForBuildQueue - doc <- openDoc "Hello.hs" "haskell" - void waitForBuildQueue - result1 <- docLspSemanticTokensString doc - liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" +semanticTokensConfigTest = + testGroup + "semantic token config test" + [ testCase "function to variable" $ do + let content = Text.unlines ["module Hello where", "go _ = 1"] + let fs = mkFs $ directFile "Hello.hs" content + let funcVar = KV.fromList ["functionToken" .= var] + var :: String + var = "variable" + do + recorder <- pluginTestRecorder + Test.Hls.runSessionWithServerInTmpDir' + (semanticTokensPlugin recorder) + (mkSemanticConfig funcVar) + def {ignoreConfigurationRequests = False} + fullCaps + fs + $ do + -- modifySemantic funcVar + void waitForBuildQueue + doc <- openDoc "Hello.hs" "haskell" + void waitForBuildQueue + result1 <- docLspSemanticTokensString doc + liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" ] semanticTokensFullDeltaTests :: TestTree @@ -185,11 +186,10 @@ semanticTokensFullDeltaTests = _ <- waitForAction "TypeCheck" doc1 _ <- Test.getSemanticTokens doc1 delta <- getSemanticTokensFullDelta doc1 "0" - liftIO $ delta @?= expectDelta - - , testCase "add tokens" $ do + liftIO $ delta @?= expectDelta, + testCase "add tokens" $ do let file1 = "TModuleA.hs" - let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2,0,3,8,0])])) + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2, 0, 3, 8, 0])])) -- r c l t m -- where r = row, c = column, l = length, t = token, m = modifier Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do @@ -197,16 +197,17 @@ semanticTokensFullDeltaTests = _ <- waitForAction "TypeCheck" doc1 _ <- Test.getSemanticTokens doc1 -- open the file and append a line to it - let change = TextDocumentContentChangeEvent - $ InL $ #range .== Range (Position 4 0) (Position 4 6) - .+ #rangeLength .== Nothing - .+ #text .== "foo = 1" + let change = + TextDocumentContentChangeEvent $ + InL $ + #range .== Range (Position 4 0) (Position 4 6) + .+ #rangeLength .== Nothing + .+ #text .== "foo = 1" changeDoc doc1 [change] _ <- waitForAction "TypeCheck" doc1 delta <- getSemanticTokensFullDelta doc1 "0" - liftIO $ delta @?= expectDelta - - , testCase "remove tokens" $ do + liftIO $ delta @?= expectDelta, + testCase "remove tokens" $ do let file1 = "TModuleA.hs" let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])])) -- delete all tokens @@ -215,10 +216,12 @@ semanticTokensFullDeltaTests = _ <- waitForAction "TypeCheck" doc1 _ <- Test.getSemanticTokens doc1 -- open the file and append a line to it - let change = TextDocumentContentChangeEvent - $ InL $ #range .== Range (Position 2 0) (Position 2 28) - .+ #rangeLength .== Nothing - .+ #text .== Text.replicate 28 " " + let change = + TextDocumentContentChangeEvent $ + InL $ + #range .== Range (Position 2 0) (Position 2 28) + .+ #rangeLength .== Nothing + .+ #text .== Text.replicate 28 " " changeDoc doc1 [change] _ <- waitForAction "TypeCheck" doc1 delta <- getSemanticTokensFullDelta doc1 "0" @@ -244,16 +247,17 @@ semanticTokensTests = Left _ -> error "TypeCheck2 failed" result <- docSemanticTokensString def doc2 - let expect = unlines [ - "3:8-16 TModule \"TModuleA\"" - , "4:18-26 TModule \"TModuleA\"" - , "6:1-3 TVariable \"go\"" - , "6:6-10 TDataConstructor \"Game\"" - , "8:1-5 TVariable \"a\\66560bb\"" - , "8:8-17 TModule \"TModuleA.\"" - , "8:17-20 TRecordField \"a\\66560b\"" - , "8:21-23 TVariable \"go\"" - ] + let expect = + unlines + [ "3:8-16 TModule \"TModuleA\"", + "4:18-26 TModule \"TModuleA\"", + "6:1-3 TVariable \"go\"", + "6:6-10 TDataConstructor \"Game\"", + "8:1-5 TVariable \"a\\66560bb\"", + "8:8-17 TModule \"TModuleA.\"", + "8:17-20 TRecordField \"a\\66560b\"", + "8:21-23 TVariable \"go\"" + ] liftIO $ result @?= expect, goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1", goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym", @@ -262,7 +266,7 @@ semanticTokensTests = goldenWithSemanticTokensWithDefaultConfig "TQualifiedName" "TQualifiedName" ] -- not supported in ghc92 - ++ [goldenWithSemanticTokensWithDefaultConfig "TDoc" "TDoc" | ghcVersion > GHC92] + ++ [goldenWithSemanticTokensWithDefaultConfig "TDoc" "TDoc" | ghcVersion > GHC92] semanticTokensDataTypeTests :: TestTree semanticTokensDataTypeTests =