Make test-suite pay attention to GHC_PACKAGE_PATH (set by stack)

fpco · Jul 31, 2015 · c0782cd · c0782cd
1 parent 5bb01e6
commit c0782cd
Show file tree

Hide file tree

Showing 2 changed files with 25 additions and 11 deletions.
diff --git a/ide-backend/TestSuite/TestSuite.hs b/ide-backend/TestSuite/TestSuite.hs
@@ -1,5 +1,6 @@
 module Main where
 
+import Data.Foldable (forM_)
 import Data.List (isPrefixOf)
 import System.Process (readProcess)
 import System.Environment
@@ -80,7 +81,8 @@ allTests name env = testGroup name [
 main :: IO ()
 main = do
     -- Yes, this is hacky, but I couldn't figure out how to easily do
-    -- this with tasty's API...
+    -- this with tasty's API...  So, instead of trying to
+    -- programatically modify the config, we generate arguments.
     args <- getArgs
     let noGhcSpecified =
            "--test-74"  `notElem` args &&
@@ -102,6 +104,11 @@ main = do
           putStrLn $ "Assuming --test-" ++ versionCode
           return (("--test-" ++ versionCode) : args)
         else return args
+    -- Set GHC_PACKAGE_PATH_TEST, an environment variable used by
+    -- TestSuite.State.startNewSession.  This is needed because
+    -- ide-backend unsets GHC_PACKAGE_PATH.
+    mpkgPath <- lookupEnv "GHC_PACKAGE_PATH"
+    forM_ mpkgPath $ setEnv "GHC_PACKAGE_PATH_TEST"
     withArgs args' $ defaultMainWithIngredients ings $ testSuite $ \env ->
       let TestSuiteConfig{..} = testSuiteEnvConfig env
           env74  = env { testSuiteEnvGhcVersion = GHC_7_4  }

diff --git a/ide-backend/TestSuite/TestSuite/State.hs b/ide-backend/TestSuite/TestSuite/State.hs
@@ -37,6 +37,7 @@ module TestSuite.State (
   , packageCheck
   ) where
 
+import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.DeepSeq (rnf)
@@ -369,8 +370,10 @@ data TestSuiteServerConfig = TestSuiteServerConfig {
   deriving (Eq, Show)
 
 startNewSession :: TestSuiteServerConfig -> IO IdeSession
-startNewSession cfg = initSession (deriveSessionInitParams cfg)
-                                  (deriveSessionConfig     cfg)
+startNewSession cfg = do
+    mpkgDb <- lookupEnv "GHC_PACKAGE_PATH_TEST"
+    initSession (deriveSessionInitParams cfg)
+                (deriveSessionConfig     cfg mpkgDb)
 
 deriveSessionInitParams :: TestSuiteServerConfig -> SessionInitParams
 deriveSessionInitParams TestSuiteServerConfig{..} = defaultSessionInitParams {
@@ -385,21 +388,25 @@ deriveSessionInitParams TestSuiteServerConfig{..} = defaultSessionInitParams {
   where
     TestSuiteConfig{..} = testSuiteServerConfig
 
-deriveSessionConfig :: TestSuiteServerConfig -> SessionConfig
-deriveSessionConfig TestSuiteServerConfig{..} = defaultSessionConfig {
+deriveSessionConfig :: TestSuiteServerConfig -> Maybe String -> SessionConfig
+deriveSessionConfig TestSuiteServerConfig{..} mpkgDb = defaultSessionConfig {
       configDeleteTempFiles =
         not testSuiteConfigKeepTempFiles
     , configPackageDBStack  =
         fromMaybe (configPackageDBStack defaultSessionConfig) $
-          (
-            testSuiteServerPackageDBStack
-          `mplus`
-            do packageDb <- case testSuiteServerGhcVersion of
+          ( do packageDb <- case testSuiteServerGhcVersion of
                               GHC_7_4  -> testSuiteConfigPackageDb74
                               GHC_7_8  -> testSuiteConfigPackageDb78
                               GHC_7_10 -> testSuiteConfigPackageDb710
-               return [GlobalPackageDB, SpecificPackageDB packageDb]
-          )
+               return [GlobalPackageDB, SpecificPackageDB packageDb])
+          <|>
+            testSuiteServerPackageDBStack
+          <|>
+            fmap
+              (\pkgPath ->
+                let dbPaths = drop 1 (reverse (splitSearchPath pkgPath))
+                in GlobalPackageDB : map SpecificPackageDB dbPaths)
+              mpkgDb
     , configExtraPathDirs =
         splitSearchPath $ case testSuiteServerGhcVersion of
                             GHC_7_4  -> testSuiteConfigExtraPaths74