Commit a5c1f21b authored by refold's avatar refold
Browse files

More sensible default package environment.

parent b4f1ece7
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment