Merge sandbox UI changes

The standard commands (e.g. configure, build) now use the sandbox, if
present.

Author: tibbe

cabal-install/Distribution/Client/Index.hs

@@ -8,27 +8,24 @@
 -----------------------------------------------------------------------------
 
 module Distribution.Client.Index (
-    index,
-
     createEmpty,
     addBuildTreeRefs,
     removeBuildTreeRefs,
     listBuildTreeRefs,
+    validateIndexPath,
 
     defaultIndexFileName
   ) where
 
 import qualified Distribution.Client.Tar as Tar
 import Distribution.Client.IndexUtils ( getSourcePackages )
 import Distribution.Client.PackageIndex ( allPackages )
-import Distribution.Client.Setup ( IndexFlags(..) )
 import Distribution.Client.Types ( Repo(..), LocalRepo(..)
                                  , SourcePackageDb(..)
                                  , SourcePackage(..), PackageLocation(..) )
 import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString
                                  , makeAbsoluteToCwd )
 
-import Distribution.Simple.Setup ( fromFlagOrDefault )
 import Distribution.Simple.Utils ( die, debug, info, findPackageDesc )
 import Distribution.Verbosity    ( Verbosity )
 
@@ -52,34 +49,6 @@ newtype BuildTreeRef = BuildTreeRef {
 defaultIndexFileName :: FilePath
 defaultIndexFileName = "00-index.tar"
 
--- | Entry point for the 'cabal index' command.
-index :: Verbosity -> IndexFlags -> FilePath -> IO ()
-index verbosity indexFlags path' = do
-  let runInit         = fromFlagOrDefault False (indexInit indexFlags)
-  let refsToAdd       = indexLinkSource indexFlags
-  let runLinkSource   = not . null $ refsToAdd
-  let refsToRemove    = indexRemoveSource indexFlags
-  let runRemoveSource = not . null $ refsToRemove
-  let runList         = fromFlagOrDefault False (indexList indexFlags)
-
-  unless (or [runInit, runLinkSource, runRemoveSource, runList]) $
-    die "no arguments passed to the 'index' command"
-
-  path <- validateIndexPath path'
-
-  when runInit $
-    createEmpty verbosity path
-
-  when runLinkSource $
-    addBuildTreeRefs verbosity path refsToAdd
-
-  when runRemoveSource $
-    removeBuildTreeRefs verbosity path refsToRemove
-
-  when runList $ do
-    refs <- listBuildTreeRefs verbosity path
-    mapM_ putStrLn refs
-
 -- | Given a path, ensure that it refers to a local build tree.
 buildTreeRefFromPath :: FilePath -> IO (Maybe BuildTreeRef)
 buildTreeRefFromPath dir = do

cabal-install/Distribution/Client/PackageEnvironment.hs

@@ -11,12 +11,15 @@
 module Distribution.Client.PackageEnvironment (
     PackageEnvironment(..)
   , IncludeComments(..)
+  , PackageEnvironmentType(..)
+  , classifyPackageEnvironment
   , createPackageEnvironment
   , tryLoadPackageEnvironment
   , readPackageEnvironmentFile
   , showPackageEnvironment
   , showPackageEnvironmentWithComments
   , setPackageDB
+  , loadUserConfig
 
   , basePackageEnvironment
   , initialPackageEnvironment
@@ -49,7 +52,7 @@ import Control.Monad                   ( foldM, when )
 import Data.List                       ( partition )
 import Data.Monoid                     ( Monoid(..) )
 import Distribution.Compat.Exception   ( catchIO )
-import System.Directory                ( renameFile )
+import System.Directory                ( doesFileExist, renameFile )
 import System.FilePath                 ( (<.>), (</>) )
 import System.IO.Error                 ( isDoesNotExistError )
 import Text.PrettyPrint                ( ($+$) )
@@ -67,6 +70,8 @@ import qualified Distribution.Text         as Text
 -- TODO: would be nice to remove duplication between D.C.PackageEnvironment and
 -- D.C.Config.
 data PackageEnvironment = PackageEnvironment {
+  -- The 'inherit' feature is not used ATM, but could be useful in the future
+  -- for constructing nested sandboxes (see discussion in #1196).
   pkgEnvInherit       :: Flag FilePath,
   pkgEnvSavedConfig   :: SavedConfig
 }
@@ -94,6 +99,25 @@ sandboxPackageEnvironmentFile = "cabal.sandbox.config"
 userPackageEnvironmentFile :: FilePath
 userPackageEnvironmentFile = "cabal.config"
 
+-- | Type of the current package environment.
+data PackageEnvironmentType =
+  SandboxPackageEnvironment   -- ^ './cabal.sandbox.config'
+  | UserPackageEnvironment    -- ^ './cabal.config'
+  | AmbientPackageEnvironment -- ^ '~/.cabal/config'
+
+-- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this
+-- directory?
+classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
+classifyPackageEnvironment pkgEnvDir = do
+  isSandbox <- configExists sandboxPackageEnvironmentFile
+  isUser    <- configExists userPackageEnvironmentFile
+  case (isSandbox, isUser) of
+    (True,  _)     -> return SandboxPackageEnvironment
+    (False, True)  -> return UserPackageEnvironment
+    (False, False) -> return AmbientPackageEnvironment
+  where
+    configExists fname = doesFileExist (pkgEnvDir </> fname)
+
 -- | Defaults common to 'initialPackageEnvironment' and
 -- 'commentPackageEnvironment'.
 commonPackageEnvironmentConfig :: FilePath -> SavedConfig
@@ -233,6 +257,11 @@ userPackageEnvironment verbosity pkgEnvDir = do
         ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
       return mempty
 
+-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.
+loadUserConfig :: Verbosity -> FilePath -> IO SavedConfig
+loadUserConfig verbosity pkgEnvDir = fmap pkgEnvSavedConfig
+                                     $ userPackageEnvironment verbosity pkgEnvDir
+
 -- | Try to load the package environment file ("cabal.sandbox.config"), exiting
 -- with error if it doesn't exist. Also returns the path to the sandbox
 -- directory. Note that the path parameter should be a name of an existing
@@ -265,6 +294,7 @@ tryLoadPackageEnvironment verbosity pkgEnvDir configFileFlag = do
   user      <- userPackageEnvironment verbosity pkgEnvDir
   inherited <- inheritedPackageEnvironment verbosity user
 
+  -- Layer the package environment settings over settings from ~/.cabal/config.
   cabalConfig <- loadConfig verbosity configFileFlag NoFlag
   return (sandboxDir,
           base `mappend` (cabalConfig `overrideSandboxSettings`