Soulomoon/refactor hls test util

ghcide/test/exe/BootTests.hs

@@ -16,6 +16,7 @@ import           Language.LSP.Protocol.Types     hiding
                                                   SemanticTokensEdit (..),
                                                   mkRange)
 import           Language.LSP.Test
+import           System.FilePath                 ((</>))
 import           Test.Hls.FileSystem             (toAbsFp)
 import           Test.Tasty
 import           Test.Tasty.HUnit
@@ -24,7 +25,7 @@ import           Test.Tasty.HUnit
 tests :: TestTree
 tests = testGroup "boot"
   [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do
-        let cPath = dir `toAbsFp` "C.hs"
+        let cPath = dir </> "C.hs"
         cSource <- liftIO $ readFileUtf8 cPath
         -- Dirty the cache
         liftIO $ runInDir dir $ do
@@ -51,6 +52,6 @@ tests = testGroup "boot"
         let floc = mkR 9 0 9 1
         checkDefs locs (pure [floc])
   , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do
-      _ <- openDoc (dir `toAbsFp` "A.hs") "haskell"
+      _ <- openDoc (dir </> "A.hs") "haskell"
       expectNoMoreDiagnostics 2
   ]

ghcide/test/exe/CPPTests.hs

@@ -9,14 +9,14 @@ import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),
                                               SemanticTokensEdit (..), mkRange)
 import           Language.LSP.Test
 -- import Test.QuickCheck.Instances ()
+import           Config
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import           TestUtils
 
 tests :: TestTree
 tests =
   testGroup "cpp"
-    [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do
+    [ testCase "cpp-error" $ do
         let content =
               T.unlines
                 [ "{-# LANGUAGE CPP #-}",
@@ -32,7 +32,7 @@ tests =
                       let _ = e :: HUnitFailure
                       run $ expectError content (2, 1)
                   )
-    , testSessionWait "cpp-ghcide" $ do
+    , testWithDummyPluginEmpty "cpp-ghcide" $ do
         _ <- createDoc "A.hs" "haskell" $ T.unlines
           ["{-# LANGUAGE CPP #-}"
           ,"main ="

ghcide/test/exe/ClientSettingsTests.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE GADTs #-}
 module ClientSettingsTests (tests) where
 
+import           Config                          (lspTestCaps, testWithConfig)
 import           Control.Applicative.Combinators
 import           Control.Monad
 import           Data.Aeson                      (toJSON)
@@ -14,13 +15,14 @@ import           Language.LSP.Protocol.Types     hiding
                                                   SemanticTokensEdit (..),
                                                   mkRange)
 import           Language.LSP.Test
-import           Test.Hls                        (waitForProgressDone)
+import           Test.Hls                        (testConfigCaps,
+                                                  waitForProgressDone)
 import           Test.Tasty
 import           TestUtils
 
 tests :: TestTree
 tests = testGroup "client settings handling"
-    [ testSession "ghcide restarts shake session on config changes" $ do
+    [ testWithConfig "ghcide restarts shake session on config changes" def {testConfigCaps = lspTestCaps} $ do
             setIgnoringLogNotifications False
             void $ createDoc "A.hs" "haskell" "module A where"
             waitForProgressDone

ghcide/test/exe/CodeLensTests.hs

@@ -2,6 +2,7 @@
 
 module CodeLensTests (tests) where
 
+import           Config
 import           Control.Applicative.Combinators
 import           Control.Lens                    ((^.))
 import           Control.Monad                   (void)
@@ -18,10 +19,9 @@ import           Language.LSP.Protocol.Types     hiding
                                                   SemanticTokensEdit (..),
                                                   mkRange)
 import           Language.LSP.Test
-import           Test.Hls                        (waitForProgressDone)
+import           Test.Hls                        (mkRange, waitForProgressDone)
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import           TestUtils
 
 tests :: TestTree
 tests = testGroup "code lenses"
@@ -46,7 +46,7 @@ addSigLensesTests =
       after' enableGHCWarnings exported (def, sig) others =
         T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others
       createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]
-      sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do
+      sigSession testName enableGHCWarnings waitForDiags mode exported def others = testWithDummyPluginEmpty testName $ do
         let originalCode = before enableGHCWarnings exported def others
         let expectedCode = after' enableGHCWarnings exported def others
         setConfigSection "haskell" (createConfig mode)
@@ -100,7 +100,7 @@ addSigLensesTests =
             [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) []
             , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) []
             ]
