PackageEnvironment.hs 24.7 KB
Newer Older
1 2
{-# LANGUAGE DeriveGeneric #-}

3 4
-----------------------------------------------------------------------------
-- |
5
-- Module      :  Distribution.Client.Sandbox.PackageEnvironment
6 7 8 9 10 11 12
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Utilities for working with the package environment file. Patterned after
-- Distribution.Client.Config.
-----------------------------------------------------------------------------

13
module Distribution.Client.Sandbox.PackageEnvironment (
refold's avatar
refold committed
14
    PackageEnvironment(..)
15 16
  , PackageEnvironmentType(..)
  , classifyPackageEnvironment
17 18
  , createPackageEnvironmentFile
  , tryLoadSandboxPackageEnvironmentFile
refold's avatar
refold committed
19 20 21
  , readPackageEnvironmentFile
  , showPackageEnvironment
  , showPackageEnvironmentWithComments
22
  , setPackageDB
23
  , sandboxPackageDBPath
refold's avatar
refold committed
24
  , loadUserConfig
refold's avatar
refold committed
25 26 27 28

  , basePackageEnvironment
  , initialPackageEnvironment
  , commentPackageEnvironment
refold's avatar
refold committed
29 30
  , sandboxPackageEnvironmentFile
  , userPackageEnvironmentFile
refold's avatar
refold committed
31
  ) where
32

33 34
import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig
                                       , loadConfig, configFieldDescriptions
35
                                       , haddockFlagsFields
36 37 38
                                       , installDirsFields, withProgramsFields
                                       , withProgramOptionsFields
                                       , defaultCompiler )
39
import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )
40
import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)
refold's avatar
refold committed
41 42
                                       , InstallFlags(..)
                                       , defaultSandboxLocation )
43 44
import Distribution.Client.Targets     ( userConstraintPackageName )
import Distribution.Utils.NubList      ( toNubList )
45
import Distribution.Simple.Compiler    ( Compiler, PackageDB(..)
46
                                       , compilerFlavor, showCompilerIdWithAbi )
refold's avatar
refold committed
47
import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate
48
                                       , defaultInstallDirs, combineInstallDirs
refold's avatar
refold committed
49
                                       , fromPathTemplate, toPathTemplate )
50 51
import Distribution.Simple.Setup       ( Flag(..)
                                       , ConfigFlags(..), HaddockFlags(..)
52
                                       , fromFlagOrDefault, toFlag, flagToMaybe )
53
import Distribution.Simple.Utils       ( die, info, notice, warn, debug )
54
import Distribution.Solver.Types.ConstraintSource
55
import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..)
56
                                       , commaListField, commaNewLineListField
57 58
                                       , liftField, lineNo, locatedErrorMsg
                                       , parseFilePathQ, readFields
59 60
                                       , showPWarning, simpleField
                                       , syntaxError, warning )
61
import Distribution.System             ( Platform )
62
import Distribution.Verbosity          ( Verbosity, normal )
63
import Control.Monad                   ( foldM, liftM2, when, unless )
64
import Data.List                       ( partition, sortBy )
65
import Data.Maybe                      ( isJust )
66
import Data.Ord                        ( comparing )
67
import Distribution.Compat.Exception   ( catchIO )
68
import Distribution.Compat.Semigroup
69 70
import System.Directory                ( doesDirectoryExist, doesFileExist
                                       , renameFile )
71
import System.FilePath                 ( (<.>), (</>), takeDirectory )
72
import System.IO.Error                 ( isDoesNotExistError )
refold's avatar
refold committed
73
import Text.PrettyPrint                ( ($+$) )
74 75 76

import qualified Text.PrettyPrint          as Disp
import qualified Distribution.Compat.ReadP as Parse
77
import qualified Distribution.ParseUtils   as ParseUtils ( Field(..) )
78
import qualified Distribution.Text         as Text
79
import GHC.Generics ( Generic )
refold's avatar
refold committed
80

81

82 83 84 85
--
-- * Configuration saved in the package environment file
--

