From 242932e24d7c203dc844655ffb7ac128327601c3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 14 Apr 2024 20:13:51 +0800 Subject: [PATCH 01/20] move ghcide-tests to haskell-language-server.cabal and make it depend on hls-test-utils --- haskell-language-server.cabal | 100 ++++++++++++++++++++++++++++++++++ 1 file changed, 100 insertions(+) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 759288f081..4312b12854 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2099,6 +2099,106 @@ benchmark benchmark , yaml +test-suite ghcide-tests + import: warnings + type: exitcode-stdio-1.0 + default-language: GHC2021 + build-tool-depends: + , ghcide:ghcide + , ghcide:ghcide-test-preprocessor + , implicit-hie:gen-hie + + build-depends: + , aeson + , async + , base + , containers + , data-default + , directory + , enummapset + , extra + , filepath + , fuzzy + , ghcide + , ghcide:ghcide-test-utils + , hls-plugin-api + , lens + , list-t + , lsp + , lsp-test ^>=0.17.0.0 + , lsp-types + , monoid-subclasses + , mtl + , network-uri + , QuickCheck + , random + , regex-tdfa ^>=1.3.1 + , row-types + , shake + , sqlite-simple + , stm + , stm-containers + , tasty + , tasty-expected-failure + , tasty-hunit >=0.10 + , tasty-quickcheck + , tasty-rerun + , text + , text-rope + , unordered-containers + , hls-test-utils == 2.7.0.0 + + if impl(ghc <9.3) + build-depends: ghc-typelits-knownnat + + hs-source-dirs: ghcide/test/exe + ghc-options: -threaded -O0 + + main-is: Main.hs + other-modules: + AsyncTests + BootTests + ClientSettingsTests + CodeLensTests + CompletionTests + CPPTests + CradleTests + DependentFileTest + DiagnosticTests + ExceptionTests + FindDefinitionAndHoverTests + FuzzySearch + GarbageCollectionTests + HaddockTests + HieDbRetry + HighlightTests + IfaceTests + InitializeResponseTests + LogType + NonLspCommandLine + OpenCloseTest + OutlineTests + PluginSimpleTests + PositionMappingTests + PreprocessorTests + Progress + ReferenceTests + RootUriTests + SafeTests + SymlinkTests + TestUtils + THTests + UnitTests + WatchedFileTests + + -- Tests that have been pulled out of the main file + default-extensions: + LambdaCase + OverloadedStrings + RecordWildCards + ViewPatterns + + test-suite ghcide-tests import: warnings type: exitcode-stdio-1.0 From 88a560989b4a0cd5f3d6738d0c82fe63c9e1934d Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 16 Apr 2024 23:48:13 +0800 Subject: [PATCH 02/20] migrate initializeResponseTests --- ghcide/test/exe/InitializeResponseTests.hs | 6 ++++-- haskell-language-server.cabal | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index ab34bdfd54..8ae723e0d3 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} module InitializeResponseTests (tests) where diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 4312b12854..f6833a7a7f 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2156,6 +2156,7 @@ test-suite ghcide-tests main-is: Main.hs other-modules: + Config AsyncTests BootTests ClientSettingsTests From 1a7f4f527f109e425686558144ecbee44bef7c19 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 16 Apr 2024 23:50:02 +0800 Subject: [PATCH 03/20] cleanup --- ghcide/test/exe/InitializeResponseTests.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index 8ae723e0d3..ab34bdfd54 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} module InitializeResponseTests (tests) where From 84d63838cc1c560cbacef5c873affa94e2f60aee Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 19 Apr 2024 22:58:34 +0800 Subject: [PATCH 04/20] migrate initializeResponseTests --- ghcide/test/exe/Config.hs | 14 +- ghcide/test/exe/InitializeResponseTests.hs | 5 +- ghcide/test/exe/OutlineTests.hs | 313 +++++++++------------ 3 files changed, 152 insertions(+), 180 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 565e6c9ceb..5528c11934 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -1,8 +1,10 @@ +{-# 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 testDataDir :: FilePath @@ -13,4 +15,10 @@ 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 + +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..0aa0cadbaa 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 + "module" + ["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) From d9dd2f4bf0cef5b0774391d1b4510d36aef681f7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 19 Apr 2024 23:09:50 +0800 Subject: [PATCH 05/20] remove duplication --- haskell-language-server.cabal | 101 ---------------------------------- 1 file changed, 101 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index f6833a7a7f..759288f081 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2198,104 +2198,3 @@ test-suite ghcide-tests OverloadedStrings RecordWildCards ViewPatterns - - -test-suite ghcide-tests - import: warnings - type: exitcode-stdio-1.0 - default-language: GHC2021 - build-tool-depends: - , ghcide:ghcide - , ghcide:ghcide-test-preprocessor - , implicit-hie:gen-hie - - build-depends: - , aeson - , async - , base - , containers - , data-default - , directory - , enummapset - , extra - , filepath - , fuzzy - , ghcide - , ghcide:ghcide-test-utils - , hls-plugin-api - , lens - , list-t - , lsp - , lsp-test ^>=0.17.0.0 - , lsp-types - , monoid-subclasses - , mtl - , network-uri - , QuickCheck - , random - , regex-tdfa ^>=1.3.1 - , row-types - , shake - , sqlite-simple - , stm - , stm-containers - , tasty - , tasty-expected-failure - , tasty-hunit >=0.10 - , tasty-quickcheck - , tasty-rerun - , text - , text-rope - , unordered-containers - , hls-test-utils == 2.7.0.0 - - if impl(ghc <9.3) - build-depends: ghc-typelits-knownnat - - hs-source-dirs: ghcide/test/exe - ghc-options: -threaded -O0 - - main-is: Main.hs - other-modules: - Config - AsyncTests - BootTests - ClientSettingsTests - CodeLensTests - CompletionTests - CPPTests - CradleTests - DependentFileTest - DiagnosticTests - ExceptionTests - FindDefinitionAndHoverTests - FuzzySearch - GarbageCollectionTests - HaddockTests - HieDbRetry - HighlightTests - IfaceTests - InitializeResponseTests - LogType - NonLspCommandLine - OpenCloseTest - OutlineTests - PluginSimpleTests - PositionMappingTests - PreprocessorTests - Progress - ReferenceTests - RootUriTests - SafeTests - SymlinkTests - TestUtils - THTests - UnitTests - WatchedFileTests - - -- Tests that have been pulled out of the main file - default-extensions: - LambdaCase - OverloadedStrings - RecordWildCards - ViewPatterns From 1392e4ed02634a3313a99cd234d386015ed54812 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 19 Apr 2024 23:20:37 +0800 Subject: [PATCH 06/20] fix test name --- ghcide/test/exe/OutlineTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs index 0aa0cadbaa..640e13a907 100644 --- a/ghcide/test/exe/OutlineTests.hs +++ b/ghcide/test/exe/OutlineTests.hs @@ -31,7 +31,7 @@ tests = testGroup "outline" [ testSymbolsA - "module" + "type class:" ["module A where", "class A a where a :: a -> Bool"] [ moduleSymbol "A" From 7bbc35c9667531e496529e56877a93aff8fc34c2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 20 Apr 2024 00:06:51 +0800 Subject: [PATCH 07/20] migrate referenceTests --- ghcide/test/exe/Config.hs | 6 +- ghcide/test/exe/ReferenceTests.hs | 76 ++++++--- hls-test-utils/src/Test/Hls.hs | 179 ++++++++++++++++------ hls-test-utils/src/Test/Hls/FileSystem.hs | 25 ++- 4 files changed, 207 insertions(+), 79 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 5528c11934..872980b6b1 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -17,8 +17,12 @@ mkIdeTestFs = FS.mkVirtualFileTree testDataDir dummyPlugin :: PluginTestDescriptor () dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dummyTestPlugin") "core" -runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a +runWithDummyPlugin :: (TestRunner cont a) => FS.VirtualFileTree -> cont -> IO a runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin +-- testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree +testWithDummyPlugin :: (TestRunner cont ()) => String -> FS.VirtualFileTree -> cont -> 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/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 5abb18bfe8..94cc361e91 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/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 @@ -18,14 +17,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 +163,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 +212,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..5aa2fa5e3b 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', + -- * polymorphic test runner so we can expose different continuation + TestRunner, -- * Helpful re-exports PluginDescriptor, IdeState, @@ -363,6 +365,87 @@ 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 @@ -374,15 +457,15 @@ 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 +-- 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 +-- 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. -- @@ -405,46 +488,46 @@ 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 +-- 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 b6742c4b83..b3a3737c1b 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,15 +101,23 @@ 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 + where -- | 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 -- | Materialise a virtual file tree in the 'rootDir' directory. -- @@ -154,6 +164,9 @@ file fp cts = File fp cts copy :: FilePath -> FileTree copy fp = File fp (Ref fp) +copyDir :: FilePath -> FileTree +copyDir dir = CopiedDirectory dir + directory :: FilePath -> [FileTree] -> FileTree directory name nodes = Directory name nodes From 3275a6372273d7095098e9ef12f86c9f3e80dcae Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 20 Apr 2024 00:13:35 +0800 Subject: [PATCH 08/20] fix github action --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 0fbfc1c8c8..b86b6b8302 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -117,7 +117,7 @@ jobs: - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test name: Test ghcide # run the tests without parallelism to avoid running out of memory - run: cabal test ghcide || cabal test ghcide + run: cabal test ghcide-tests || cabal test ghcide-tests - if: matrix.test name: Test hls-plugin-api From 8c1fa83d35d52ba7333ae2cab298687a2f08481c Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 20 Apr 2024 00:25:03 +0800 Subject: [PATCH 09/20] fix test dir location --- ghcide/test/exe/TestUtils.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index e28f26c50c..d0c5644f41 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -248,10 +248,10 @@ runWithExtraFiles prefix s = withTempDir $ \dir -> do copyTestDataFiles :: FilePath -> FilePath -> IO () copyTestDataFiles dir prefix = do -- Copy all the test data files to the temporary workspace - testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] + testDataFiles <- getDirectoryFilesIO ("ghcide/test/data" prefix) ["//*"] for_ testDataFiles $ \f -> do createDirectoryIfMissing True $ dir takeDirectory f - copyFile ("test/data" prefix f) (dir f) + copyFile ("ghcide/test/data" prefix f) (dir f) withLongTimeout :: IO a -> IO a withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") @@ -263,7 +263,7 @@ lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeW openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "test/data" path + source <- liftIO $ readFileUtf8 $ "ghcide/test/data" path createDoc path "haskell" source pattern R :: UInt -> UInt -> UInt -> UInt -> Range From 873baac14e850bd5f81dc38aaf1258b05940724f Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 20 Apr 2024 00:45:34 +0800 Subject: [PATCH 10/20] Fix hls-semantic-tests --- .../test/SemanticTokensTest.hs | 136 +++++++++--------- 1 file changed, 70 insertions(+), 66 deletions(-) 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 = From 8f696fc01354a47aa73c11117af17e092048bcdb Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 20 Apr 2024 01:10:50 +0800 Subject: [PATCH 11/20] fix 9.2 build --- ghcide/test/exe/ReferenceTests.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 94cc361e91..e81b7ec0f7 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} + module ReferenceTests (tests) where import Control.Applicative.Combinators From d6019495c7616fc981bcd88081067e6fb814f067 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 20 Apr 2024 01:17:20 +0800 Subject: [PATCH 12/20] cleanup --- hls-test-utils/src/Test/Hls.hs | 84 +--------------------------------- 1 file changed, 2 insertions(+), 82 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 5aa2fa5e3b..f56abcdf64 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -435,17 +435,8 @@ class TestRunner cont res where 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 - - - +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 @@ -457,77 +448,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. -- From 9d1c166c4c31103c980497f3baf8404a839ccbea Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 21 Apr 2024 19:56:13 +0800 Subject: [PATCH 13/20] add doc for CopiedDirectory --- hls-test-utils/src/Test/Hls/FileSystem.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index b3a3737c1b..c15c38b986 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -65,9 +65,9 @@ data VirtualFileTree = } deriving (Eq, Ord, Show) data FileTree - = File FilePath Content - | Directory FilePath [FileTree] - | CopiedDirectory FilePath + = 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 @@ -164,6 +164,8 @@ 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 From 923745a4f97968fdb7bafcc97b4248cfb7b2ef4d Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 21 Apr 2024 20:58:36 +0800 Subject: [PATCH 14/20] only copy files in git --- hls-test-utils/src/Test/Hls/FileSystem.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index c15c38b986..f8a14013d8 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -34,10 +34,12 @@ module Test.Hls.FileSystem import Data.Foldable (traverse_) import qualified Data.Text as T import qualified Data.Text.IO as T +import Debug.Trace (traceShow, traceShowM) 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 @@ -116,7 +118,7 @@ materialise rootDir' fileTree testDataDir' = do where -- | Copy a directory into a test project. copyDir' :: FilePath -> FilePath -> IO [FileTree] copyDir' root dir = do - files <- listDirectory (root dir) + files <- lines <$> withCurrentDirectory (root dir) (readProcess "git" ["ls-files", "--cached", "--modified"] "") traverse (\f -> pure $ copy (dir f)) files -- | Materialise a virtual file tree in the 'rootDir' directory. From 6e3e664b23bb69468f522bf8cb4f3aba04c40ce0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 21 Apr 2024 21:00:16 +0800 Subject: [PATCH 15/20] cleanup --- hls-test-utils/src/Test/Hls/FileSystem.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index f8a14013d8..2c35f67bcc 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -34,7 +34,6 @@ module Test.Hls.FileSystem import Data.Foldable (traverse_) import qualified Data.Text as T import qualified Data.Text.IO as T -import Debug.Trace (traceShow, traceShowM) import Development.IDE (NormalizedFilePath) import Language.LSP.Protocol.Types (toNormalizedFilePath) import System.Directory From 448dd3305eb535b0f60d9885d5d6e3f9973ac7f1 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 21 Apr 2024 21:30:26 +0800 Subject: [PATCH 16/20] add --others to show un staged files --- hls-test-utils/src/Test/Hls/FileSystem.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index 2c35f67bcc..0d92e1a5da 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -117,7 +117,8 @@ materialise rootDir' fileTree testDataDir' = do where -- | Copy a directory into a test project. copyDir' :: FilePath -> FilePath -> IO [FileTree] copyDir' root dir = do - files <- lines <$> withCurrentDirectory (root dir) (readProcess "git" ["ls-files", "--cached", "--modified"] "") + files <- lines <$> withCurrentDirectory (root dir) (readProcess "git" ["ls-files", "--cached", "--modified", "--others"] "") + mapM putStrLn files traverse (\f -> pure $ copy (dir f)) files -- | Materialise a virtual file tree in the 'rootDir' directory. From baccb0b671302bfd2d7d8d06f1593d35cad76cf9 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 21 Apr 2024 21:31:35 +0800 Subject: [PATCH 17/20] cleanup --- ghcide/test/data/references/a/A.hs | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 ghcide/test/data/references/a/A.hs diff --git a/ghcide/test/data/references/a/A.hs b/ghcide/test/data/references/a/A.hs new file mode 100644 index 0000000000..9a7d7e33c9 --- /dev/null +++ b/ghcide/test/data/references/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Data.Text +foo = () From 5e887a8065198400f68ddbbf897733ee2b0e69ee Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 21 Apr 2024 21:32:26 +0800 Subject: [PATCH 18/20] cleanup --- ghcide/test/data/references/a/A.hs | 3 --- hls-test-utils/src/Test/Hls/FileSystem.hs | 1 - 2 files changed, 4 deletions(-) delete mode 100644 ghcide/test/data/references/a/A.hs diff --git a/ghcide/test/data/references/a/A.hs b/ghcide/test/data/references/a/A.hs deleted file mode 100644 index 9a7d7e33c9..0000000000 --- a/ghcide/test/data/references/a/A.hs +++ /dev/null @@ -1,3 +0,0 @@ -module A(foo) where -import Data.Text -foo = () diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index 0d92e1a5da..f878fc1267 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -118,7 +118,6 @@ materialise rootDir' fileTree testDataDir' = do copyDir' :: FilePath -> FilePath -> IO [FileTree] copyDir' root dir = do files <- lines <$> withCurrentDirectory (root dir) (readProcess "git" ["ls-files", "--cached", "--modified", "--others"] "") - mapM putStrLn files traverse (\f -> pure $ copy (dir f)) files -- | Materialise a virtual file tree in the 'rootDir' directory. From f889d3b29f6c7540b07aee4213a31cf81148fa88 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 21 Apr 2024 23:01:42 +0800 Subject: [PATCH 19/20] copy dir recursively --- hls-test-utils/src/Test/Hls/FileSystem.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index f878fc1267..221fb7c23b 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -109,16 +109,18 @@ materialise rootDir' fileTree testDataDir' = do createDirectory (root name) mapM_ (persist (root name)) nodes persist root (CopiedDirectory name) = do - nodes <- copyDir' testDataDir' name - mapM_ (persist root) nodes + 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 - where -- | Copy a directory into a test project. - copyDir' :: FilePath -> FilePath -> IO [FileTree] - copyDir' root dir = do - files <- lines <$> withCurrentDirectory (root dir) (readProcess "git" ["ls-files", "--cached", "--modified", "--others"] "") - traverse (\f -> pure $ copy (dir f)) files -- | Materialise a virtual file tree in the 'rootDir' directory. -- From aadf02847d3509d04849fbd9ec0984489539a109 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 22 Apr 2024 18:54:00 +0800 Subject: [PATCH 20/20] use wrapper version to provide file system --- ghcide/test/exe/Config.hs | 11 +- ghcide/test/exe/ReferenceTests.hs | 2 +- hls-test-utils/src/Test/Hls.hs | 162 +++++++++++++++++------------- 3 files changed, 100 insertions(+), 75 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 872980b6b1..fa33ccefd8 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -6,6 +6,7 @@ import Ide.Types (defaultPluginDescriptor) import System.FilePath (()) import Test.Hls import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (FileSystem) testDataDir :: FilePath testDataDir = "ghcide" "test" "data" @@ -17,12 +18,18 @@ mkIdeTestFs = FS.mkVirtualFileTree testDataDir dummyPlugin :: PluginTestDescriptor () dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dummyTestPlugin") "core" -runWithDummyPlugin :: (TestRunner cont a) => FS.VirtualFileTree -> cont -> IO a +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 :: (TestRunner cont ()) => String -> 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/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index e81b7ec0f7..3bafb0b20d 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -169,7 +169,7 @@ getReferences' (file, l, c) includeDeclaration = do referenceTestSession :: String -> FilePath -> [FilePath] -> Session () -> TestTree referenceTestSession name thisDoc docs' f = do - testWithDummyPlugin name (mkIdeTestFs [copyDir "references"]) $ \fs -> do + testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do -- needed to build whole project indexing configureCheckProject True -- need to get the real paths through links diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index f56abcdf64..d8aba65f54 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -33,8 +33,8 @@ module Test.Hls runSessionWithServerAndCapsInTmpDir, runSessionWithServer', runSessionWithServerInTmpDir', - -- * polymorphic test runner so we can expose different continuation - TestRunner, + -- continuation version that take a FileSystem + runSessionWithServerInTmpDirCont', -- * Helpful re-exports PluginDescriptor, IdeState, @@ -365,78 +365,96 @@ 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. +runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a +runSessionWithServerInTmpDir config plugin tree act = runSessionWithServerInTmpDirCont' config plugin tree (const 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) + +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 + +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 + +runSessionWithServerInTmpDir' :: + -- | Plugins to load on the server. -- - -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. + -- 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. +-- +-- 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@ +runSessionWithServerInTmpDirCont :: + -- | Plugins to load on the server. -- - -- 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 + -- 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