-        , testSession "keep stale lens" $ do
+        , testWithDummyPluginEmpty "keep stale lens" $ do
             let content = T.unlines
                     [ "module Stale where"
                     , "f = _"

ghcide/test/exe/Config.hs

@@ -11,33 +11,37 @@ module Config(
     , testWithDummyPluginEmpty
     , testWithDummyPlugin'
     , testWithDummyPluginEmpty'
-    , testWithDummyPluginAndCap'
+    , testWithConfig
+    , testWithExtraFiles
     , runWithExtraFiles
     , runInDir
-    , testWithExtraFiles
+    , run
 
-    -- * utilities for testing definition and hover
+    -- * utilities for testing
     , Expect(..)
     , pattern R
     , mkR
     , checkDefs
     , mkL
+    , withLongTimeout
     , lspTestCaps
     , lspTestCapsNoFileWatches
     ) where
 
+import           Control.Exception           (bracket_)
 import           Control.Lens.Setter         ((.~))
 import           Data.Foldable               (traverse_)
 import           Data.Function               ((&))
 import qualified Data.Text                   as T
+import           Development.IDE             (Pretty)
 import           Development.IDE.Test        (canonicalizeUri)
 import           Ide.Types                   (defaultPluginDescriptor)
 import qualified Language.LSP.Protocol.Lens  as L
 import           Language.LSP.Protocol.Types (Null (..))
+import           System.Environment.Blank    (setEnv, unsetEnv)
 import           System.FilePath             ((</>))
 import           Test.Hls
 import qualified Test.Hls.FileSystem         as FS
-import           Test.Hls.FileSystem         (FileSystem, fsRoot)
 
 testDataDir :: FilePath
 testDataDir = "ghcide" </> "test" </> "data"
@@ -52,37 +56,49 @@ dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dum
 runWithDummyPlugin ::  FS.VirtualFileTree -> Session a -> IO a
 runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin
 
-runWithDummyPlugin' ::  FS.VirtualFileTree -> (FileSystem -> Session a) -> IO a
-runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin
-
-runWithDummyPluginAndCap' :: ClientCapabilities -> (FileSystem -> Session ()) -> IO ()
-runWithDummyPluginAndCap' cap = runSessionWithServerAndCapsInTmpDirCont def dummyPlugin cap (mkIdeTestFs [])
+testWithConfig :: String -> TestConfig () -> Session () -> TestTree
+testWithConfig name conf s = testCase name $ runSessionWithTestConfig conf $ const s
 
-testWithDummyPluginAndCap' :: String -> ClientCapabilities -> (FileSystem -> Session ()) -> TestTree
-testWithDummyPluginAndCap' caseName cap = testCase caseName . runWithDummyPluginAndCap' cap
+runWithDummyPlugin' ::  FS.VirtualFileTree -> (FilePath -> Session a) -> IO a
+runWithDummyPlugin' fs = runSessionWithTestConfig def {
+    testPluginDescriptor = dummyPlugin
+    , testDirLocation = Right fs
+    , testConfigCaps = lspTestCaps
+    , testShiftRoot = True
+    }
 
 testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree
 testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const
 
-testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FileSystem -> Session ()) -> TestTree
+testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FilePath -> Session ()) -> TestTree
 testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs
 
 testWithDummyPluginEmpty :: String -> Session () -> TestTree
 testWithDummyPluginEmpty caseName = testWithDummyPlugin caseName $ mkIdeTestFs []
 
-testWithDummyPluginEmpty' :: String -> (FileSystem -> Session ()) -> TestTree
+testWithDummyPluginEmpty' :: String -> (FilePath -> Session ()) -> TestTree
 testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs []
 
-runWithExtraFiles :: String -> (FileSystem -> Session a) -> IO a
+runWithExtraFiles :: String -> (FilePath -> Session a) -> IO a
 runWithExtraFiles dirName action = do
     let vfs = mkIdeTestFs [FS.copyDir dirName]
     runWithDummyPlugin' vfs action
 
-testWithExtraFiles :: String -> String -> (FileSystem -> Session ()) -> TestTree
+testWithExtraFiles :: String -> String -> (FilePath -> Session ()) -> TestTree
 testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action
 
-runInDir :: FileSystem -> Session a -> IO a
-runInDir fs = runSessionWithServerNoRootLock False dummyPlugin def def def (fsRoot fs)
+runInDir :: FilePath -> Session a -> IO a
+runInDir fp =
+    runSessionWithTestConfig def {
+        testShiftRoot = False
+        , testPluginDescriptor=dummyPlugin
+        , testDirLocation = Left fp
+        } . const
+
+run :: Session a -> IO a
+run = runSessionWithTestConfig def
+    {testDirLocation=Right (mkIdeTestFs []), testPluginDescriptor=dummyPlugin}
+    . const
 
 pattern R :: UInt -> UInt -> UInt -> UInt -> Range
 pattern R x y x' y' = Range (Position x y) (Position x' y')
@@ -146,3 +162,6 @@ lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) N
 
 lspTestCapsNoFileWatches :: ClientCapabilities
 lspTestCapsNoFileWatches = lspTestCaps & L.workspace . traverse . L.didChangeWatchedFiles .~ Nothing
+
+withLongTimeout :: IO a -> IO a
+withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")

ghcide/test/exe/CradleTests.hs

@@ -25,13 +25,14 @@ import           Language.LSP.Test
 import           System.FilePath
 import           System.IO.Extra                 hiding (withTempDir)
 -- import Test.QuickCheck.Instances ()