86 87
-- TODO: would be nice to remove duplication between
-- D.C.Sandbox.PackageEnvironment and D.C.Config.
88
data PackageEnvironment = PackageEnvironment {
refold's avatar
refold committed
89 90
  -- The 'inherit' feature is not used ATM, but could be useful in the future
  -- for constructing nested sandboxes (see discussion in #1196).
91 92
  pkgEnvInherit       :: Flag FilePath,
  pkgEnvSavedConfig   :: SavedConfig
93
} deriving Generic
94

95
instance Monoid PackageEnvironment where
96
  mempty = gmempty
97
  mappend = (<>)
98

99
instance Semigroup PackageEnvironment where
100
  (<>) = gmappend
101

102 103
-- | The automatically-created package environment file that should not be
-- touched by the user.
refold's avatar
refold committed
104 105
sandboxPackageEnvironmentFile :: FilePath
sandboxPackageEnvironmentFile = "cabal.sandbox.config"
106 107 108

-- | Optional package environment file that can be used to customize the default
-- settings. Created by the user.
refold's avatar
refold committed
109 110
userPackageEnvironmentFile :: FilePath
userPackageEnvironmentFile = "cabal.config"
111

refold's avatar
refold committed
112 113 114 115 116
-- | Type of the current package environment.
data PackageEnvironmentType =
  SandboxPackageEnvironment   -- ^ './cabal.sandbox.config'
  | UserPackageEnvironment    -- ^ './cabal.config'
  | AmbientPackageEnvironment -- ^ '~/.cabal/config'
117 118 119

-- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this
-- directory?
120
classifyPackageEnvironment :: FilePath -> Flag FilePath -> Flag Bool
121
                              -> IO PackageEnvironmentType
122 123 124 125 126
classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag ignoreSandboxFlag =
  do isSandbox <- liftM2 (||) (return forceSandboxConfig)
                  (configExists sandboxPackageEnvironmentFile)
     isUser    <- configExists userPackageEnvironmentFile
     return (classify isSandbox isUser)
127
  where
128 129 130 131 132 133 134 135 136
    configExists fname   = doesFileExist (pkgEnvDir </> fname)
    ignoreSandbox        = fromFlagOrDefault False ignoreSandboxFlag
    forceSandboxConfig   = isJust . flagToMaybe $ sandboxConfigFileFlag

    classify :: Bool -> Bool -> PackageEnvironmentType
    classify True _
      | not ignoreSandbox = SandboxPackageEnvironment
    classify _    True    = UserPackageEnvironment
    classify _    False   = AmbientPackageEnvironment
137

138 139
-- | Defaults common to 'initialPackageEnvironment' and
-- 'commentPackageEnvironment'.
refold's avatar
refold committed
140
commonPackageEnvironmentConfig :: FilePath -> SavedConfig
141
commonPackageEnvironmentConfig sandboxDir =
142 143
  mempty {
    savedConfigureFlags = mempty {
Mikhail Glushenkov's avatar
Typo.  
Mikhail Glushenkov committed
144
       -- TODO: Currently, we follow cabal-dev and set 'user-install: False' in
145 146 147
       -- the config file. In the future we may want to distinguish between
       -- global, sandbox and user install types.
       configUserInstall = toFlag False,
refold's avatar
refold committed
148
       configInstallDirs = installDirs
149
       },
refold's avatar
refold committed
150 151
    savedUserInstallDirs   = installDirs,
    savedGlobalInstallDirs = installDirs,
152
    savedGlobalFlags = mempty {
153
      globalLogsDir = toFlag $ sandboxDir </> "logs",
refold's avatar
refold committed
154
      -- Is this right? cabal-dev uses the global world file.
155
      globalWorldFile = toFlag $ sandboxDir </> "world"
156 157
      }
    }
158
  where
refold's avatar
refold committed
159
    installDirs = sandboxInstallDirs sandboxDir
160

refold's avatar
refold committed
161
-- | 'commonPackageEnvironmentConfig' wrapped inside a 'PackageEnvironment'.
162 163 164 165 166
commonPackageEnvironment :: FilePath -> PackageEnvironment
commonPackageEnvironment sandboxDir = mempty {
  pkgEnvSavedConfig = commonPackageEnvironmentConfig sandboxDir
  }

refold's avatar
refold committed
167 168 169 170 171 172
-- | Given a path to a sandbox, return the corresponding InstallDirs record.
sandboxInstallDirs :: FilePath -> InstallDirs (Flag PathTemplate)
sandboxInstallDirs sandboxDir = mempty {
  prefix = toFlag (toPathTemplate sandboxDir)
  }

173 174 175
-- | 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.
176 177
basePackageEnvironment :: PackageEnvironment
basePackageEnvironment =
178
    mempty {
179 180
      pkgEnvSavedConfig = mempty {
         savedConfigureFlags = mempty {
181 182 183
            configHcFlavor    = toFlag defaultCompiler,
            configVerbosity   = toFlag normal
            }
refold's avatar
refold committed
184
         }
185
      }
refold's avatar
refold committed
186 187

-- | Initial configuration that we write out to the package environment file if
refold's avatar
refold committed
188 189
-- it does not exist. When the package environment gets loaded this
-- configuration gets layered on top of 'basePackageEnvironment'.
190 191 192
initialPackageEnvironment :: FilePath -> Compiler -> Platform
                             -> IO PackageEnvironment
initialPackageEnvironment sandboxDir compiler platform = do
193 194
  defInstallDirs <- defaultInstallDirs (compilerFlavor compiler)
                    {- userInstall= -} False {- _hasLibs= -} False
195
  let initialConfig = commonPackageEnvironmentConfig sandboxDir
196 197
      installDirs   = combineInstallDirs (\d f -> Flag $ fromFlagOrDefault d f)
                      defInstallDirs (savedUserInstallDirs initialConfig)
198
  return $ mempty {
199
    pkgEnvSavedConfig = initialConfig {
200 201
       savedUserInstallDirs   = installDirs,
       savedGlobalInstallDirs = installDirs,
202
       savedGlobalFlags = (savedGlobalFlags initialConfig) {
203
          globalLocalRepos = toNubList [sandboxDir </> "packages"]
refold's avatar
refold committed
204
          },
205
       savedConfigureFlags = setPackageDB sandboxDir compiler platform
206 207
                             (savedConfigureFlags initialConfig),
       savedInstallFlags = (savedInstallFlags initialConfig) {
208
         installSummaryFile = toNubList [toPathTemplate (sandboxDir </>
refold's avatar
refold committed
209 210 211
                                               "logs" </> "build.log")]
         }
       }
212
    }
refold's avatar
refold committed
213

214
-- | Return the path to the sandbox package database.
215 216 217 218
sandboxPackageDBPath :: FilePath -> Compiler -> Platform -> String
sandboxPackageDBPath sandboxDir compiler platform =
    sandboxDir
         </> (Text.display platform ++ "-"
219
             ++ showCompilerIdWithAbi compiler
220
             ++ "-packages.conf.d")
221 222 223
-- The path in sandboxPackageDBPath should be kept in sync with the
-- path in the bootstrap.sh which is used to bootstrap cabal-install
-- into a sandbox.
224

refold's avatar
refold committed
225
-- | Use the package DB location specific for this compiler.
226 227
setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags
setPackageDB sandboxDir compiler platform configFlags =
refold's avatar
refold committed
228
  configFlags {
229 230 231 232
    configPackageDBs = [Just (SpecificPackageDB $ sandboxPackageDBPath
                                                      sandboxDir
                                                      compiler
                                                      platform)]
refold's avatar
refold committed
233 234
    }

235 236
-- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are
-- overridden instead of mappend'ed.
237
overrideSandboxSettings :: PackageEnvironment -> PackageEnvironment ->
238
                           PackageEnvironment
239
overrideSandboxSettings pkgEnv0 pkgEnv =
240 241
  pkgEnv {
    pkgEnvSavedConfig = mappendedConf {
242
         savedConfigureFlags = (savedConfigureFlags mappendedConf) {
243 244 245 246 247
          configPackageDBs = configPackageDBs pkgEnvConfigureFlags
          }
       , savedInstallFlags = (savedInstallFlags mappendedConf) {
          installSummaryFile = installSummaryFile pkgEnvInstallFlags
          }
248 249
       },
    pkgEnvInherit = pkgEnvInherit pkgEnv0
250 251 252
    }
  where
    pkgEnvConf           = pkgEnvSavedConfig pkgEnv
253
    mappendedConf        = (pkgEnvSavedConfig pkgEnv0) `mappend` pkgEnvConf
254 255 256
    pkgEnvConfigureFlags = savedConfigureFlags pkgEnvConf
    pkgEnvInstallFlags   = savedInstallFlags pkgEnvConf

refold's avatar
refold committed
257 258
-- | Default values that get used if no value is given. Used here to include in
-- comments when we write out the initial package environment.
259
commentPackageEnvironment :: FilePath -> IO PackageEnvironment
260
commentPackageEnvironment sandboxDir = do
261
  commentConf  <- commentSavedConfig
262
  let baseConf =  commonPackageEnvironmentConfig sandboxDir
refold's avatar
refold committed
263 264 265
  return $ mempty {
    pkgEnvSavedConfig = commentConf `mappend` baseConf
    }
266

refold's avatar
refold committed
267 268 269 270 271 272 273 274
-- | If this package environment inherits from some other package environment,
-- return that package environment; otherwise return mempty.
inheritedPackageEnvironment :: Verbosity -> PackageEnvironment
                               -> IO PackageEnvironment
inheritedPackageEnvironment verbosity pkgEnv = do
  case (pkgEnvInherit pkgEnv) of
    NoFlag                -> return mempty
    confPathFlag@(Flag _) -> do
275
      conf <- loadConfig verbosity confPathFlag
refold's avatar
refold committed
276
      return $ mempty { pkgEnvSavedConfig = conf }
refold's avatar
refold committed
277

278
-- | Load the user package environment if it exists (the optional "cabal.config"
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
279
-- file). If it does not exist locally, attempt to load an optional global one.
280 281
userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath
                       -> IO PackageEnvironment
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
282 283
userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do
    let path = pkgEnvDir </> userPackageEnvironmentFile
284 285
    minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path)
            mempty path
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
286 287
    case (minp, globalConfigLocation) of
      (Just parseRes, _)  -> processConfigParse path parseRes
