Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

More sensible default package environment.

  • Loading branch information...
commit a5c1f21b9807aaf3e56778a789ec848a18cbc444 1 parent b4f1ece
@23Skidoo 23Skidoo authored
Showing with 78 additions and 31 deletions.
  1. +78 −31 cabal-install/Distribution/Client/PackageEnvironment.hs
View
109 cabal-install/Distribution/Client/PackageEnvironment.hs
@@ -19,9 +19,13 @@ import Distribution.Client.Config ( SavedConfig(..), baseSavedConfig,
configFieldDescriptions,
installDirsFields )
import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
-import Distribution.Client.Setup ( SandboxFlags(..) )
-import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate )
-import Distribution.Simple.Setup ( Flag(..), fromFlagOrDefault, toFlag )
+import Distribution.Client.Setup ( GlobalFlags(..), InstallFlags(..),
+ SandboxFlags(..) )
+import Distribution.Simple.Compiler ( PackageDB(..) )
+import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate,
+ toPathTemplate )
+import Distribution.Simple.Setup ( Flag(..), ConfigFlags(..),
+ fromFlagOrDefault, toFlag )
import Distribution.Simple.Utils ( notice, warn, lowercase )
import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..),
liftField, lineNo, locatedErrorMsg,
@@ -34,7 +38,7 @@ import Data.Monoid ( Monoid(..) )
import Distribution.Compat.Exception ( catchIO )
import System.Directory ( canonicalizePath,
createDirectoryIfMissing, renameFile )
-import System.FilePath ( (<.>), takeDirectory )
+import System.FilePath ( (<.>), (</>), takeDirectory )
import System.IO.Error ( isDoesNotExistError )
import Text.PrettyPrint ( ($+$) )
@@ -47,7 +51,7 @@ import qualified Distribution.ParseUtils as ParseUtils ( Field(..) )
-- * Configuration saved in the package environment file
--
--- TODO: better defaults, constraints field (really needed? there is already
+-- TODO: add a 'constraints' field (really needed? there is already
-- 'constraint'), remove duplication between D.C.PackageEnvironment and
-- D.C.Config
data PackageEnvironment = PackageEnvironment {
@@ -69,10 +73,27 @@ instance Monoid PackageEnvironment where
combine f = f a `mappend` f b
-- | Values that *must* be initialised.
-basePackageEnvironment :: IO PackageEnvironment
-basePackageEnvironment = do
+basePackageEnvironment :: FilePath -> IO PackageEnvironment
+basePackageEnvironment pkgEnvDir = do
baseConf <- baseSavedConfig
- return $ mempty { pkgEnvSavedConfig = baseConf }
+ return $ mempty {
+ pkgEnvSavedConfig = baseConf {
+ savedConfigureFlags = (savedConfigureFlags baseConf) {
+ configUserInstall = toFlag False
+ },
+ savedUserInstallDirs = (savedUserInstallDirs baseConf) {
+ prefix = toFlag (toPathTemplate pkgEnvDir)
+ },
+ savedGlobalInstallDirs = (savedGlobalInstallDirs baseConf) {
+ prefix = toFlag (toPathTemplate pkgEnvDir)
+ },
+ savedGlobalFlags = (savedGlobalFlags baseConf) {
+ globalLogsDir = toFlag $ pkgEnvDir </> "logs",
+ -- TODO: cabal-dev uses the global world file: is this right?
+ globalWorldFile = toFlag $ pkgEnvDir </> "world"
+ }
+ }
+ }
-- | Initial configuration that we write out to the package environment file if
-- it does not exist. When the package environment gets loaded it gets layered
@@ -80,7 +101,31 @@ basePackageEnvironment = do
initialPackageEnvironment :: FilePath -> IO PackageEnvironment
initialPackageEnvironment pkgEnvDir = do
initialConf <- initialSavedConfig
- return $ mempty { pkgEnvSavedConfig = initialConf }
+ return $ mempty {
+ pkgEnvSavedConfig = initialConf {
+ savedUserInstallDirs = (savedUserInstallDirs initialConf) {
+ prefix = toFlag (toPathTemplate pkgEnvDir)
+ },
+ savedGlobalInstallDirs = (savedGlobalInstallDirs initialConf) {
+ prefix = toFlag (toPathTemplate pkgEnvDir)
+ },
+ savedGlobalFlags = (savedGlobalFlags initialConf) {
+ globalLocalRepos = [pkgEnvDir </> "packages"],
+ -- TODO: cabal-dev uses the global world file: is this right?
+ globalWorldFile = toFlag $ pkgEnvDir </> "world"
+ },
+ savedConfigureFlags = (savedConfigureFlags initialConf) {
+ configUserInstall = toFlag False,
+ -- TODO: This should include comp. flavor and version
+ configPackageDBs = [Just (SpecificPackageDB $ pkgEnvDir
+ </> "packages.conf.d")]
+ },
+ savedInstallFlags = (savedInstallFlags initialConf) {
+ installSummaryFile = [toPathTemplate (pkgEnvDir </>
+ "logs" </> "build.log")]
+ }
+ }
+ }
-- | Default values that get used if no value is given. Used here to include in
-- comments when we write out the initial package environment.
@@ -97,30 +142,32 @@ dumpPackageEnvironment verbosity sandboxFlags path = do
-- | Load the package environment file, creating it if doesn't exist.
loadPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment
-loadPackageEnvironment verbosity path = addBasePkgEnv $ do
+loadPackageEnvironment verbosity path = do
pkgEnvDir <- canonicalizePath . takeDirectory $ path
- minp <- readPackageEnvironmentFile mempty path
- case minp of
- Nothing -> do
- notice verbosity $ "Writing default package environment to " ++ path
- commentPkgEnv <- commentPackageEnvironment pkgEnvDir
- initialPkgEnv <- initialPackageEnvironment pkgEnvDir
- writePackageEnvironmentFile path commentPkgEnv initialPkgEnv
- return initialPkgEnv
- Just (ParseOk warns pkgEnv) -> do
- when (not $ null warns) $ warn verbosity $
- unlines (map (showPWarning path) warns)
- return pkgEnv
- Just (ParseFailed err) -> do
- let (line, msg) = locatedErrorMsg err
- warn verbosity $
- "Error parsing package environment file " ++ path
- ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
- warn verbosity $ "Using default package environment."
- initialPackageEnvironment pkgEnvDir
+ addBasePkgEnv pkgEnvDir $ do
+ minp <- readPackageEnvironmentFile mempty path
+ case minp of
+ Nothing -> do
+ notice verbosity $ "Writing default package environment to " ++ path
+ commentPkgEnv <- commentPackageEnvironment pkgEnvDir
+ initialPkgEnv <- initialPackageEnvironment pkgEnvDir
+ writePackageEnvironmentFile path commentPkgEnv initialPkgEnv
+ return initialPkgEnv
+ Just (ParseOk warns pkgEnv) -> do
+ when (not $ null warns) $ warn verbosity $
+ unlines (map (showPWarning path) warns)
+ return pkgEnv
+ Just (ParseFailed err) -> do
+ let (line, msg) = locatedErrorMsg err
+ warn verbosity $
+ "Error parsing package environment file " ++ path
+ ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
+ warn verbosity $ "Using default package environment."
+ initialPackageEnvironment pkgEnvDir
where
- addBasePkgEnv body = do
- base <- basePackageEnvironment
+ addBasePkgEnv :: FilePath -> IO PackageEnvironment -> IO PackageEnvironment
+ addBasePkgEnv pkgEnvDir body = do
+ base <- basePackageEnvironment pkgEnvDir
extra <- body
return $ base `mappend` extra
Please sign in to comment.
Something went wrong with that request. Please try again.