+import           Config
 import           Config                          (checkDefs, mkL)
 import           Control.Lens                    ((^.))
 import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))
 import           GHC.TypeLits                    (symbolVal)
+import           Test.Hls                        (ignoreForGhcVersions)
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import           TestUtils
 
 
 tests :: TestTree
@@ -40,17 +41,17 @@ tests = testGroup "cradle"
     ,testGroup "ignore-fatal" [ignoreFatalWarning]
     ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
     ,testGroup "multi"   (multiTests "multi")
-    ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2"
+    ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2"
        $ testGroup "multi-unit" (multiTests "multi-unit")
     ,testGroup "sub-directory"   [simpleSubDirectoryTest]
-    ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2"
+    ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2"
       $ testGroup "multi-unit-rexport" [multiRexportTest]
     ]
 
 loadCradleOnlyonce :: TestTree
 loadCradleOnlyonce = testGroup "load cradle only once"
-    [ testSession' "implicit" implicit
-    , testSession' "direct"   direct
+    [ testWithDummyPluginEmpty' "implicit" implicit
+    , testWithDummyPluginEmpty' "direct"   direct
     ]
     where
         direct dir = do
@@ -70,7 +71,7 @@ loadCradleOnlyonce = testGroup "load cradle only once"
             liftIO $ length msgs @?= 0
 
 retryFailedCradle :: TestTree
-retryFailedCradle = testSession' "retry failed" $ \dir -> do
+retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
   -- The false cradle always fails
   let hieContents = "cradle: {bios: {shell: \"false\"}}"
       hiePath = dir </> "hie.yaml"
@@ -124,7 +125,7 @@ multiTestName :: FilePath -> String -> String
 multiTestName dir name = "simple-" ++ dir ++ "-" ++ name
 
 simpleMultiTest :: FilePath -> TestTree
-simpleMultiTest variant = testCase (multiTestName variant "test") $ withLongTimeout $ runWithExtraFiles variant $ \dir -> do
+simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do
     let aPath = dir </> "a/A.hs"
         bPath = dir </> "b/B.hs"
     adoc <- openDoc aPath "haskell"
@@ -201,7 +202,7 @@ multiRexportTest =
     expectNoMoreDiagnostics 0.5
 
 sessionDepsArePickedUp :: TestTree
-sessionDepsArePickedUp = testSession'
+sessionDepsArePickedUp = testWithDummyPluginEmpty'
   "session-deps-are-picked-up"
   $ \dir -> do
     liftIO $

ghcide/test/exe/DependentFileTest.hs

@@ -4,7 +4,6 @@
 module DependentFileTest (tests) where
 
 import           Config
-import           Control.Monad.IO.Class         (liftIO)
 import qualified Data.Text                      as T
 import           Development.IDE.Test           (expectDiagnostics)
 import           Development.IDE.Types.Location
@@ -15,28 +14,32 @@ import           Language.LSP.Protocol.Types    hiding
                                                  SemanticTokensEdit (..),
                                                  mkRange)
 import           Language.LSP.Test
-import           Test.Hls.FileSystem            (FileSystem, toAbsFp)
-import           Test.Tasty
+import           Test.Hls
+
 
 tests :: TestTree
 tests = testGroup "addDependentFile"
-    [testGroup "file-changed" [testWithDummyPluginEmpty' "test" test]
+    [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def
+        {testShiftRoot=True
+        , testDirLocation=Right (mkIdeTestFs [])
+        , testPluginDescriptor = dummyPlugin
+        } test]
     ]
     where
-      test :: FileSystem -> Session ()
-      test dir = do
+      test :: FilePath -> Session ()
+      test _ = do
         -- If the file contains B then no type error
         -- otherwise type error
-        let depFilePath = toAbsFp dir "dep-file.txt"
+        let depFilePath = "dep-file.txt"
         liftIO $ writeFile depFilePath "A"
         let fooContent = T.unlines
               [ "{-# LANGUAGE TemplateHaskell #-}"
               , "module Foo where"
               , "import Language.Haskell.TH.Syntax"
               , "foo :: Int"
               , "foo = 1 + $(do"
-              , "               qAddDependentFile \"dep-file.txt\""
-              , "               f <- qRunIO (readFile \"dep-file.txt\")"
+              , "               qAddDependentFile \"" <> T.pack depFilePath <> "\""
+              , "               f <- qRunIO (readFile \"" <> T.pack depFilePath <> "\")"
               , "               if f == \"B\" then [| 1 |] else lift f)"
               ]
         let bazContent = T.unlines ["module Baz where", "import Foo ()"]
@@ -47,7 +50,7 @@ tests = testGroup "addDependentFile"
         -- Now modify the dependent file
         liftIO $ writeFile depFilePath "B"
         sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
-            [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ]
+            [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ]
 
         -- Modifying Baz will now trigger Foo to be rebuilt as well
         let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial