Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'master' of github.com:haskell/cabal

  • Loading branch information...
commit 43af8a442407cf5fcecef09e411385ab0b75b328 2 parents ffa24d5 + 5ced794
@igfoo igfoo authored
View
2  Cabal/Cabal.cabal
@@ -46,7 +46,7 @@ Library
if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }
if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }
if flag(base3)
- Build-Depends: directory >= 1 && < 1.2,
+ Build-Depends: directory >= 1 && < 1.3,
process >= 1 && < 1.2,
old-time >= 1 && < 1.2,
containers >= 0.1 && < 0.6,
View
62 cabal-install/Distribution/Client/Config.hs
@@ -8,7 +8,8 @@
-- Stability : provisional
-- Portability : portable
--
--- Utilities for handling saved state such as known packages, known servers and downloaded packages.
+-- Utilities for handling saved state such as known packages, known servers and
+-- downloaded packages.
-----------------------------------------------------------------------------
module Distribution.Client.Config (
SavedConfig(..),
@@ -21,7 +22,14 @@ module Distribution.Client.Config (
defaultCabalDir,
defaultConfigFile,
defaultCacheDir,
+ defaultCompiler,
defaultLogsDir,
+
+ baseSavedConfig,
+ commentSavedConfig,
+ initialSavedConfig,
+ configFieldDescriptions,
+ installDirsFields
) where
@@ -54,6 +62,8 @@ import Distribution.ParseUtils
, locatedErrorMsg, showPWarning
, readFields, warning, lineNo
, simpleField, listField, parseFilePathQ, parseTokenQ )
+import Distribution.Client.ParseUtils
+ ( parseFields, ppFields, ppSection )
import qualified Distribution.ParseUtils as ParseUtils
( Field(..) )
import qualified Distribution.Text as Text
@@ -78,19 +88,18 @@ import Data.Monoid
( Monoid(..) )
import Control.Monad
( when, foldM, liftM )
-import qualified Data.Map as Map
import qualified Distribution.Compat.ReadP as Parse
( option )
import qualified Text.PrettyPrint as Disp
- ( Doc, render, text, colon, vcat, empty, isEmpty, nest )
+ ( render, text, empty )
import Text.PrettyPrint
- ( (<>), (<+>), ($$), ($+$) )
+ ( ($+$) )
import System.Directory
- ( createDirectoryIfMissing, getAppUserDataDirectory )
+ ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile )
import Network.URI
( URI(..), URIAuth(..) )
import System.FilePath
- ( (</>), takeDirectory )
+ ( (<.>), (</>), takeDirectory )
import System.Environment
( getEnvironment )
import System.IO.Error
@@ -303,8 +312,10 @@ readConfigFile initial file = handleNotExists $
writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
writeConfigFile file comments vals = do
+ let tmpFile = file <.> "tmp"
createDirectoryIfMissing True (takeDirectory file)
- writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"
+ writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n"
+ renameFile tmpFile file
where
explanation = unlines
["-- This is the configuration file for the 'cabal' command line tool."
@@ -528,42 +539,5 @@ showConfigWithComments comment vals = Disp.render $
ppSection "install-dirs" name installDirsFields
(field comment) (field vals)
-------------------------
--- * Parsing utils
---
-
---FIXME: replace this with something better in Cabal-1.5
-parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a
-parseFields fields initial = foldM setField initial
- where
- fieldMap = Map.fromList
- [ (name, f) | f@(FieldDescr name _ _) <- fields ]
- setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of
- Just (FieldDescr _ _ set) -> set line value accum
- Nothing -> do
- warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
- return accum
- setField accum f = do
- warning $ "Unrecognized stanza on line " ++ show (lineNo f)
- return accum
-
--- | This is a customised version of the function from Cabal that also prints
--- default values for empty fields as comments.
---
-ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc
-ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)
- | FieldDescr name getter _ <- fields]
-
-ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc
-ppField name def cur
- | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def
- | otherwise = Disp.text name <> Disp.colon <+> cur
-
-ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc
-ppSection name arg fields def cur =
- Disp.text name <+> Disp.text arg
- $$ Disp.nest 2 (ppFields fields def cur)
-
installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions
-
View
319 cabal-install/Distribution/Client/PackageEnvironment.hs
@@ -0,0 +1,319 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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(..),
+ loadPackageEnvironment,
+ showPackageEnvironment,
+ showPackageEnvironmentWithComments,
+
+ basePackageEnvironment,
+ initialPackageEnvironment,
+ commentPackageEnvironment
+ ) where
+
+import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig,
+ initialSavedConfig, loadConfig,
+ configFieldDescriptions,
+ installDirsFields, defaultCompiler )
+import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
+import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..)
+ , InstallFlags(..) )
+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(..),
+ 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
+
+defaultPackageEnvironmentFileName :: FilePath
+defaultPackageEnvironmentFileName = "pkgenv"
+
+-- | Defaults common to 'initialPackageEnvironment' and
+-- 'commentPackageEnvironment'.
+commonPackageEnvironmentConfig :: FilePath -> SavedConfig
+commonPackageEnvironmentConfig pkgEnvDir =
+ mempty {
+ savedConfigureFlags = mempty {
+ configUserInstall = toFlag False,
+ configInstallDirs = sandboxInstallDirs
+ },
+ savedUserInstallDirs = sandboxInstallDirs,
+ savedGlobalInstallDirs = sandboxInstallDirs,
+ savedGlobalFlags = mempty {
+ globalLogsDir = toFlag $ pkgEnvDir </> "logs",
+ -- Is this right? cabal-dev uses the global world file.
+ globalWorldFile = toFlag $ pkgEnvDir </> "world"
+ }
+ }
+ where
+ sandboxInstallDirs = mempty { prefix = toFlag (toPathTemplate pkgEnvDir) }
+
+-- | 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 pkgEnvDir = do
+ let baseConf = commonPackageEnvironmentConfig pkgEnvDir 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 it gets layered
+-- on top of 'basePackageEnvironment'.
+initialPackageEnvironment :: FilePath -> IO PackageEnvironment
+initialPackageEnvironment pkgEnvDir = do
+ initialConf' <- initialSavedConfig
+ let baseConf = commonPackageEnvironmentConfig pkgEnvDir
+ let initialConf = initialConf' `mappend` baseConf
+ return $ mempty {
+ pkgEnvSavedConfig = initialConf {
+ savedGlobalFlags = (savedGlobalFlags initialConf) {
+ globalLocalRepos = [pkgEnvDir </> "packages"]
+ },
+ savedConfigureFlags = (savedConfigureFlags initialConf) {
+ -- 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.
+commentPackageEnvironment :: FilePath -> IO PackageEnvironment
+commentPackageEnvironment pkgEnvDir = do
+ commentConf <- commentSavedConfig
+ let baseConf = commonPackageEnvironmentConfig pkgEnvDir
+ return $ mempty {
+ pkgEnvSavedConfig = commentConf `mappend` baseConf
+ }
+
+-- | Load the package environment file, creating it if doesn't exist. Note that
+-- the path parameter should be a name of an existing directory.
+loadPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment
+loadPackageEnvironment verbosity pkgEnvDir = do
+ let path = pkgEnvDir </> defaultPackageEnvironmentFileName
+ addBasePkgEnv $ 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 :: IO PackageEnvironment -> IO PackageEnvironment
+ addBasePkgEnv body = do
+ let base = basePackageEnvironment pkgEnvDir
+ extra <- body
+ case pkgEnvInherit extra of
+ NoFlag ->
+ return $ base `mappend` extra
+ (Flag confPath) -> do
+ conf <- loadConfig verbosity (Flag confPath) (Flag False)
+ let conf' = base `mappend` conf `mappend` (pkgEnvSavedConfig extra)
+ return $ extra { pkgEnvSavedConfig = conf' }
+
+-- | 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."
+ ,""
+ ,"-- 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
View
55 cabal-install/Distribution/Client/ParseUtils.hs
@@ -0,0 +1,55 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.ParseUtils
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Parsing utilities.
+-----------------------------------------------------------------------------
+
+module Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
+ where
+
+import Distribution.ParseUtils
+ ( FieldDescr(..), ParseResult(..), warning, lineNo )
+import qualified Distribution.ParseUtils as ParseUtils
+ ( Field(..) )
+
+import Control.Monad ( foldM )
+import Text.PrettyPrint ( (<>), (<+>), ($$) )
+import qualified Data.Map as Map
+import qualified Text.PrettyPrint as Disp
+ ( Doc, text, colon, vcat, isEmpty, nest )
+
+--FIXME: replace this with something better
+parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a
+parseFields fields initial = foldM setField initial
+ where
+ fieldMap = Map.fromList
+ [ (name, f) | f@(FieldDescr name _ _) <- fields ]
+ setField accum (ParseUtils.F line name value) =
+ case Map.lookup name fieldMap of
+ Just (FieldDescr _ _ set) -> set line value accum
+ Nothing -> do
+ warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
+ return accum
+ setField accum f = do
+ warning $ "Unrecognized stanza on line " ++ show (lineNo f)
+ return accum
+
+-- | This is a customised version of the function from Cabal that also prints
+-- default values for empty fields as comments.
+--
+ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc
+ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)
+ | FieldDescr name getter _ <- fields]
+
+ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc
+ppField name def cur
+ | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def
+ | otherwise = Disp.text name <> Disp.colon <+> cur
+
+ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc
+ppSection name arg fields def cur =
+ Disp.text name <+> Disp.text arg
+ $$ Disp.nest 2 (ppFields fields def cur)
View
4 cabal-install/cabal-install.cabal
@@ -88,8 +88,10 @@ Executable cabal
Distribution.Client.InstallPlan
Distribution.Client.InstallSymlink
Distribution.Client.List
+ Distribution.Client.PackageEnvironment
Distribution.Client.PackageIndex
Distribution.Client.PackageUtils
+ Distribution.Client.ParseUtils
Distribution.Client.Setup
Distribution.Client.SetupWrapper
Distribution.Client.SrcDist
@@ -120,7 +122,7 @@ Executable cabal
else
build-depends: base >= 3,
process >= 1 && < 1.2,
- directory >= 1 && < 1.2,
+ directory >= 1 && < 1.3,
pretty >= 1 && < 1.2,
random >= 1 && < 1.1,
containers >= 0.1 && < 0.6,
Please sign in to comment.
Something went wrong with that request. Please try again.