288 289 290 291 292 293 294 295 296 297
      (_, Just globalLoc) -> do
        minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc)
                 mempty globalLoc
        maybe (warn verbosity ("no constraints file found at " ++ globalLoc)
               >> return mempty)
          (processConfigParse globalLoc)
          minp'
      _ -> do
        debug verbosity ("no user package environment file found at " ++ pkgEnvDir)
        return mempty
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
298 299
  where
    processConfigParse path (ParseOk warns parseResult) = do
300 301 302
      when (not $ null warns) $ warn verbosity $
        unlines (map (showPWarning path) warns)
      return parseResult
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
303
    processConfigParse path (ParseFailed err) = do
304
      let (line, msg) = locatedErrorMsg err
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
305
      warn verbosity $ "Error parsing package environment file " ++ path
306 307 308
        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
      return mempty

refold's avatar
refold committed
309
-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
310 311
loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig verbosity pkgEnvDir globalConfigLocation =
312 313
    fmap pkgEnvSavedConfig $
    userPackageEnvironment verbosity pkgEnvDir globalConfigLocation
refold's avatar
refold committed
314

315
-- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and
316 317 318 319 320 321
-- 'updatePackageEnvironment'.
handleParseResult :: Verbosity -> FilePath
                     -> Maybe (ParseResult PackageEnvironment)
                     -> IO PackageEnvironment
