content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleContexts #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Distribution.Client.Sandbox
  -- Maintainer  :  cabal-devel@haskell.org
  -- Portability :  portable
  --
  -- UI for the sandboxing functionality.
  -----------------------------------------------------------------------------
  
  module Distribution.Client.Sandbox (
      sandboxInit,
      sandboxDelete,
      sandboxAddSource,
      sandboxAddSourceSnapshot,
      sandboxDeleteSource,
      sandboxListSources,
      sandboxHcPkg,
      dumpPackageEnvironment,
      withSandboxBinDirOnSearchPath,
  
      getSandboxConfigFilePath,
      loadConfigOrSandboxConfig,
      findSavedDistPref,
      initPackageDBIfNeeded,
      maybeWithSandboxDirOnSearchPath,
  
      WereDepsReinstalled(..),
      reinstallAddSourceDeps,
      maybeReinstallAddSourceDeps,
  
      SandboxPackageInfo(..),
      maybeWithSandboxPackageInfo,
  
      tryGetIndexFilePath,
      sandboxBuildDir,
      getInstalledPackagesInSandbox,
      updateSandboxConfigFileFlag,
      updateInstallDirs,
  
      getPersistOrConfigCompiler
    ) where
  
  import Prelude ()
  import Distribution.Client.Compat.Prelude
  
  import Distribution.Client.Setup
    ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)
    , GlobalFlags(..), configCompilerAux', configPackageDB'
    , defaultConfigExFlags, defaultInstallFlags
    , defaultSandboxLocation, withRepoContext )
  import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps
                                                , maybeAddCompilerTimestampRecord
                                                , withAddTimestamps
                                                , removeTimestamps )
  import Distribution.Client.Config
    ( SavedConfig(..), defaultUserInstall, loadConfig )
  import Distribution.Client.Dependency         ( foldProgress )
  import Distribution.Client.IndexUtils         ( BuildTreeRefType(..) )
  import Distribution.Client.Install            ( InstallArgs,
                                                  makeInstallContext,
                                                  makeInstallPlan,
                                                  processInstallPlan )
  import Distribution.Utils.NubList            ( fromNubList )
  
  import Distribution.Client.Sandbox.PackageEnvironment
    ( PackageEnvironment(..), PackageEnvironmentType(..)
    , createPackageEnvironmentFile, classifyPackageEnvironment
    , tryLoadSandboxPackageEnvironmentFile, loadUserConfig
    , commentPackageEnvironment, showPackageEnvironmentWithComments
    , sandboxPackageEnvironmentFile, userPackageEnvironmentFile
    , sandboxPackageDBPath )
  import Distribution.Client.Sandbox.Types      ( SandboxPackageInfo(..)
                                                , UseSandbox(..) )
  import Distribution.Client.SetupWrapper
    ( SetupScriptOptions(..), defaultSetupScriptOptions )
  import Distribution.Client.Types              ( PackageLocation(..) )
  import Distribution.Client.Utils              ( inDir, tryCanonicalizePath
                                                , tryFindAddSourcePackageDesc)
  import Distribution.PackageDescription.Configuration
                                                ( flattenPackageDescription )
  import Distribution.Client.PackageDescription.Dhall
           ( readGenericPackageDescription )
  import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..) )
  import Distribution.Simple.Configure          ( configCompilerAuxEx
                                                , getPackageDBContents
                                                , maybeGetPersistBuildConfig
                                                , findDistPrefOrDefault
                                                , findDistPref )
  import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo
  import Distribution.Simple.PreProcess         ( knownSuffixHandlers )
  import Distribution.Simple.Program            ( ProgramDb )
  import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)
                                                , fromFlagOrDefault, flagToMaybe )
  import Distribution.Simple.SrcDist            ( prepareTree )
  import Distribution.Simple.Utils              ( die', debug, notice, info, warn
                                                , debugNoWrap, defaultPackageDesc
                                                , topHandlerWith
                                                , createDirectoryIfMissingVerbose )
  import Distribution.Package                   ( Package(..) )
  import Distribution.System                    ( Platform )
  import Distribution.Text                      ( display )
  import Distribution.Verbosity                 ( Verbosity )
  import Distribution.Compat.Environment        ( lookupEnv, setEnv )
  import Distribution.Client.Compat.FilePerms   ( setFileHidden )
  import qualified Distribution.Client.Sandbox.Index as Index
  import Distribution.Simple.PackageIndex       ( InstalledPackageIndex )
  import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex
  import qualified Distribution.Simple.Register      as Register
  
  import Distribution.Solver.Types.SourcePackage
  
  import qualified Data.Map                          as M
  import qualified Data.Set                          as S
  import Data.Either                            (partitionEithers)
  import Control.Exception                      ( assert, bracket_ )
  import Control.Monad                          ( forM, mapM, mapM_ )
  import Data.Bits                              ( shiftL, shiftR, xor )
  import Data.IORef                             ( newIORef, writeIORef, readIORef )
  import Data.List                              ( delete
                                                , groupBy )
  import Data.Maybe                             ( fromJust )
  import Numeric                                ( showHex )
  import System.Directory                       ( canonicalizePath
                                                , createDirectory
                                                , doesDirectoryExist
                                                , doesFileExist
                                                , getCurrentDirectory
                                                , removeDirectoryRecursive
                                                , removeFile
                                                , renameDirectory )
  import System.FilePath                        ( (</>), equalFilePath
                                                , getSearchPath
                                                , searchPathSeparator
                                                , splitSearchPath
                                                , takeDirectory )
  
  --
  -- * Constants
  --
  
  -- | The name of the sandbox subdirectory where we keep snapshots of add-source
  -- dependencies.
  snapshotDirectoryName :: FilePath
  snapshotDirectoryName = "snapshots"
  
  -- | Non-standard build dir that is used for building add-source deps instead of
  -- "dist". Fixes surprising behaviour in some cases (see issue #1281).
  sandboxBuildDir :: FilePath -> FilePath
  sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash ""
    where
      sandboxDirHash = jenkins sandboxDir
  
      -- See http://en.wikipedia.org/wiki/Jenkins_hash_function
      jenkins :: String -> Word32
      jenkins str = loop_finish $ foldl' loop 0 str
        where
          loop :: Word32 -> Char -> Word32
          loop hash key_i' = hash'''
            where
              key_i   = toEnum . ord $ key_i'
              hash'   = hash + key_i
              hash''  = hash' + (shiftL hash' 10)
              hash''' = hash'' `xor` (shiftR hash'' 6)
  
          loop_finish :: Word32 -> Word32
          loop_finish hash = hash'''
            where
              hash'   = hash + (shiftL hash 3)
              hash''  = hash' `xor` (shiftR hash' 11)
              hash''' = hash'' + (shiftL hash'' 15)
  
  --
  -- * Basic sandbox functions.
  --
  
  -- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the
  -- value of the @ETLAS_SANDBOX_CONFIG@ environment variable, or else to
  -- 'NoFlag'.
  updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags
  updateSandboxConfigFileFlag globalFlags =
    case globalSandboxConfigFile globalFlags of
      Flag _ -> return globalFlags
      NoFlag -> do
        f' <- fmap (maybe NoFlag Flag) . lookupEnv $ "ETLAS_SANDBOX_CONFIG"
        return globalFlags { globalSandboxConfigFile = f' }
  
  -- | Return the path to the sandbox config file - either the default or the one
  -- specified with @--sandbox-config-file@.
  getSandboxConfigFilePath :: GlobalFlags -> IO FilePath
  getSandboxConfigFilePath globalFlags = do
    let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags
    case sandboxConfigFileFlag of
      NoFlag -> do pkgEnvDir <- getCurrentDirectory
                   return (pkgEnvDir </> sandboxPackageEnvironmentFile)
      Flag path -> return path
  
  -- | Load the @cabal.sandbox.config@ file (and possibly the optional
  -- @cabal.config@). In addition to a @PackageEnvironment@, also return a
  -- canonical path to the sandbox. Exit with error if the sandbox directory or
  -- the package environment file do not exist.
  tryLoadSandboxConfig :: Verbosity -> GlobalFlags
                          -> IO (FilePath, PackageEnvironment)
  tryLoadSandboxConfig verbosity globalFlags = do
    path <- getSandboxConfigFilePath globalFlags
    tryLoadSandboxPackageEnvironmentFile verbosity path
      (globalConfigFile globalFlags)
      (globalSendMetrics globalFlags)
  
  -- | Return the name of the package index file for this package environment.
  tryGetIndexFilePath :: Verbosity -> SavedConfig -> IO FilePath
  tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config)
  
  -- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of
  -- 'SavedConfig'.
  tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath
  tryGetIndexFilePath' verbosity globalFlags = do
    let paths = fromNubList $ globalLocalRepos globalFlags
    case paths of
      []  -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++
             "no local repos found. " ++ checkConfiguration
      _   -> return $ (last paths) </> Index.defaultIndexFileName
    where
      checkConfiguration = "Please check your configuration ('"
                           ++ userPackageEnvironmentFile ++ "')."
  
  -- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error
  -- message than just pattern-matching.
  getSandboxPackageDB :: Verbosity -> ConfigFlags -> IO PackageDB
  getSandboxPackageDB verbosity configFlags = do
    case configPackageDBs configFlags of
      [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB
      -- TODO: should we allow multiple package DBs (e.g. with 'inherit')?
  
      []                                     ->
        die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt
      [_]                                    ->
        die' verbosity $ "Unexpected contents of the 'package-db' field. "
              ++ sandboxConfigCorrupt
      _                                      ->
        die' verbosity $ "Too many package DBs provided. " ++ sandboxConfigCorrupt
  
    where
      sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt."
  
  
  -- | Which packages are installed in the sandbox package DB?
  getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags
                                   -> Compiler -> ProgramDb
                                   -> IO InstalledPackageIndex
  getInstalledPackagesInSandbox verbosity configFlags comp progdb = do
      sandboxDB <- getSandboxPackageDB verbosity configFlags
      getPackageDBContents verbosity comp sandboxDB progdb
  
  -- | Temporarily add $SANDBOX_DIR/bin to $PATH.
  withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a
  withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir
    where
      -- TODO: Instead of modifying the global process state, it'd be better to
      -- set the environment individually for each subprocess invocation. This
      -- will have to wait until the Shell monad is implemented; without it the
      -- required changes are too intrusive.
      addBinDir :: IO ()
      addBinDir = do
        mbOldPath <- lookupEnv "PATH"
        let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator)
                      mbOldPath
        setEnv "PATH" newPath
  
      rmBinDir :: IO ()
      rmBinDir = do
        oldPath <- getSearchPath
        let newPath = intercalate [searchPathSeparator]
                      (delete sandboxBin oldPath)
        setEnv "PATH" newPath
  
      sandboxBin = sandboxDir </> "bin"
  
  -- | Initialise a package DB for this compiler if it doesn't exist.
  initPackageDBIfNeeded :: Verbosity -> ConfigFlags
                           -> Compiler -> ProgramDb
                           -> IO ()
  initPackageDBIfNeeded verbosity configFlags comp progdb = do
    SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags
    packageDBExists <- doesDirectoryExist dbPath
    unless packageDBExists $
      Register.initPackageDB verbosity comp progdb dbPath
    when packageDBExists $
      debug verbosity $ "The package database already exists: " ++ dbPath
  
  -- | Entry point for the 'cabal sandbox dump-pkgenv' command.
  dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()
  dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do
    (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
    commentPkgEnv        <- commentPackageEnvironment sandboxDir
    putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv
  
  -- | Entry point for the 'cabal sandbox init' command.
  sandboxInit :: Verbosity -> SandboxFlags  -> GlobalFlags -> IO ()
  sandboxInit verbosity sandboxFlags globalFlags = do
    -- Warn if there's a 'cabal-dev' sandbox.
    isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev")
                         (doesFileExist $ "cabal-dev" </> "cabal.config")
    when isCabalDevSandbox $
      warn verbosity $
      "You are apparently using a legacy (cabal-dev) sandbox. "
      ++ "Legacy sandboxes may interact badly with native Cabal sandboxes. "
      ++ "You may want to delete the 'cabal-dev' directory to prevent issues."
  
    -- Create the sandbox directory.
    let sandboxDir' = fromFlagOrDefault defaultSandboxLocation
                      (sandboxLocation sandboxFlags)
    createDirectoryIfMissingVerbose verbosity True sandboxDir'
    sandboxDir <- tryCanonicalizePath sandboxDir'
    setFileHidden sandboxDir
  
    -- Determine which compiler to use (using the value from ~/.cabal/config).
    userConfig <- loadConfig verbosity (globalConfigFile globalFlags)
                    (globalSendMetrics globalFlags)
    (comp, platform, progdb) <- configCompilerAuxEx (savedConfigureFlags userConfig)
  
    -- Create the package environment file.
    pkgEnvFile <- getSandboxConfigFilePath globalFlags
    createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform
    (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
    let config      = pkgEnvSavedConfig pkgEnv
        configFlags = savedConfigureFlags config
  
    -- Create the index file if it doesn't exist.
    indexFile <- tryGetIndexFilePath verbosity config
    indexFileExists <- doesFileExist indexFile
    if indexFileExists
      then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir
      else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir
    Index.createEmpty verbosity indexFile
  
    -- Create the package DB for the default compiler.
    initPackageDBIfNeeded verbosity configFlags comp progdb
    maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
      (compilerId comp) platform
  
  -- | Entry point for the 'cabal sandbox delete' command.
  sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()
  sandboxDelete verbosity _sandboxFlags globalFlags = do
    (useSandbox, _) <- loadConfigOrSandboxConfig
                         verbosity
                         globalFlags { globalRequireSandbox = Flag False }
    case useSandbox of
      NoSandbox -> warn verbosity "Not in a sandbox."
      UseSandbox sandboxDir -> do
        curDir     <- getCurrentDirectory
        pkgEnvFile <- getSandboxConfigFilePath globalFlags
  
        -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard
        -- location.
        let isNonDefaultConfigLocation = not $ equalFilePath pkgEnvFile $
                                         curDir </> sandboxPackageEnvironmentFile
  
        if isNonDefaultConfigLocation
          then warn verbosity $ "Sandbox config file is in non-default location: '"
                      ++ pkgEnvFile ++ "'.\n Please delete manually."
          else removeFile pkgEnvFile
  
        -- Remove the sandbox directory, unless we're using a shared sandbox.
        let isNonDefaultSandboxLocation = not $ equalFilePath sandboxDir $
                                          curDir </> defaultSandboxLocation
  
        when isNonDefaultSandboxLocation $
          die' verbosity $ "Non-default sandbox location used: '" ++ sandboxDir
          ++ "'.\nAssuming a shared sandbox. Please delete '"
          ++ sandboxDir ++ "' manually."
  
        absSandboxDir <- canonicalizePath sandboxDir
        notice verbosity $ "Deleting the sandbox located at " ++ absSandboxDir
        removeDirectoryRecursive absSandboxDir
  
        let
          pathInsideSandbox = isPrefixOf absSandboxDir
  
          -- Warn the user if deleting the sandbox deleted a package database
          -- referenced in the current environment.
          checkPackagePaths var = do
            let
              checkPath path = do
                absPath <- canonicalizePath path
                (when (pathInsideSandbox absPath) . warn verbosity)
                  (var ++ " refers to package database " ++ path
                   ++ " inside the deleted sandbox.")
            liftM (maybe [] splitSearchPath) (lookupEnv var) >>= mapM_ checkPath
  
        checkPackagePaths "ETLAS_SANDBOX_PACKAGE_PATH"
        checkPackagePaths "ETA_PACKAGE_PATH"
  
  -- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'.
  doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment
                 -> BuildTreeRefType
                 -> IO ()
  doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do
    let savedConfig       = pkgEnvSavedConfig pkgEnv
    indexFile            <- tryGetIndexFilePath verbosity savedConfig
  
    -- If we're running 'sandbox add-source' for the first time for this compiler,
    -- we need to create an initial timestamp record.
    (comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig
    maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
      (compilerId comp) platform
  
    withAddTimestamps verbosity sandboxDir $ do
      -- Path canonicalisation is done in addBuildTreeRefs, but we do it
      -- twice because of the timestamps file.
      buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs
      Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType
      return buildTreeRefs'
  
  -- | Entry point for the 'cabal sandbox add-source' command.
  sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
                      -> IO ()
  sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do
    (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
  
    if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)
      then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv
      else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef
  
  -- | Entry point for the 'cabal sandbox add-source --snapshot' command.
  sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath
                              -> PackageEnvironment
                              -> IO ()
  sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do
    let snapshotDir = sandboxDir </> snapshotDirectoryName
  
    -- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private
    -- location.
    createDirectoryIfMissingVerbose verbosity True snapshotDir
  
    -- Collect the package descriptions first, so that if some path does not refer
    -- to a cabal package, we fail immediately.
    pkgs      <- forM buildTreeRefs $ \buildTreeRef ->
      inDir (Just buildTreeRef) $
      return . flattenPackageDescription
              =<< readGenericPackageDescription verbosity
              =<< defaultPackageDesc     verbosity
  
    -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If
    -- 'prepareTree' throws an error at any point, the old snapshots will still be
    -- in consistent state.
    tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) ->
      inDir (Just buildTreeRef) $ do
        let targetDir    = snapshotDir </> (display . packageId $ pkg)
            targetTmpDir = targetDir ++ "-tmp"
        dirExists <- doesDirectoryExist targetTmpDir
        when dirExists $
          removeDirectoryRecursive targetDir
        createDirectory targetTmpDir
        prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers
        return (targetTmpDir, targetDir)
  
    -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to
    -- "snapshots/$PKGNAME-$VERSION".
    snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do
      dirExists <- doesDirectoryExist targetDir
      when dirExists $
        removeDirectoryRecursive targetDir
      renameDirectory targetTmpDir targetDir
      return targetDir
  
    -- Once the packages are copied, just 'add-source' them as usual.
    doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef
  
  -- | Entry point for the 'cabal sandbox delete-source' command.
  sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
                         -> IO ()
  sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
    (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
    indexFile            <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv)
  
    (results, convDict) <-
      Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
  
    let (failedPaths, removedPaths) = partitionEithers results
        removedRefs = fmap convDict removedPaths
  
    unless (null removedPaths) $ do
      removeTimestamps verbosity sandboxDir removedPaths
  
      notice verbosity $ "Success deleting sources: " ++
        showL removedRefs ++ "\n\n"
  
    unless (null failedPaths) $ do
      let groupedFailures = groupBy errorType failedPaths
      mapM_ handleErrors groupedFailures
      die' verbosity $ "The sources with the above errors were skipped. (" ++
        showL (fmap getPath failedPaths) ++ ")"
  
    notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++
      "source dependency, but does not remove the package " ++
      "from the sandbox package DB.\n\n" ++
      "Use 'sandbox hc-pkg -- unregister' to do that."
    where
      getPath (Index.ErrNonregisteredSource p) = p
      getPath (Index.ErrNonexistentSource p) = p
  
      showPaths f = concat . intersperse " " . fmap (show . f)
  
      showL = showPaths id
  
      showE [] = return ' '
      showE errs = showPaths getPath errs
  
      errorType Index.ErrNonregisteredSource{} Index.ErrNonregisteredSource{} =
        True
      errorType Index.ErrNonexistentSource{} Index.ErrNonexistentSource{} = True
      errorType _ _ = False
  
      handleErrors [] = return ()
      handleErrors errs@(Index.ErrNonregisteredSource{}:_) =
        warn verbosity ("Sources not registered: " ++ showE errs ++ "\n\n")
      handleErrors errs@(Index.ErrNonexistentSource{}:_)   =
        warn verbosity
        ("Source directory not found for paths: " ++ showE errs ++ "\n"
         ++ "If you are trying to delete a reference to a removed directory, "
         ++ "please provide the full absolute path "
         ++ "(as given by `sandbox list-sources`).\n\n")
  
  -- | Entry point for the 'cabal sandbox list-sources' command.
  sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags
                        -> IO ()
  sandboxListSources verbosity _sandboxFlags globalFlags = do
    (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
    indexFile            <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv)
  
    refs <- Index.listBuildTreeRefs verbosity
            Index.ListIgnored Index.LinksAndSnapshots indexFile
    when (null refs) $
      notice verbosity $ "Index file '" ++ indexFile
      ++ "' has no references to local build trees."
    when (not . null $ refs) $ do
      notice verbosity $ "Source dependencies registered "
        ++ "in the current sandbox ('" ++ sandboxDir ++ "'):\n\n"
      mapM_ putStrLn refs
      notice verbosity $ "\nTo unregister source dependencies, "
                         ++ "use the 'sandbox delete-source' command."
  
  -- | Entry point for the 'cabal sandbox hc-pkg' command. Invokes the @hc-pkg@
  -- tool with provided arguments, restricted to the sandbox.
  sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO ()
  sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do
    (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
    let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv
    -- Invoke hc-pkg for the most recently configured compiler (if any),
    -- using the right package-db for the compiler (see #1935).
    (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags
    let dir         = sandboxPackageDBPath sandboxDir comp platform
        dbStack     = [GlobalPackageDB, SpecificPackageDB dir]
    Register.invokeHcPkg verbosity comp progdb dbStack extraArgs
  
  updateInstallDirs :: Flag Bool
                    -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig)
  updateInstallDirs userInstallFlag (useSandbox, savedConfig) =
    case useSandbox of
      NoSandbox ->
        let savedConfig' = savedConfig {
              savedConfigureFlags = configureFlags {
                  configInstallDirs = installDirs
              }
            }
        in (useSandbox, savedConfig')
      _ -> (useSandbox, savedConfig)
    where
      configureFlags = savedConfigureFlags savedConfig
      userInstallDirs = savedUserInstallDirs savedConfig
      globalInstallDirs = savedGlobalInstallDirs savedConfig
      installDirs | userInstall = userInstallDirs
                  | otherwise   = globalInstallDirs
      userInstall = fromFlagOrDefault defaultUserInstall
                    (configUserInstall configureFlags `mappend` userInstallFlag)
  
  -- | Check which type of package environment we're in and return a
  -- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates
  -- whether we're working in a sandbox.
  loadConfigOrSandboxConfig :: Verbosity
                            -> GlobalFlags  -- ^ For @--config-file@ and
                                            -- @--sandbox-config-file@.
                            -> IO (UseSandbox, SavedConfig)
  loadConfigOrSandboxConfig verbosity globalFlags = do
    let configFileFlag        = globalConfigFile        globalFlags
        sandboxConfigFileFlag = globalSandboxConfigFile globalFlags
        ignoreSandboxFlag     = globalIgnoreSandbox     globalFlags
        sendMetricsFlag       = globalSendMetrics       globalFlags
  
    pkgEnvDir  <- getPkgEnvDir sandboxConfigFileFlag
    pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag
                                             ignoreSandboxFlag
    case pkgEnvType of
      -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.
      SandboxPackageEnvironment -> do
        (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
                                -- Prints an error message and exits on error.
        let config = pkgEnvSavedConfig pkgEnv
        return (UseSandbox sandboxDir, config)
  
      -- Only @cabal.config@ is present.
      UserPackageEnvironment    -> do
        config <- loadConfig verbosity configFileFlag sendMetricsFlag
        userConfig <- loadUserConfig verbosity pkgEnvDir Nothing
        let config' = config `mappend` userConfig
        dieIfSandboxRequired config'
        return (NoSandbox, config')
  
      -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
      AmbientPackageEnvironment -> do
        config <- loadConfig verbosity configFileFlag sendMetricsFlag
        let globalConstraintsOpt =
              flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config
        globalConstraintConfig <-
          loadUserConfig verbosity pkgEnvDir globalConstraintsOpt
        let config' = config `mappend` globalConstraintConfig
        dieIfSandboxRequired config
        return (NoSandbox, config')
  
    where
      -- Return the path to the package environment directory - either the
      -- current directory or the one that @--sandbox-config-file@ resides in.
      getPkgEnvDir :: (Flag FilePath) -> IO FilePath
      getPkgEnvDir sandboxConfigFileFlag = do
        case sandboxConfigFileFlag of
          NoFlag    -> getCurrentDirectory
          Flag path -> tryCanonicalizePath . takeDirectory $ path
  
      -- Die if @--require-sandbox@ was specified and we're not inside a sandbox.
      dieIfSandboxRequired :: SavedConfig -> IO ()
      dieIfSandboxRequired config = checkFlag flag
        where
          flag = (globalRequireSandbox . savedGlobalFlags $ config)
                 `mappend` (globalRequireSandbox globalFlags)
          checkFlag (Flag True)  =
            die' verbosity $ "'require-sandbox' is set to True, but no sandbox is present. "
               ++ "Use '--no-require-sandbox' if you want to override "
               ++ "'require-sandbox' temporarily."
          checkFlag (Flag False) = return ()
          checkFlag (NoFlag)     = return ()
  
  -- | Return the saved \"dist/\" prefix, or the default prefix.
  findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath
  findSavedDistPref config flagDistPref = do
      let defDistPref = useDistPref defaultSetupScriptOptions
          flagDistPref' = configDistPref (savedConfigureFlags config)
                          `mappend` flagDistPref
      findDistPref defDistPref flagDistPref'
  
  -- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do
  -- nothing.
  maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a
  maybeWithSandboxDirOnSearchPath NoSandbox               act = act
  maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act =
    withSandboxBinDirOnSearchPath sandboxDir $ act
  
  -- | Had reinstallAddSourceDeps actually reinstalled any dependencies?
  data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled
  
  -- | Reinstall those add-source dependencies that have been modified since
  -- we've last installed them. Assumes that we're working inside a sandbox.
  reinstallAddSourceDeps :: Verbosity
                            -> ConfigFlags  -> ConfigExFlags
                            -> InstallFlags -> GlobalFlags
                            -> FilePath
                            -> IO WereDepsReinstalled
  reinstallAddSourceDeps verbosity configFlags' configExFlags
                         installFlags globalFlags sandboxDir = topHandler' $ do
    let sandboxDistPref     = sandboxBuildDir sandboxDir
        configFlags         = configFlags'
                              { configDistPref  = Flag sandboxDistPref }
        haddockFlags        = mempty
                              { haddockDistPref = Flag sandboxDistPref }
    (comp, platform, progdb) <- configCompilerAux' configFlags
    retVal                   <- newIORef NoDepsReinstalled
  
    withSandboxPackageInfo verbosity configFlags globalFlags
                           comp platform progdb sandboxDir $ \sandboxPkgInfo ->
      unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do
  
        withRepoContext verbosity globalFlags $ \repoContext -> do
          let args :: InstallArgs
              args = ((configPackageDB' configFlags)
                    ,repoContext
                    ,comp, platform, progdb
                    ,UseSandbox sandboxDir, Just sandboxPkgInfo
                    ,globalFlags, configFlags, configExFlags, installFlags
                    ,haddockFlags)
  
          -- This can actually be replaced by a call to 'install', but we use a
          -- lower-level API because of layer separation reasons. Additionally, we
          -- might want to use some lower-level features this in the future.
          withSandboxBinDirOnSearchPath sandboxDir $ do
            installContext <- makeInstallContext verbosity args Nothing
            installPlan    <- foldProgress logMsg die'' return =<<
                              makeInstallPlan verbosity args installContext
  
            processInstallPlan verbosity args installContext installPlan
            writeIORef retVal ReinstalledSomeDeps
  
    readIORef retVal
  
      where
        die'' message = die' verbosity (message ++ installFailedInSandbox)
        -- TODO: use a better error message, remove duplication.
        installFailedInSandbox =
          "Note: when using a sandbox, all packages are required to have "
          ++ "consistent dependencies. Try reinstalling/unregistering the "
          ++ "offending packages or recreating the sandbox."
        logMsg message rest = debugNoWrap verbosity message >> rest
  
        topHandler' = topHandlerWith $ \_ -> do
          warn verbosity "Couldn't reinstall some add-source dependencies."
          -- Here we can't know whether any deps have been reinstalled, so we have
          -- to be conservative.
          return ReinstalledSomeDeps
  
  -- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that
  -- we don't update the timestamp file here - this is done in
  -- 'postInstallActions'.
  withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags
                            -> Compiler -> Platform -> ProgramDb
                            -> FilePath
                            -> (SandboxPackageInfo -> IO ())
                            -> IO ()
  withSandboxPackageInfo verbosity configFlags globalFlags
                         comp platform progdb sandboxDir cont = do
    -- List all add-source deps.
    indexFile              <- tryGetIndexFilePath' verbosity globalFlags
    buildTreeRefs          <- Index.listBuildTreeRefs verbosity
                              Index.DontListIgnored Index.OnlyLinks indexFile
    let allAddSourceDepsSet = S.fromList buildTreeRefs
  
    -- List all packages installed in the sandbox.
    installedPkgIndex <- getInstalledPackagesInSandbox verbosity
                         configFlags comp progdb
    let err = "Error reading sandbox package information."
    -- Get the package descriptions for all add-source deps.
    depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs
    depsPkgDescs   <- mapM (readGenericPackageDescription verbosity) depsCabalFiles
    let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)
        isInstalled pkgid = not . null
          . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid
        installedDepsMap  = M.filter (isInstalled . packageId) depsMap
  
    -- Get the package ids of modified (and installed) add-source deps.
    modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir
                             (compilerId comp) platform installedDepsMap
    -- 'fromJust' here is safe because 'modifiedAddSourceDeps' are guaranteed to
    -- be a subset of the keys of 'depsMap'.
    let modifiedDeps    = [ (modDepPath, fromJust $ M.lookup modDepPath depsMap)
                          | modDepPath <- modifiedAddSourceDeps ]
        modifiedDepsMap = M.fromList modifiedDeps
  
    assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())
    if (null modifiedDeps)
      then info   verbosity $ "Found no modified add-source deps."
      else notice verbosity $ "Some add-source dependencies have been modified. "
                              ++ "They will be reinstalled..."
  
    -- Get the package ids of the remaining add-source deps (some are possibly not
    -- installed).
    let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)
  
    -- Finally, assemble a 'SandboxPackageInfo'.
    cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)
      (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet
  
    where
      toSourcePackage (path, pkgDesc) = SourcePackage
        (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing Nothing
  
  -- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the
  -- identity otherwise.
  maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags
                                 -> Compiler -> Platform -> ProgramDb
                                 -> UseSandbox
                                 -> (Maybe SandboxPackageInfo -> IO ())
                                 -> IO ()
  maybeWithSandboxPackageInfo verbosity configFlags globalFlags
                              comp platform progdb useSandbox cont =
    case useSandbox of
      NoSandbox             -> cont Nothing
      UseSandbox sandboxDir -> withSandboxPackageInfo verbosity
                               configFlags globalFlags
                               comp platform progdb sandboxDir
                               (\spi -> cont (Just spi))
  
  -- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that
  -- case.
  maybeReinstallAddSourceDeps :: Verbosity
                                 -> Flag (Maybe Int) -- ^ The '-j' flag
                                 -> ConfigFlags      -- ^ Saved configure flags
                                                     -- (from dist/setup-config)
                                 -> GlobalFlags
                                 -> (UseSandbox, SavedConfig)
                                 -> IO WereDepsReinstalled
  maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags'
                              globalFlags' (useSandbox, config) = do
    case useSandbox of
      NoSandbox             -> return NoDepsReinstalled
      UseSandbox sandboxDir -> do
        -- Reinstall the modified add-source deps.
        let configFlags    = savedConfigureFlags config
                             `mappendSomeSavedFlags`
                             configFlags'
            configExFlags  = defaultConfigExFlags
                             `mappend` savedConfigureExFlags config
            installFlags'  = defaultInstallFlags
                             `mappend` savedInstallFlags config
            installFlags   = installFlags' {
              installNumJobs    = installNumJobs installFlags'
                                  `mappend` numJobsFlag
              }
            globalFlags    = savedGlobalFlags config
            -- This makes it possible to override things like 'remote-repo-cache'
            -- from the command line. These options are hidden, and are only
            -- useful for debugging, so this should be fine.
                             `mappend` globalFlags'
        reinstallAddSourceDeps
          verbosity configFlags configExFlags
          installFlags globalFlags sandboxDir
  
    where
  
      -- NOTE: we can't simply do @sandboxConfigFlags `mappend` savedFlags@
      -- because we don't want to auto-enable things like 'library-profiling' for
      -- all add-source dependencies even if the user has passed
      -- '--enable-library-profiling' to 'cabal configure'. These options are
      -- supposed to be set in 'cabal.config'.
      mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags
      mappendSomeSavedFlags sandboxConfigFlags savedFlags =
        sandboxConfigFlags {
          configHcFlavor     = configHcFlavor sandboxConfigFlags
                               `mappend` configHcFlavor savedFlags,
          configHcPath       = configHcPath sandboxConfigFlags
                               `mappend` configHcPath savedFlags,
          configHcPkg        = configHcPkg sandboxConfigFlags
                               `mappend` configHcPkg savedFlags,
          configProgramPaths = configProgramPaths sandboxConfigFlags
                               `mappend` configProgramPaths savedFlags,
          configProgramArgs  = configProgramArgs sandboxConfigFlags
                               `mappend` configProgramArgs savedFlags,
          -- NOTE: Unconditionally choosing the value from
          -- 'dist/setup-config'. Sandbox package DB location may have been
          -- changed by 'configure -w'.
          configPackageDBs   = configPackageDBs savedFlags
          -- FIXME: Is this compatible with the 'inherit' feature?
          }
  
  --
  -- Utils (transitionary)
  --
  
  -- | Try to read the most recently configured compiler from the
  -- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it
  -- cannot be read.
  getPersistOrConfigCompiler :: ConfigFlags
                             -> IO (Compiler, Platform, ProgramDb)
  getPersistOrConfigCompiler configFlags = do
    distPref <- findDistPrefOrDefault (configDistPref configFlags)
    mlbi <- maybeGetPersistBuildConfig distPref
    case mlbi of
      Nothing  -> do configCompilerAux' configFlags
      Just lbi -> return ( LocalBuildInfo.compiler lbi
                         , LocalBuildInfo.hostPlatform lbi
                         , LocalBuildInfo.withPrograms lbi
                         )
  