Disable check project in the ghcide test suite (haskell#2397)

* configureCheckProject * disable checkProject in the ghcide test suite * Fix getOptions to honor LSP config overrides This is a bit ugly, but we already do it in defaultMain I also realized I don't really understand the HLS config options anymore. * redundant import * fix tests Co-authored-by: Javier Neira <[email protected]>
drsooch · Dec 3, 2021 · d6a2904 · d6a2904
1 parent a501c3c
commit d6a2904
Show file tree

Hide file tree

Showing 4 changed files with 29 additions and 13 deletions.
diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
@@ -442,6 +442,7 @@ executable ghcide-bench
         base,
         bytestring,
         containers,
+        data-default,
         directory,
         extra,
         filepath,

diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
@@ -308,7 +308,14 @@ instance IsIdeGlobal GlobalIdeOptions
 getIdeOptions :: Action IdeOptions
 getIdeOptions = do
     GlobalIdeOptions x <- getIdeGlobalAction
-    return x
+    env <- lspEnv <$> getShakeExtras
+    case env of
+        Nothing -> return x
+        Just env -> do
+            config <- liftIO $ LSP.runLspT env HLS.getClientConfig
+            return x{optCheckProject = pure $ checkProject config,
+                     optCheckParents = pure $ checkParents config
+                }
 
 getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
 getIdeOptionsIO ide = do

diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
@@ -53,7 +53,7 @@ import           Development.IDE.Test                     (Cursor,
                                                            getInterfaceFilesDir,
                                                            waitForAction,
                                                            getStoredKeys,
-                                                           waitForTypecheck, waitForGC)
+                                                           waitForTypecheck, waitForGC, configureCheckProject)
 import           Development.IDE.Test.Runfiles
 import qualified Development.IDE.Types.Diagnostics        as Diagnostics
 import           Development.IDE.Types.Location
@@ -427,10 +427,7 @@ diagnosticTests = testGroup "diagnostics"
       liftIO $ writeFile (path </> "hie.yaml") cradle
       _ <- createDoc "ModuleD.hs" "haskell" contentD
       expectDiagnostics
-        [ ( "ModuleA.hs"
-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
-          )
-        , ( "ModuleB.hs"
+        [ ( "ModuleB.hs"
           , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
           )
         ]
@@ -1603,10 +1600,7 @@ extendImportTests = testGroup "extend import actions"
         codeActionTitle CodeAction{_title=x} = x
 
         template setUpModules moduleUnderTest range expectedTitles expectedContentB = do
-            sendNotification SWorkspaceDidChangeConfiguration
-                (DidChangeConfigurationParams $ toJSON
-                  def{checkProject = overrideCheckProject})
-
+            configureCheckProject overrideCheckProject
 
             mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules
             docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest)
@@ -1783,6 +1777,7 @@ suggestImportTests = testGroup "suggest import actions"
     test = test' False
     wantWait = test' True True
     test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do
+      configureCheckProject waitForCheckProject
       let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
           after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
           cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}"
@@ -5325,6 +5320,7 @@ ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do
 
 ifaceErrorTest :: TestTree
 ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do
+    configureCheckProject True
     let bPath = dir </> "B.hs"
         pPath = dir </> "P.hs"
 
@@ -5689,6 +5685,8 @@ getReferences' (file, l, c) includeDeclaration = do
 
 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"
@@ -5819,7 +5817,9 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do
   -- Only sets HOME if it wasn't already set.
   setEnv "HOME" "/homeless-shelter" False
   conf <- getConfigFromEnv
-  runSessionWithConfig conf cmd lspTestCaps projDir s
+  runSessionWithConfig conf cmd lspTestCaps projDir $ do
+      configureCheckProject False
+      s
 
 getConfigFromEnv :: IO SessionConfig
 getConfigFromEnv = do

diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs
@@ -29,14 +29,16 @@ module Development.IDE.Test
   , getStoredKeys
   , waitForCustomMessage
   , waitForGC
-  ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount) where
+  ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount,configureCheckProject) where
 
 import           Control.Applicative.Combinators
 import           Control.Lens                    hiding (List)
 import           Control.Monad
 import           Control.Monad.IO.Class
+import           Data.Aeson                      (toJSON)
 import qualified Data.Aeson                      as A
 import           Data.Bifunctor                  (second)
+import           Data.Default
 import qualified Data.Map.Strict                 as Map
 import           Data.Maybe                      (fromJust)
 import           Data.Text                       (Text)
@@ -45,7 +47,7 @@ import           Development.IDE.Plugin.Test     (TestRequest (..),
                                                   WaitForIdeRuleResult,
                                                   ideResultSuccess)
 import           Development.IDE.Test.Diagnostic
-import           Ide.Plugin.Config               (CheckParents)
+import           Ide.Plugin.Config               (CheckParents, checkProject)
 import           Language.LSP.Test               hiding (message)
 import qualified Language.LSP.Test               as LspTest
 import           Language.LSP.Types              hiding
@@ -246,3 +248,9 @@ waitForGC = waitForCustomMessage "ghcide/GC" $ \v ->
     case A.fromJSON v of
         A.Success x -> Just x
         _           -> Nothing
+
+configureCheckProject :: Bool -> Session ()
+configureCheckProject overrideCheckProject =
+    sendNotification SWorkspaceDidChangeConfiguration
+        (DidChangeConfigurationParams $ toJSON
+            def{checkProject = overrideCheckProject})