Support for extra-package-dbs in 'stack ghci'

Extra package dbs support for GHC_PACKAGE_PATH
commercialhaskell · Nov 12, 2015 · f2f50a6 · f2f50a6
1 parent 33462ab
commit f2f50a6
Show file tree

Hide file tree

Showing 3 changed files with 10 additions and 5 deletions.
diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs
@@ -171,10 +171,11 @@ getCabalPkgVer menv wc =
         maybe (throwM $ Couldn'tFindPkgId cabalPackageName) return
 
 -- | Get the value for GHC_PACKAGE_PATH
-mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> Path Abs Dir -> Text
-mkGhcPackagePath locals localdb deps globaldb =
+mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
+mkGhcPackagePath locals localdb deps extras globaldb =
   T.pack $ intercalate [searchPathSeparator] $ concat
     [ [toFilePathNoTrailingSep localdb | locals]
     , [toFilePathNoTrailingSep deps]
+    , [toFilePathNoTrailingSep db | db <- reverse extras]
     , [toFilePathNoTrailingSep globaldb]
     ]
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -239,7 +239,8 @@ setupEnv mResolveMissingGHC = do
     localdb <- runReaderT packageDatabaseLocal envConfig0
     createDatabase menv wc localdb
     globaldb <- getGlobalDB menv wc
-    let mkGPP locals = mkGhcPackagePath locals localdb deps globaldb
+    extras <- runReaderT packageDatabaseExtra envConfig0
+    let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb
 
     distDir <- runReaderT distRelativeDir envConfig0
 

diff --git a/src/main/Main.hs b/src/main/Main.hs
@@ -371,6 +371,7 @@ pathCmd keys go =
             menv <- getMinimalEnvOverride
             snap <- packageDatabaseDeps
             local <- packageDatabaseLocal
+            extra <- packageDatabaseExtra
             global <- getGlobalDB menv =<< getWhichCompiler
             snaproot <- installationRootDeps
             localroot <- installationRootLocal
@@ -394,7 +395,8 @@ pathCmd keys go =
                                     global
                                     snaproot
                                     localroot
-                                    distDir))))
+                                    distDir
+                                    extra))))
 
 -- | Passed to all the path printers as a source of info.
 data PathInfo = PathInfo
@@ -406,6 +408,7 @@ data PathInfo = PathInfo
     ,piSnapRoot :: Path Abs Dir
     ,piLocalRoot :: Path Abs Dir
     ,piDistDir :: Path Rel Dir
+    ,piExtraDbs :: [Path Abs Dir]
     }
 
 -- | The paths of interest to a user. The first tuple string is used
@@ -467,7 +470,7 @@ paths =
              T.pack (toFilePathNoTrailingSep (piGlobalDb pi)))
     , ( "GHC_PACKAGE_PATH environment variable"
       , "ghc-package-path"
-      , \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piGlobalDb pi))
+      , \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piExtraDbs pi) (piGlobalDb pi))
     , ( "Snapshot installation root"
       , "snapshot-install-root"
       , \pi ->