Package environments

Summary: Package environments are files with package IDs that indicate which packages should be visible; see entry in user guide for details.

Reviewers: duncan, austin

Reviewed By: duncan, austin

Subscribers: carter, thomie

Differential Revision: https://phabricator.haskell.org/D558

(cherry picked from commit 099b76769f02432d8efcd7881348e5f5b6b50787)

4 files changed, 148 insertions, 13 deletions

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 94c786b567..951db0e9d0 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -18,7 +18,7 @@ module CmdLineParser
       Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
       errorsToGhcException,
 
-      EwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate
+      EwM(..), runEwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate
     ) where
 
 #include "HsVersions.h"
@@ -108,6 +108,9 @@ instance Monad m => Monad (EwM m) where
                                       unEwM (k r) l e' w')
     return v = EwM (\_ e w -> return (e, w, v))
 
+runEwM :: EwM m a -> m (Errs, Warns, a)
+runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
+
 setArg :: Monad m => Located String -> EwM m () -> EwM m ()
 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
 
@@ -170,8 +173,7 @@ processArgs :: Monad m
                    [Located String],  -- errors
                    [Located String] ) -- warnings
 processArgs spec args = do
-    (errs, warns, spare) <- unEwM action (panic "processArgs: no arg yet")
-                                  emptyBag emptyBag
+    (errs, warns, spare) <- runEwM action
     return (spare, bagToList errs, bagToList warns)
   where
     action = process args []
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6046751f8f..a1b1400571 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -67,6 +67,7 @@ module DynFlags (
         Settings(..),
         targetPlatform, programName, projectVersion,
         ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
+        versionedAppDir,
         extraGccViaCFlags, systemPackageConfig,
         pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
         pgm_sysman, pgm_windres, pgm_libtool, pgm_lo, pgm_lc,
@@ -91,6 +92,7 @@ module DynFlags (
         updOptLevel,
         setTmpDir,
         setPackageKey,
+        interpretPackageEnv,
 
         -- ** Parsing DynFlags
         parseDynamicFlagsCmdLine,
@@ -162,7 +164,7 @@ import CmdLineParser
 import Constants
 import Panic
 import Util
-import Maybes           ( orElse )
+import Maybes
 import MonadUtils
 import qualified Pretty
 import SrcLoc
@@ -177,6 +179,7 @@ import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
 import System.IO.Unsafe ( unsafePerformIO )
 import Data.IORef
 import Control.Monad
+import Control.Exception (throwIO)
 
 import Data.Bits
 import Data.Char
@@ -184,11 +187,12 @@ import Data.Int
 import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Word
 import System.FilePath
+import System.Directory
+import System.Environment (getEnv)
 import System.IO
 import System.IO.Error
 import Text.ParserCombinators.ReadP hiding (char)
@@ -767,6 +771,8 @@ data DynFlags = DynFlags {
 
   packageFlags          :: [PackageFlag],
         -- ^ The @-package@ and @-hide-package@ flags from the command-line
+  packageEnv            :: Maybe FilePath,
+        -- ^ Filepath to the package environment file (if overriding default)
 
   -- Package state
   -- NB. do not modify this field, it is calculated by
@@ -1012,6 +1018,14 @@ opt_lo dflags = sOpt_lo (settings dflags)
 opt_lc                :: DynFlags -> [String]
 opt_lc dflags = sOpt_lc (settings dflags)
 
+-- | The directory for this version of ghc in the user's app directory
+-- (typically something like @~/.ghc/x86_64-linux-7.6.3@)
+--
+versionedAppDir :: IO FilePath
+versionedAppDir = do
+  appdir <- getAppUserDataDirectory "ghc"
+  return $ appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
+
 -- | The target code type of the compilation (if any).
 --
 -- Whenever you change the target, also make sure to set 'ghcLink' to
@@ -1469,6 +1483,7 @@ defaultDynFlags mySettings =
 
         extraPkgConfs           = id,
         packageFlags            = [],
+        packageEnv              = Nothing,
         pkgDatabase             = Nothing,
         pkgState                = panic "no package state yet: call GHC.setSessionDynFlags",
         ways                    = defaultWays mySettings,
@@ -2722,6 +2737,7 @@ package_flags = [
   , defFlag "package-key"           (HasArg exposePackageKey)
   , defFlag "hide-package"          (HasArg hidePackage)
   , defFlag "hide-all-packages"     (NoArg (setGeneralFlag Opt_HideAllPackages))
+  , defFlag "package-env"           (HasArg setPackageEnv)
   , defFlag "ignore-package"        (HasArg ignorePackage)
   , defFlag "syslib"
       (HasArg (\s -> do exposePackage s
@@ -2731,6 +2747,8 @@ package_flags = [
   , defFlag "trust"                 (HasArg trustPackage)
   , defFlag "distrust"              (HasArg distrustPackage)
   ]
+  where
+    setPackageEnv env = upd $ \s -> s { packageEnv = Just env }
 
 -- | Make a list of flags for shell completion.
 -- Filter all available flags into two groups, for interactive GHC vs all other.
@@ -3697,6 +3715,102 @@ exposePackage' p dflags
 setPackageKey :: String -> DynFlags -> DynFlags
 setPackageKey p s =  s{ thisPackage = stringToPackageKey p }
 
+-- -----------------------------------------------------------------------------
+-- | Find the package environment (if one exists)
+--
+-- We interpret the package environment as a set of package flags; to be
+-- specific, if we find a package environment
+--
+-- > id1
+-- > id2
+-- > ..
+-- > idn
+--
+-- we interpret this as
+--
+-- > [ -hide-all-packages
+-- > , -package-id id1
+-- > , -package-id id2
+-- > , ..
+-- > , -package-id idn
+-- > ]
+interpretPackageEnv :: DynFlags -> IO DynFlags
+interpretPackageEnv dflags = do
+    mPkgEnv <- runMaybeT $ msum $ [
+                   getCmdLineArg >>= \env -> msum [
+                       loadEnvFile  env
+                     , loadEnvName  env
+                     , cmdLineError env
+                     ]
+                 , getEnvVar >>= \env -> msum [
+                       loadEnvFile env
+                     , loadEnvName env
+                     , envError    env
+                     ]
+                 , loadEnvFile localEnvFile
+                 , loadEnvName defaultEnvName
+                 ]
+    case mPkgEnv of
+      Nothing ->
+        -- No environment found. Leave DynFlags unchanged.
+        return dflags
+      Just ids -> do
+        let setFlags :: DynP ()
+            setFlags = do
+              setGeneralFlag Opt_HideAllPackages
+              mapM_ exposePackageId (lines ids)
+
+            (_, dflags') = runCmdLine (runEwM setFlags) dflags
+
+        return dflags'
+  where
+    -- Loading environments (by name or by location)
+
+    namedEnvPath :: String -> MaybeT IO FilePath
+    namedEnvPath name = do
+     appdir <- liftMaybeT $ versionedAppDir
+     return $ appdir </> "environments" </> name
+
+    loadEnvName :: String -> MaybeT IO String
+    loadEnvName name = loadEnvFile =<< namedEnvPath name
+
+    loadEnvFile :: String -> MaybeT IO String
+    loadEnvFile path = do
+      guard =<< liftMaybeT (doesFileExist path)
+      liftMaybeT $ readFile path
+
+    -- Various ways to define which environment to use
+
+    getCmdLineArg :: MaybeT IO String
+    getCmdLineArg = MaybeT $ return $ packageEnv dflags
+
+    getEnvVar :: MaybeT IO String
+    getEnvVar = do
+      mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT"
+      case mvar of
+        Right var -> return var
+        Left err  -> if isDoesNotExistError err then mzero
+                                                else liftMaybeT $ throwIO err
+
+    defaultEnvName :: String
+    defaultEnvName = "default"
+
+    localEnvFile :: FilePath
+    localEnvFile = "./.ghc.environment"
+
+    -- Error reporting
+
+    cmdLineError :: String -> MaybeT IO a
+    cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
+      "Package environment " ++ show env ++ " not found"
+
+    envError :: String -> MaybeT IO a
+    envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
+         "Package environment "
+      ++ show env
+      ++ " (specified in GHC_ENVIRIONMENT) not found"
+
+
 -- If we're linking a binary, then only targets that produce object
 -- code are allowed (requests for other target types are ignored).
 setTarget :: HscTarget -> DynP ()
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 0ffa680d42..e081a31f25 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -354,10 +354,10 @@ getPackageConfRefs dflags = do
 
 resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
 resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
-resolvePackageConfig dflags UserPkgConf = handleIO (\_ -> return Nothing) $ do
-  appdir <- getAppUserDataDirectory (programName dflags)
-  let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':projectVersion dflags)
-      pkgconf = dir </> "package.conf.d"
+resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do
+  dir <- versionedAppDir
+  let pkgconf = dir </> "package.conf.d"
+
   exist <- doesDirectoryExist pkgconf
   return $ if exist then Just pkgconf else Nothing
 resolvePackageConfig _ (PkgConfFile name) = return $ Just name
@@ -814,7 +814,8 @@ mkPackageState
            PackageKey) -- this package, might be modified if the current
                       -- package is a wired-in package.
 
-mkPackageState dflags pkgs0 preload0 this_package = do
+mkPackageState dflags0 pkgs0 preload0 this_package = do
+  dflags <- interpretPackageEnv dflags0
 
 {-
    Plan.
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index fc8e3199ae..4e64d6ed9a 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -15,11 +15,10 @@ module Maybes (
         whenIsJust,
         expectJust,
 
-        MaybeT(..)
+        MaybeT(..), liftMaybeT
     ) where
-#if __GLASGOW_HASKELL__ < 709
+
 import Control.Applicative
-#endif
 import Control.Monad
 import Data.Maybe
 
@@ -76,6 +75,25 @@ instance Monad m => Monad (MaybeT m) where
   x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f)
   fail _ = MaybeT $ return Nothing
 
+#if __GLASGOW_HASKELL__ < 710
+-- Pre-AMP change
+instance (Monad m, Functor m) => Alternative (MaybeT m) where
+#else
+instance (Monad m) => Alternative (MaybeT m) where
+#endif
+  empty = mzero
+  (<|>) = mplus
+
+instance Monad m => MonadPlus (MaybeT m) where
+  mzero       = MaybeT $ return Nothing
+  p `mplus` q = MaybeT $ do ma <- runMaybeT p
+                            case ma of
+                              Just a  -> return (Just a)
+                              Nothing -> runMaybeT q
+
+liftMaybeT :: Monad m => m a -> MaybeT m a
+liftMaybeT act = MaybeT $ Just `liftM` act
+
 {-
 ************************************************************************
 *                                                                      *