handleParseResult verbosity path minp =
  case minp of
refold's avatar
refold committed
322 323 324 325 326 327 328 329 330 331
    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
refold's avatar
refold committed
332

333 334 335 336 337 338 339
-- | Try to load the given package environment file, exiting with error if it
-- doesn't exist. Also returns the path to the sandbox directory. The path
-- parameter should refer to an existing file.
tryLoadSandboxPackageEnvironmentFile :: Verbosity -> FilePath -> (Flag FilePath)
                                        -> IO (FilePath, PackageEnvironment)
tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do
  let pkgEnvDir = takeDirectory pkgEnvFile
340
  minp   <- readPackageEnvironmentFile
341
            (ConstraintSourceSandboxConfig pkgEnvFile) mempty pkgEnvFile
342
  pkgEnv <- handleParseResult verbosity pkgEnvFile minp
343

refold's avatar
refold committed
344
  -- Get the saved sandbox directory.
345 346
  -- TODO: Use substPathTemplate with
  -- compilerTemplateEnv ++ platformTemplateEnv ++ abiTemplateEnv.
refold's avatar
refold committed
347
  let sandboxDir = fromFlagOrDefault defaultSandboxLocation
refold's avatar
refold committed
348
                   . fmap fromPathTemplate . prefix . savedUserInstallDirs
refold's avatar
refold committed
349
                   . pkgEnvSavedConfig $ pkgEnv
refold's avatar
refold committed
350

351 352 353 354 355 356 357
  -- Do some sanity checks
  dirExists            <- doesDirectoryExist sandboxDir
  -- TODO: Also check for an initialised package DB?
  unless dirExists $
    die ("No sandbox exists at " ++ sandboxDir)
  info verbosity $ "Using a sandbox located at " ++ sandboxDir

