From 3bf602543b5ae92fd1ccd3a148abc61858fb7700 Mon Sep 17 00:00:00 2001
From: Christopher Chalmers <c.chalmers@me.com>
Date: Mon, 29 Dec 2014 01:23:13 +0000
Subject: [PATCH] Use -package-db instead of package path env.

---
 src/Diagrams/Backend/CmdLine.hs | 16 +++++++-------
 src/Diagrams/Util.hs            | 39 +++++++++++++++++----------------
 2 files changed, 28 insertions(+), 27 deletions(-)

diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs
index 4858a05f..1f47d3f0 100644
--- a/src/Diagrams/Backend/CmdLine.hs
+++ b/src/Diagrams/Backend/CmdLine.hs
@@ -580,12 +580,12 @@ defaultLoopRender opts = when (opts ^. loop) $ do
                      ++ "Specify source file with '-s' or '--src'")
   srcPath' <- canonicalizePath srcPath
 
-  sandbox <- findSandbox []
-  case sandbox of
-    Nothing -> return ()
+  sandbox     <- findSandbox []
+  sandboxArgs <- case sandbox of
+    Nothing -> return []
     Just sb -> do
-      ghcPackagePath sb
       putStrLn ("Using sandbox " ++ takeDirectory sb)
+      return ["-package-db", sb]
 
   let srcFilePath = fromText $ T.pack srcPath'
       args'       = delete "-l" . delete "--loop" $ args
@@ -600,7 +600,7 @@ defaultLoopRender opts = when (opts ^. loop) $ do
              (existsEvents (== srcFilePath))
              -- Call the new program without the looping option
              (\ev -> putStrF ("Modified " ++ show (eventTime ev) ++ " ... ")
-                 >> recompile srcPath newProg >>= run newProg args')
+                  >> recompile srcPath newProg sandboxArgs >>= run newProg args')
       putStrLn $ "Watching source file " ++ srcPath
       putStrLn $ "Compiling target: " ++ newProg
       putStrLn $ "Program args: " ++ unwords args'
@@ -609,9 +609,9 @@ defaultLoopRender opts = when (opts ^. loop) $ do
         "darwin" -> 5000000000000
         _        -> maxBound
 
-recompile :: FilePath -> FilePath -> IO ExitCode
-recompile srcFile outFile = do
-  let ghcArgs = ["--make", srcFile, "-o", outFile]
+recompile :: FilePath -> FilePath -> [String] -> IO ExitCode
+recompile srcFile outFile args = do
+  let ghcArgs = ["--make", srcFile, "-o", outFile] ++ args
   putStrF "compiling ... "
   (exit, _, stderr) <- readProcessWithExitCode "ghc" ghcArgs ""
   when (exit /= ExitSuccess) $ putStrLn ('\n':stderr)
diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs
index 177dbae6..987d17be 100644
--- a/src/Diagrams/Util.hs
+++ b/src/Diagrams/Util.hs
@@ -22,7 +22,7 @@ module Diagrams.Util
 
     -- * Finding sandboxes
   , findSandbox
-  , ghcPackagePath
+  , globalPackage
 
     -- * Internal utilities
   , foldB
@@ -175,11 +175,9 @@ isDB path =
 findSandbox :: [FilePath] -> IO (Maybe FilePath)
 findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig
   where
-    lookEnv = MaybeT . lookupEnv
-    ghcPkg  = lookEnv "GHC_PACKAGE_PATH"
-    hsenv   = lookEnv "HSENV"
-    pkgDB   = lookEnv "PACKAGE_DB_FOR_GHC"
-    envDB   = ghcPkg <|> hsenv <|> pkgDB
+    -- first path in environment
+    lookEnv = MaybeT . (fmap . fmap) (head . splitSearchPath) . lookupEnv
+    envDB   = foldMaybeT lookEnv ["GHC_PACKAGE_PATH", "HSENV", "PACKAGE_DB_FOR_GHC"]
 
     -- test if path points directly to db or contains a config file
     test x    = isDB x <|> configSearch x
@@ -191,11 +189,22 @@ findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig
 --   environment (appending the ghc global package database from @ghc
 --   --info@. @GHC_PACKAGE_PATH@ if the variable ghc and other tools use
 --   to find the package database. (This is what @cabal exec@ sets)
-ghcPackagePath :: FilePath -> IO ()
-ghcPackagePath db = do
-  gdb <- globalPackage
-  let dbs = intercalate [searchPathSeparator] [db,gdb]
-  setEnv "GHC_PACKAGE_PATH" dbs
+-- ghcPackagePath :: FilePath -> IO ()
+-- ghcPackagePath db = do
+--   gdb <- globalPackage
+--   let dbs = intercalate [searchPathSeparator] [db,gdb]
+--   setEnv "GHC_PACKAGE_PATH" dbs
+--
+-- setEnv is only in base > 4.7, either need to use setenv package or
+-- -package-db flag
+
+-- | Find ghc's global package database. Throws an error if it isn't
+--   found.
+globalPackage :: IO FilePath
+globalPackage = do
+  info <- read <$> readProcess "ghc" ["--info"] ""
+  return $ fromMaybe (error "Unable to parse ghc --info.")
+                     (lookup "Global Package DB" info)
 
 -- MaybeT utilities
 
@@ -217,11 +226,3 @@ foldMaybeT f (a:as) = MaybeT $ do
     then return x
     else runMaybeT (foldMaybeT f as)
 
--- | Find ghc's global package database. Throws in error if it isn't
---   found.
-globalPackage :: IO FilePath
-globalPackage = do
-  info <- read <$> readProcess "ghc" ["--info"] ""
-  return $ fromMaybe (error "Unable to parse ghc --info.")
-                     (lookup "Global Package DB" info)
-