From 4799edc01e25699e071644f7fc78655e485ac863 Mon Sep 17 00:00:00 2001
From: Daniel Vigovszky <daniel.vigovszky@gmail.com>
Date: Sun, 25 Oct 2015 16:44:52 +0100
Subject: [PATCH] Support for extra-package-dbs in 'stack ghci'

Extra package dbs support for GHC_PACKAGE_PATH
---
 src/Stack/GhcPkg.hs | 5 +++--
 src/Stack/Setup.hs  | 3 ++-
 src/main/Main.hs    | 7 +++++--
 3 files changed, 10 insertions(+), 5 deletions(-)

diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs
index 33b5ebbb37..95d158bdc7 100644
--- a/src/Stack/GhcPkg.hs
+++ b/src/Stack/GhcPkg.hs
@@ -170,10 +170,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
index 70f20384ce..dda1c2568f 100644
--- 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
index 527f3e249c..9efc8e6bb5 100644
--- a/src/main/Main.hs
+++ b/src/main/Main.hs
@@ -427,6 +427,7 @@ pathCmd keys go =
             menv <- getMinimalEnvOverride
             snap <- packageDatabaseDeps
             local <- packageDatabaseLocal
+            extra <- packageDatabaseExtra
             global <- getGlobalDB menv =<< getWhichCompiler
             snaproot <- installationRootDeps
             localroot <- installationRootLocal
@@ -456,7 +457,8 @@ pathCmd keys go =
                                     snaproot
                                     localroot
                                     distDir
-                                    hpcDir))))
+                                    hpcDir
+                                    extra))))
 
 -- | Passed to all the path printers as a source of info.
 data PathInfo = PathInfo
@@ -469,6 +471,7 @@ data PathInfo = PathInfo
     , piLocalRoot   :: Path Abs Dir
     , piDistDir     :: Path Rel Dir
     , piHpcDir      :: Path Abs Dir
+    , piExtraDbs    :: [Path Abs Dir]
     }
 
 -- | The paths of interest to a user. The first tuple string is used
@@ -517,7 +520,7 @@ paths =
       , T.pack . toFilePathNoTrailingSep . piGlobalDb )
     , ( "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"
       , T.pack . toFilePathNoTrailingSep . piSnapRoot )