358 359
  let base   = basePackageEnvironment
  let common = commonPackageEnvironment sandboxDir
U-CIQDEV\gbazerman's avatar
U-CIQDEV\gbazerman committed
360
  user      <- userPackageEnvironment verbosity pkgEnvDir Nothing --TODO
refold's avatar
refold committed
361
  inherited <- inheritedPackageEnvironment verbosity user
362

refold's avatar
refold committed
363
  -- Layer the package environment settings over settings from ~/.cabal/config.
364
  cabalConfig <- fmap unsetSymlinkBinDir $ loadConfig verbosity configFileFlag
365
  return (sandboxDir,
366
          updateInstallDirs $
367 368 369 370 371
          (base `mappend` (toPkgEnv cabalConfig) `mappend`
           common `mappend` inherited `mappend` user)
          `overrideSandboxSettings` pkgEnv)
    where
      toPkgEnv config = mempty { pkgEnvSavedConfig = config }
refold's avatar
refold committed
372

373
      updateInstallDirs pkgEnv =
374 375
        let config         = pkgEnvSavedConfig    pkgEnv
            configureFlags = savedConfigureFlags  config
376 377 378 379 380 381 382 383 384
            installDirs    = savedUserInstallDirs config
        in pkgEnv {
          pkgEnvSavedConfig = config {
             savedConfigureFlags = configureFlags {
                configInstallDirs = installDirs
                }
             }
          }

385 386 387 388 389 390 391 392 393 394
      -- We don't want to inherit the value of 'symlink-bindir' from
      -- '~/.cabal/config'. See #1514.
      unsetSymlinkBinDir config =
        let installFlags = savedInstallFlags config
        in config {
          savedInstallFlags = installFlags {
             installSymlinkBinDir = NoFlag
             }
          }

395
-- | Create a new package environment file, replacing the existing one if it
refold's avatar
refold committed
396
-- exists. Note that the path parameters should point to existing directories.
397 398 399 400
createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath
                                -> Compiler
                                -> Platform
                                -> IO ()
bardur.arantsson's avatar
bardur.arantsson committed
401 402
createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile compiler platform = do
  notice verbosity $ "Writing a default package environment file to " ++ pkgEnvFile
403
  initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform
bardur.arantsson's avatar
bardur.arantsson committed
404
  writePackageEnvironmentFile pkgEnvFile initialPkgEnv
405

406
-- | Descriptions of all fields in the package environment file.
407 408
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs src = [
409
  simpleField "inherit"
410
    (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)
411
    pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })
412

413
  , commaNewLineListField "constraints"
414
    (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)
415 416
    (sortConstraints . configExConstraints
     . savedConfigureExFlags . pkgEnvSavedConfig)
417 418 419 420 421 422 423 424
    (\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 }))
425
  ]
426
  ++ map toPkgEnv configFieldDescriptions'
427 428 429
  where
    optional = Parse.option mempty . fmap toFlag

430 431 432
    configFieldDescriptions' :: [FieldDescr SavedConfig]
    configFieldDescriptions' = filter
      (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")
433
      (configFieldDescriptions src)
434

435
    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
436 437 438 439 440
    toPkgEnv fieldDescr =
      liftField pkgEnvSavedConfig
      (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})
      fieldDescr

441 442 443 444 445 446 447 448 449 450
    updateConfigureExFlags :: PackageEnvironment
                              -> (ConfigExFlags -> ConfigExFlags)
                              -> PackageEnvironment
    updateConfigureExFlags pkgEnv f = pkgEnv {
      pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {
         savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig
                                 $ pkgEnv
         }
      }

451 452
    sortConstraints = sortBy (comparing $ userConstraintPackageName . fst)

453
-- | Read the package environment file.
454
readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
455
                              -> IO (Maybe (ParseResult PackageEnvironment))
456
readPackageEnvironmentFile src initial file =
457
  handleNotExists $
458
  fmap (Just . parsePackageEnvironment src initial) (readFile file)
459 460 461 462 463 464 465
  where
    handleNotExists action = catchIO action $ \ioe ->
      if isDoesNotExistError ioe
        then return Nothing
        else ioError ioe

-- | Parse the package environment file.
466
parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String
467
                           -> ParseResult PackageEnvironment
468
parsePackageEnvironment src initial str = do
469 470 471 472 473
  fields <- readFields str
  let (knownSections, others) = partition isKnownSection fields
  pkgEnv <- parse others
  let config       = pkgEnvSavedConfig pkgEnv
      installDirs0 = savedUserInstallDirs config
