Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

383 lines (346 sloc) 16.335 kB
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.PackageEnvironment
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Utilities for working with the package environment file. Patterned after
-- Distribution.Client.Config.
-----------------------------------------------------------------------------
module Distribution.Client.PackageEnvironment (
PackageEnvironment(..)
, createPackageEnvironment
, tryLoadPackageEnvironment
, readPackageEnvironmentFile
, showPackageEnvironment
, showPackageEnvironmentWithComments
, setPackageDB
, basePackageEnvironment
, initialPackageEnvironment
, commentPackageEnvironment
, sandboxPackageEnvironmentFile
, userPackageEnvironmentFile
) where
import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig,
loadConfig, configFieldDescriptions,
installDirsFields, defaultCompiler )
import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..)
, InstallFlags(..)
, defaultSandboxLocation )
import Distribution.Simple.Compiler ( Compiler, PackageDB(..)
, showCompilerId )
import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate,
fromPathTemplate, toPathTemplate )
import Distribution.Simple.Setup ( Flag(..), ConfigFlags(..),
fromFlagOrDefault, toFlag )
import Distribution.Simple.Utils ( die, notice, warn, lowercase )
import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..),
commaListField,
liftField, lineNo, locatedErrorMsg,
parseFilePathQ, readFields,
showPWarning, simpleField, warning )
import Distribution.Verbosity ( Verbosity, normal )
import Control.Monad ( foldM, when )
import Data.List ( partition )
import Data.Monoid ( Monoid(..) )
import Distribution.Compat.Exception ( catchIO )
import System.Directory ( renameFile )
import System.FilePath ( (<.>), (</>) )
import System.IO.Error ( isDoesNotExistError )
import Text.PrettyPrint ( ($+$) )
import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import qualified Distribution.ParseUtils as ParseUtils ( Field(..) )
import qualified Distribution.Text as Text
--
-- * Configuration saved in the package environment file
--
-- TODO: would be nice to remove duplication between D.C.PackageEnvironment and
-- D.C.Config.
data PackageEnvironment = PackageEnvironment {
pkgEnvInherit :: Flag FilePath,
pkgEnvSavedConfig :: SavedConfig
}
instance Monoid PackageEnvironment where
mempty = PackageEnvironment {
pkgEnvInherit = mempty,
pkgEnvSavedConfig = mempty
}
mappend a b = PackageEnvironment {
pkgEnvInherit = combine pkgEnvInherit,
pkgEnvSavedConfig = combine pkgEnvSavedConfig
}
where
combine f = f a `mappend` f b
-- | The automatically-created package environment file that should not be
-- touched by the user.
sandboxPackageEnvironmentFile :: FilePath
sandboxPackageEnvironmentFile = "cabal.sandbox.config"
-- | Optional package environment file that can be used to customize the default
-- settings. Created by the user.
userPackageEnvironmentFile :: FilePath
userPackageEnvironmentFile = "cabal.config"
-- | Defaults common to 'initialPackageEnvironment' and
-- 'commentPackageEnvironment'.
commonPackageEnvironmentConfig :: FilePath -> SavedConfig
commonPackageEnvironmentConfig sandboxDir =
mempty {
savedConfigureFlags = mempty {
configUserInstall = toFlag True,
configInstallDirs = sandboxInstallDirs
},
savedUserInstallDirs = sandboxInstallDirs,
savedGlobalInstallDirs = sandboxInstallDirs,
savedGlobalFlags = mempty {
globalLogsDir = toFlag $ sandboxDir </> "logs",
-- Is this right? cabal-dev uses the global world file.
globalWorldFile = toFlag $ sandboxDir </> "world"
}
}
where
sandboxInstallDirs = mempty { prefix = toFlag (toPathTemplate sandboxDir) }
-- | These are the absolute basic defaults, the fields that must be
-- initialised. When we load the package environment from the file we layer the
-- loaded values over these ones.
basePackageEnvironment :: FilePath -> PackageEnvironment
basePackageEnvironment sandboxDir = do
let baseConf = commonPackageEnvironmentConfig sandboxDir in
mempty {
pkgEnvSavedConfig = baseConf {
savedConfigureFlags = (savedConfigureFlags baseConf) {
configHcFlavor = toFlag defaultCompiler,
configVerbosity = toFlag normal
}
}
}
-- | Initial configuration that we write out to the package environment file if
-- it does not exist. When the package environment gets loaded this
-- configuration gets layered on top of 'basePackageEnvironment'.
initialPackageEnvironment :: FilePath -> Compiler -> SavedConfig
-> IO PackageEnvironment
initialPackageEnvironment sandboxDir compiler userConfig = do
let commonConfig = commonPackageEnvironmentConfig sandboxDir
initialConfig = userConfig `mappend` commonConfig
return $ mempty {
pkgEnvSavedConfig = initialConfig {
savedGlobalFlags = (savedGlobalFlags initialConfig) {
globalLocalRepos = [sandboxDir </> "packages"]
},
savedConfigureFlags = setPackageDB sandboxDir compiler
(savedConfigureFlags initialConfig),
savedInstallFlags = (savedInstallFlags initialConfig) {
installSummaryFile = [toPathTemplate (sandboxDir </>
"logs" </> "build.log")]
}
}
}
-- | Use the package DB location specific for this compiler.
setPackageDB :: FilePath -> Compiler -> ConfigFlags -> ConfigFlags
setPackageDB sandboxDir compiler configFlags =
configFlags {
configPackageDBs = [Just (SpecificPackageDB $ sandboxDir
</> (showCompilerId compiler ++
"-packages.conf.d"))]
}
-- | Default values that get used if no value is given. Used here to include in
-- comments when we write out the initial package environment.
commentPackageEnvironment :: FilePath -> IO PackageEnvironment
commentPackageEnvironment sandboxDir = do
commentConf <- commentSavedConfig
let baseConf = commonPackageEnvironmentConfig sandboxDir
return $ mempty {
pkgEnvSavedConfig = commentConf `mappend` baseConf
}
-- | Return the base package environment: settings from the config file this
-- package environment optionally inherits from layered on top of
-- `basePackageEnvironment`.
basePkgEnv :: Verbosity -> FilePath -> (Flag FilePath) -> IO PackageEnvironment
basePkgEnv verbosity sandboxDir inheritConfig = do
let base = basePackageEnvironment sandboxDir
baseConf = pkgEnvSavedConfig base
-- Does this package environment inherit from some config file?
case inheritConfig of
NoFlag -> return base
(Flag confPath) -> do
conf <- loadConfig verbosity (Flag confPath) NoFlag
return $ base { pkgEnvSavedConfig = baseConf `mappend` conf }
-- | Load the user package environment if it exists (the optional "cabal.config"
-- file).
userPkgEnv :: Verbosity -> FilePath -> IO PackageEnvironment
userPkgEnv verbosity pkgEnvDir = do
let path = pkgEnvDir </> userPackageEnvironmentFile
minp <- readPackageEnvironmentFile mempty path
case minp of
Nothing -> return mempty
Just (ParseOk warns parseResult) -> do
when (not $ null warns) $ warn verbosity $
unlines (map (showPWarning path) warns)
return parseResult
Just (ParseFailed err) -> do
let (line, msg) = locatedErrorMsg err
warn verbosity $ "Error parsing user package environment file " ++ path
++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
return mempty
-- | 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
-- directory.
tryLoadPackageEnvironment :: Verbosity -> FilePath
-> IO (FilePath, PackageEnvironment)
tryLoadPackageEnvironment verbosity pkgEnvDir = do
let path = pkgEnvDir </> sandboxPackageEnvironmentFile
minp <- readPackageEnvironmentFile mempty path
pkgEnv <- case minp of
Nothing -> die $
"The package environment file '" ++ path ++ "' doesn't exist"
Just (ParseOk warns parseResult) -> do
when (not $ null warns) $ warn verbosity $
unlines (map (showPWarning path) warns)
return parseResult
Just (ParseFailed err) -> do
let (line, msg) = locatedErrorMsg err
die $ "Error parsing package environment file " ++ path
++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
user <- userPkgEnv verbosity pkgEnvDir
-- Get the saved sandbox directory.
-- TODO: Use substPathTemplate instead of fromPathTemplate.
let sandboxDir = fromFlagOrDefault defaultSandboxLocation
. fmap fromPathTemplate . prefix . savedGlobalInstallDirs
. pkgEnvSavedConfig $ pkgEnv
base <- basePkgEnv verbosity sandboxDir (pkgEnvInherit pkgEnv)
return (sandboxDir, base `mappend` user `mappend` pkgEnv)
-- | Create a new package environment file, replacing the existing one if it
-- exists. Note that the path parameters should point to existing directories.
createPackageEnvironment :: Verbosity -> FilePath -> FilePath
-> Compiler -> SavedConfig
-> IO PackageEnvironment
createPackageEnvironment verbosity sandboxDir pkgEnvDir compiler userConfig = do
let path = pkgEnvDir </> sandboxPackageEnvironmentFile
notice verbosity $ "Writing default package environment to " ++ path
commentPkgEnv <- commentPackageEnvironment sandboxDir
initialPkgEnv <- initialPackageEnvironment sandboxDir compiler userConfig
writePackageEnvironmentFile path commentPkgEnv initialPkgEnv
user <- userPkgEnv verbosity pkgEnvDir
base <- basePkgEnv verbosity sandboxDir (pkgEnvInherit initialPkgEnv)
return $ base `mappend` user `mappend` initialPkgEnv
-- | Descriptions of all fields in the package environment file.
pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs = [
simpleField "inherit"
(fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)
pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })
-- FIXME: Should we make these fields part of ~/.cabal/config ?
, commaListField "constraints"
Text.disp Text.parse
(configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)
(\v pkgEnv -> updateConfigureExFlags pkgEnv
(\flags -> flags { configExConstraints = v }))
, commaListField "preferences"
Text.disp Text.parse
(configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)
(\v pkgEnv -> updateConfigureExFlags pkgEnv
(\flags -> flags { configPreferences = v }))
]
++ map toPkgEnv configFieldDescriptions'
where
optional = Parse.option mempty . fmap toFlag
configFieldDescriptions' :: [FieldDescr SavedConfig]
configFieldDescriptions' = filter
(\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")
configFieldDescriptions
toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv fieldDescr =
liftField pkgEnvSavedConfig
(\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})
fieldDescr
updateConfigureExFlags :: PackageEnvironment
-> (ConfigExFlags -> ConfigExFlags)
-> PackageEnvironment
updateConfigureExFlags pkgEnv f = pkgEnv {
pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {
savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig
$ pkgEnv
}
}
-- | Read the package environment file.
readPackageEnvironmentFile :: PackageEnvironment -> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile initial file =
handleNotExists $
fmap (Just . parsePackageEnvironment initial) (readFile file)
where
handleNotExists action = catchIO action $ \ioe ->
if isDoesNotExistError ioe
then return Nothing
else ioError ioe
-- | Parse the package environment file.
parsePackageEnvironment :: PackageEnvironment -> String
-> ParseResult PackageEnvironment
parsePackageEnvironment initial str = do
fields <- readFields str
let (knownSections, others) = partition isKnownSection fields
pkgEnv <- parse others
let config = pkgEnvSavedConfig pkgEnv
installDirs0 = savedUserInstallDirs config
-- 'install-dirs' is the only section that we care about.
installDirs <- foldM parseSection installDirs0 knownSections
return pkgEnv {
pkgEnvSavedConfig = config {
savedUserInstallDirs = installDirs,
savedGlobalInstallDirs = installDirs
}
}
where
isKnownSection :: ParseUtils.Field -> Bool
isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
isKnownSection _ = False
parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment
parse = parseFields pkgEnvFieldDescrs initial
parseSection :: InstallDirs (Flag PathTemplate)
-> ParseUtils.Field
-> ParseResult (InstallDirs (Flag PathTemplate))
parseSection accum (ParseUtils.Section _ "install-dirs" name fs)
| name' == "" = do accum' <- parseFields installDirsFields accum fs
return accum'
| otherwise = do warning "The install-dirs section should be unnamed"
return accum
where name' = lowercase name
parseSection accum f = do
warning $ "Unrecognized stanza on line " ++ show (lineNo f)
return accum
-- | Write out the package environment file.
writePackageEnvironmentFile :: FilePath -> PackageEnvironment
-> PackageEnvironment -> IO ()
writePackageEnvironmentFile path comments pkgEnv = do
let tmpPath = (path <.> "tmp")
writeFile tmpPath $ explanation
++ showPackageEnvironmentWithComments comments pkgEnv ++ "\n"
renameFile tmpPath path
where
explanation = unlines
["-- This is a Cabal package environment file."
,"-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY."
,"-- Please create a 'cabal.config' file in the same directory"
,"-- if you want to change the default settings for this sandbox."
,""
,"-- The available configuration options are listed below."
,"-- Some of them have default values listed."
,""
,"-- Lines (like this one) beginning with '--' are comments."
,"-- Be careful with spaces and indentation because they are"
,"-- used to indicate layout for nested sections."
,"",""
]
-- | Pretty-print the package environment data.
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment = showPackageEnvironmentWithComments mempty
showPackageEnvironmentWithComments :: PackageEnvironment -> PackageEnvironment
-> String
showPackageEnvironmentWithComments defPkgEnv pkgEnv = Disp.render $
ppFields pkgEnvFieldDescrs defPkgEnv pkgEnv
$+$ Disp.text ""
$+$ ppSection "install-dirs" "" installDirsFields
(field defPkgEnv) (field pkgEnv)
where
field = savedUserInstallDirs . pkgEnvSavedConfig
Jump to Line
Something went wrong with that request. Please try again.