474 475 476 477
  (haddockFlags, installDirs, paths, args) <-
    foldM parseSections
    (savedHaddockFlags config, installDirs0, [], [])
    knownSections
478 479
  return pkgEnv {
    pkgEnvSavedConfig = config {
480 481 482 483
       savedConfigureFlags    = (savedConfigureFlags config) {
          configProgramPaths  = paths,
          configProgramArgs   = args
          },
484
       savedHaddockFlags      = haddockFlags,
485 486 487 488 489 490 491
       savedUserInstallDirs   = installDirs,
       savedGlobalInstallDirs = installDirs
       }
    }

  where
    isKnownSection :: ParseUtils.Field -> Bool
492
    isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True
493 494 495 496
    isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True
    isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True
    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
    isKnownSection _                                                    = False
497

498
    parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment
499
    parse = parseFields (pkgEnvFieldDescrs src) initial
500

501 502
    parseSections :: SectionsAccum -> ParseUtils.Field
                     -> ParseResult SectionsAccum
503 504 505 506 507 508 509 510 511 512 513
    parseSections accum@(h,d,p,a)
                 (ParseUtils.Section _ "haddock" name fs)
      | name == "" = do h' <- parseFields haddockFlagsFields h fs
                        return (h', d, p, a)
      | otherwise  = do
          warning "The 'haddock' section should be unnamed"
          return accum
    parseSections (h,d,p,a)
                  (ParseUtils.Section line "install-dirs" name fs)
      | name == "" = do d' <- parseFields installDirsFields d fs
                        return (h, d',p,a)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
514
      | otherwise  =
515
        syntaxError line $
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
516 517 518
        "Named 'install-dirs' section: '" ++ name
        ++ "'. Note that named 'install-dirs' sections are not allowed in the '"
        ++ userPackageEnvironmentFile ++ "' file."
519
    parseSections accum@(h, d,p,a)
520
                  (ParseUtils.Section _ "program-locations" name fs)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
521 522 523
      | name == "" = do p' <- parseFields withProgramsFields p fs
                        return (h, d, p', a)
      | otherwise  = do
524 525
          warning "The 'program-locations' section should be unnamed"
          return accum
526
    parseSections accum@(h, d, p, a)
527
                  (ParseUtils.Section _ "program-default-options" name fs)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
528 529 530
      | name == "" = do a' <- parseFields withProgramOptionsFields a fs
                        return (h, d, p, a')
      | otherwise  = do
531 532 533 534 535 536 537
          warning "The 'program-default-options' section should be unnamed"
          return accum
    parseSections accum f = do
      warning $ "Unrecognized stanza on line " ++ show (lineNo f)
      return accum

-- | Accumulator type for 'parseSections'.
538
type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate)
539
                     , [(String, FilePath)], [(String, [String])])
540 541

-- | Write out the package environment file.
bardur.arantsson's avatar
bardur.arantsson committed
542 543
writePackageEnvironmentFile :: FilePath -> PackageEnvironment -> IO ()
writePackageEnvironmentFile path pkgEnv = do
544
  let tmpPath = (path <.> "tmp")
545
  writeFile tmpPath $ explanation ++ pkgEnvStr ++ "\n"
546
  renameFile tmpPath path
refold's avatar
refold committed
547
  where
bardur.arantsson's avatar
bardur.arantsson committed
548
    pkgEnvStr = showPackageEnvironment pkgEnv
refold's avatar
refold committed
549 550
    explanation = unlines
      ["-- This is a Cabal package environment file."
551 552 553
      ,"-- 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."
refold's avatar
refold committed
554 555
      ,"",""
      ]
556

557
-- | Pretty-print the package environment.
558
showPackageEnvironment :: PackageEnvironment -> String
refold's avatar
refold committed
559
showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv
560 561 562

-- | Pretty-print the package environment with default values for empty fields
-- commented out (just like the default ~/.cabal/config).
refold's avatar
refold committed
563 564
showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)
                                      -> PackageEnvironment
565
                                      -> String
refold's avatar
refold committed
566
showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $
567
      ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown)
568
               mdefPkgEnv pkgEnv
569 570
  $+$ Disp.text ""
  $+$ ppSection "install-dirs" "" installDirsFields
refold's avatar
refold committed
571
                (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)
572
  where
refold's avatar
refold committed
573
    installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig