{-# LANGUAGE DeriveGeneric #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Sandbox.PackageEnvironment
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Utilities for working with the package environment file. Patterned after
-- Distribution.Client.Config.
-----------------------------------------------------------------------------

module Distribution.Client.Sandbox.PackageEnvironment (
    PackageEnvironment(..)
  , PackageEnvironmentType(..)
  , classifyPackageEnvironment
  , readPackageEnvironmentFile
  , showPackageEnvironment
  , showPackageEnvironmentWithComments
  , loadUserConfig

  , userPackageEnvironmentFile
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.Config      ( SavedConfig(..)
                                       , configFieldDescriptions
                                       , haddockFlagsFields
                                       , installDirsFields, withProgramsFields
                                       , withProgramOptionsFields
                                       )
import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )
import Distribution.Client.Setup       ( ConfigExFlags(..)
                                       )
import Distribution.Client.Targets     ( userConstraintPackageName )
import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate )
import Distribution.Simple.Setup       ( Flag(..)
                                       , ConfigFlags(..), HaddockFlags(..)
                                       )
import Distribution.Simple.Utils       ( warn, debug )
import Distribution.Solver.Types.ConstraintSource
import Distribution.Deprecated.ParseUtils         ( FieldDescr(..), ParseResult(..)
                                       , commaListFieldParsec, commaNewLineListFieldParsec
                                       , liftField, lineNo, locatedErrorMsg
                                       , readFields
                                       , showPWarning
                                       , syntaxError, warning )
import System.Directory                ( doesFileExist )
import System.FilePath                 ( (</>) )
import System.IO.Error                 ( isDoesNotExistError )
import Text.PrettyPrint                ( ($+$) )

import qualified Data.ByteString as BS
import qualified Text.PrettyPrint          as Disp
import qualified Distribution.Deprecated.ParseUtils   as ParseUtils ( Field(..) )

--
-- * Configuration saved in the package environment file
--

-- TODO: would be nice to remove duplication between
-- D.C.Sandbox.PackageEnvironment and D.C.Config.
data PackageEnvironment = PackageEnvironment {
  PackageEnvironment -> SavedConfig
pkgEnvSavedConfig   :: SavedConfig
} deriving forall x. Rep PackageEnvironment x -> PackageEnvironment
forall x. PackageEnvironment -> Rep PackageEnvironment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PackageEnvironment x -> PackageEnvironment
$cfrom :: forall x. PackageEnvironment -> Rep PackageEnvironment x
Generic

instance Monoid PackageEnvironment where
  mempty :: PackageEnvironment
mempty = forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
  mappend :: PackageEnvironment -> PackageEnvironment -> PackageEnvironment
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup PackageEnvironment where
  <> :: PackageEnvironment -> PackageEnvironment -> PackageEnvironment
(<>) = forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend

-- | Optional package environment file that can be used to customize the default
-- settings. Created by the user.
userPackageEnvironmentFile :: FilePath
userPackageEnvironmentFile :: String
userPackageEnvironmentFile = String
"cabal.config"

-- | Type of the current package environment.
data PackageEnvironmentType
  = UserPackageEnvironment    -- ^ './cabal.config'
  | AmbientPackageEnvironment -- ^ '~/.config/cabal/config'

-- | Is there a 'cabal.config' in this directory?
classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment :: String -> IO PackageEnvironmentType
classifyPackageEnvironment String
pkgEnvDir = do
     Bool
isUser <- String -> IO Bool
configExists String
userPackageEnvironmentFile
     forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> PackageEnvironmentType
classify Bool
isUser)
  where
    configExists :: String -> IO Bool
configExists String
fname   = String -> IO Bool
doesFileExist (String
pkgEnvDir String -> String -> String
</> String
fname)

    classify :: Bool -> PackageEnvironmentType
    classify :: Bool -> PackageEnvironmentType
classify Bool
True    = PackageEnvironmentType
UserPackageEnvironment
    classify Bool
False   = PackageEnvironmentType
AmbientPackageEnvironment


-- | Load the user package environment if it exists (the optional "cabal.config"
-- file). If it does not exist locally, attempt to load an optional global one.
userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath
                       -> IO PackageEnvironment
userPackageEnvironment :: Verbosity -> String -> Maybe String -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity String
pkgEnvDir Maybe String
globalConfigLocation = do
    let path :: String
path = String
pkgEnvDir String -> String -> String
</> String
userPackageEnvironmentFile
    Maybe (ParseResult PackageEnvironment)
minp <- ConstraintSource
-> PackageEnvironment
-> String
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile (String -> ConstraintSource
ConstraintSourceUserConfig String
path)
            forall a. Monoid a => a
mempty String
path
    case (Maybe (ParseResult PackageEnvironment)
minp, Maybe String
globalConfigLocation) of
      (Just ParseResult PackageEnvironment
parseRes, Maybe String
_)  -> forall {b}. Monoid b => String -> ParseResult b -> IO b
processConfigParse String
path ParseResult PackageEnvironment
parseRes
      (Maybe (ParseResult PackageEnvironment)
_, Just String
globalLoc) -> do
        Maybe (ParseResult PackageEnvironment)
minp' <- ConstraintSource
-> PackageEnvironment
-> String
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile (String -> ConstraintSource
ConstraintSourceUserConfig String
globalLoc)
                 forall a. Monoid a => a
mempty String
globalLoc
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> String -> IO ()
warn Verbosity
verbosity (String
"no constraints file found at " forall a. [a] -> [a] -> [a]
++ String
globalLoc)
               forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty)
          (forall {b}. Monoid b => String -> ParseResult b -> IO b
processConfigParse String
globalLoc)
          Maybe (ParseResult PackageEnvironment)
minp'
      (Maybe (ParseResult PackageEnvironment), Maybe String)
_ -> do
        Verbosity -> String -> IO ()
debug Verbosity
verbosity (String
"no user package environment file found at " forall a. [a] -> [a] -> [a]
++ String
pkgEnvDir)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
  where
    processConfigParse :: String -> ParseResult b -> IO b
processConfigParse String
path (ParseOk [PWarning]
warns b
parseResult) = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warns) forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
        [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
showPWarning String
path) [PWarning]
warns)
      forall (m :: * -> *) a. Monad m => a -> m a
return b
parseResult
    processConfigParse String
path (ParseFailed PError
err) = do
      let (Maybe LineNo
line, String
msg) = PError -> (Maybe LineNo, String)
locatedErrorMsg PError
err
      Verbosity -> String -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Error parsing package environment file " forall a. [a] -> [a] -> [a]
++ String
path
        forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\LineNo
n -> String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LineNo
n) Maybe LineNo
line forall a. [a] -> [a] -> [a]
++ String
":\n" forall a. [a] -> [a] -> [a]
++ String
msg
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.
loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig :: Verbosity -> String -> Maybe String -> IO SavedConfig
loadUserConfig Verbosity
verbosity String
pkgEnvDir Maybe String
globalConfigLocation =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageEnvironment -> SavedConfig
pkgEnvSavedConfig forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> Maybe String -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity String
pkgEnvDir Maybe String
globalConfigLocation



-- | Descriptions of all fields in the package environment file.
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
src =
  [ forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaNewLineListFieldParsec String
"constraints"
    (forall a. Pretty a => a -> Doc
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) ((\UserConstraint
pc -> (UserConstraint
pc, ConstraintSource
src)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec)
    (forall {b}. [(UserConstraint, b)] -> [(UserConstraint, b)]
sortConstraints forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigExFlags -> [(UserConstraint, ConstraintSource)]
configExConstraints
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigExFlags
savedConfigureExFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig)
    (\[(UserConstraint, ConstraintSource)]
v PackageEnvironment
pkgEnv -> PackageEnvironment
-> (ConfigExFlags -> ConfigExFlags) -> PackageEnvironment
updateConfigureExFlags PackageEnvironment
pkgEnv
                  (\ConfigExFlags
flags -> ConfigExFlags
flags { configExConstraints :: [(UserConstraint, ConstraintSource)]
configExConstraints = [(UserConstraint, ConstraintSource)]
v }))

  , forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldParsec String
"preferences"
    forall a. Pretty a => a -> Doc
pretty forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
    (ConfigExFlags -> [PackageVersionConstraint]
configPreferences forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigExFlags
savedConfigureExFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig)
    (\[PackageVersionConstraint]
v PackageEnvironment
pkgEnv -> PackageEnvironment
-> (ConfigExFlags -> ConfigExFlags) -> PackageEnvironment
updateConfigureExFlags PackageEnvironment
pkgEnv
                  (\ConfigExFlags
flags -> ConfigExFlags
flags { configPreferences :: [PackageVersionConstraint]
configPreferences = [PackageVersionConstraint]
v }))
  ]
  forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv [FieldDescr SavedConfig]
configFieldDescriptions'
  where
    configFieldDescriptions' :: [FieldDescr SavedConfig]
    configFieldDescriptions' :: [FieldDescr SavedConfig]
configFieldDescriptions' = forall a. (a -> Bool) -> [a] -> [a]
filter
      (\(FieldDescr String
name SavedConfig -> Doc
_ LineNo -> String -> SavedConfig -> ParseResult SavedConfig
_) -> String
name forall a. Eq a => a -> a -> Bool
/= String
"preference" Bool -> Bool -> Bool
&& String
name forall a. Eq a => a -> a -> Bool
/= String
"constraint")
      (ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions ConstraintSource
src)

    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv FieldDescr SavedConfig
fieldDescr =
      forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField PackageEnvironment -> SavedConfig
pkgEnvSavedConfig
      (\SavedConfig
savedConfig PackageEnvironment
pkgEnv -> PackageEnvironment
pkgEnv { pkgEnvSavedConfig :: SavedConfig
pkgEnvSavedConfig = SavedConfig
savedConfig})
      FieldDescr SavedConfig
fieldDescr

    updateConfigureExFlags :: PackageEnvironment
                              -> (ConfigExFlags -> ConfigExFlags)
                              -> PackageEnvironment
    updateConfigureExFlags :: PackageEnvironment
-> (ConfigExFlags -> ConfigExFlags) -> PackageEnvironment
updateConfigureExFlags PackageEnvironment
pkgEnv ConfigExFlags -> ConfigExFlags
f = PackageEnvironment
pkgEnv {
      pkgEnvSavedConfig :: SavedConfig
pkgEnvSavedConfig = (PackageEnvironment -> SavedConfig
pkgEnvSavedConfig PackageEnvironment
pkgEnv) {
         savedConfigureExFlags :: ConfigExFlags
savedConfigureExFlags = ConfigExFlags -> ConfigExFlags
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigExFlags
savedConfigureExFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig
                                 forall a b. (a -> b) -> a -> b
$ PackageEnvironment
pkgEnv
         }
      }

    sortConstraints :: [(UserConstraint, b)] -> [(UserConstraint, b)]
sortConstraints = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a -> b) -> a -> b
$ UserConstraint -> PackageName
userConstraintPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

-- | Read the package environment file.
readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
                              -> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile :: ConstraintSource
-> PackageEnvironment
-> String
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile ConstraintSource
src PackageEnvironment
initial String
file =
  forall {a}. IO (Maybe a) -> IO (Maybe a)
handleNotExists forall a b. (a -> b) -> a -> b
$
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintSource
-> PackageEnvironment
-> ByteString
-> ParseResult PackageEnvironment
parsePackageEnvironment ConstraintSource
src PackageEnvironment
initial) (String -> IO ByteString
BS.readFile String
file)
  where
    handleNotExists :: IO (Maybe a) -> IO (Maybe a)
handleNotExists IO (Maybe a)
action = forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO (Maybe a)
action forall a b. (a -> b) -> a -> b
$ \IOException
ioe ->
      if IOException -> Bool
isDoesNotExistError IOException
ioe
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        else forall a. IOException -> IO a
ioError IOException
ioe

-- | Parse the package environment file.
parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString
                           -> ParseResult PackageEnvironment
parsePackageEnvironment :: ConstraintSource
-> PackageEnvironment
-> ByteString
-> ParseResult PackageEnvironment
parsePackageEnvironment ConstraintSource
src PackageEnvironment
initial ByteString
str = do
  [Field]
fields <- ByteString -> ParseResult [Field]
readFields ByteString
str
  let ([Field]
knownSections, [Field]
others) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Field -> Bool
isKnownSection [Field]
fields
  PackageEnvironment
pkgEnv <- [Field] -> ParseResult PackageEnvironment
parse [Field]
others
  let config :: SavedConfig
config       = PackageEnvironment -> SavedConfig
pkgEnvSavedConfig PackageEnvironment
pkgEnv
      installDirs0 :: InstallDirs (Flag PathTemplate)
installDirs0 = SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs SavedConfig
config
  (HaddockFlags
haddockFlags, InstallDirs (Flag PathTemplate)
installDirs, [(String, String)]
paths, [(String, [String])]
args) <-
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> Field
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
parseSections
    (SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
config, InstallDirs (Flag PathTemplate)
installDirs0, [], [])
    [Field]
knownSections
  forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
pkgEnv {
    pkgEnvSavedConfig :: SavedConfig
pkgEnvSavedConfig = SavedConfig
config {
       savedConfigureFlags :: ConfigFlags
savedConfigureFlags    = (SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config) {
          configProgramPaths :: [(String, String)]
configProgramPaths  = [(String, String)]
paths,
          configProgramArgs :: [(String, [String])]
configProgramArgs   = [(String, [String])]
args
          },
       savedHaddockFlags :: HaddockFlags
savedHaddockFlags      = HaddockFlags
haddockFlags,
       savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
savedUserInstallDirs   = InstallDirs (Flag PathTemplate)
installDirs,
       savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs = InstallDirs (Flag PathTemplate)
installDirs
       }
    }

  where
    isKnownSection :: ParseUtils.Field -> Bool
    isKnownSection :: Field -> Bool
isKnownSection (ParseUtils.Section LineNo
_ String
"haddock" String
_ [Field]
_)                 = Bool
True
    isKnownSection (ParseUtils.Section LineNo
_ String
"install-dirs" String
_ [Field]
_)            = Bool
True
    isKnownSection (ParseUtils.Section LineNo
_ String
"program-locations" String
_ [Field]
_)       = Bool
True
    isKnownSection (ParseUtils.Section LineNo
_ String
"program-default-options" String
_ [Field]
_) = Bool
True
    isKnownSection Field
_                                                    = Bool
False

    parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment
    parse :: [Field] -> ParseResult PackageEnvironment
parse = forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields (ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
src) PackageEnvironment
initial

    parseSections :: SectionsAccum -> ParseUtils.Field
                     -> ParseResult SectionsAccum
    parseSections :: (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> Field
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
parseSections accum :: (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum@(HaddockFlags
h,InstallDirs (Flag PathTemplate)
d,[(String, String)]
p,[(String, [String])]
a)
                 (ParseUtils.Section LineNo
_ String
"haddock" String
name [Field]
fs)
      | String
name forall a. Eq a => a -> a -> Bool
== String
"" = do HaddockFlags
h' <- forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr HaddockFlags]
haddockFlagsFields HaddockFlags
h [Field]
fs
                        forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h', InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a)
      | Bool
otherwise  = do
          String -> ParseResult ()
warning String
"The 'haddock' section should be unnamed"
          forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum
    parseSections (HaddockFlags
h,InstallDirs (Flag PathTemplate)
d,[(String, String)]
p,[(String, [String])]
a)
                  (ParseUtils.Section LineNo
line String
"install-dirs" String
name [Field]
fs)
      | String
name forall a. Eq a => a -> a -> Bool
== String
"" = do InstallDirs (Flag PathTemplate)
d' <- forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields InstallDirs (Flag PathTemplate)
d [Field]
fs
                        forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d',[(String, String)]
p,[(String, [String])]
a)
      | Bool
otherwise  =
        forall a. LineNo -> String -> ParseResult a
syntaxError LineNo
line forall a b. (a -> b) -> a -> b
$
        String
"Named 'install-dirs' section: '" forall a. [a] -> [a] -> [a]
++ String
name
        forall a. [a] -> [a] -> [a]
++ String
"'. Note that named 'install-dirs' sections are not allowed in the '"
        forall a. [a] -> [a] -> [a]
++ String
userPackageEnvironmentFile forall a. [a] -> [a] -> [a]
++ String
"' file."
    parseSections accum :: (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum@(HaddockFlags
h, InstallDirs (Flag PathTemplate)
d,[(String, String)]
p,[(String, [String])]
a)
                  (ParseUtils.Section LineNo
_ String
"program-locations" String
name [Field]
fs)
      | String
name forall a. Eq a => a -> a -> Bool
== String
"" = do [(String, String)]
p' <- forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(String, String)]]
withProgramsFields [(String, String)]
p [Field]
fs
                        forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p', [(String, [String])]
a)
      | Bool
otherwise  = do
          String -> ParseResult ()
warning String
"The 'program-locations' section should be unnamed"
          forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum
    parseSections accum :: (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum@(HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a)
                  (ParseUtils.Section LineNo
_ String
"program-default-options" String
name [Field]
fs)
      | String
name forall a. Eq a => a -> a -> Bool
== String
"" = do [(String, [String])]
a' <- forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(String, [String])]]
withProgramOptionsFields [(String, [String])]
a [Field]
fs
                        forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a')
      | Bool
otherwise  = do
          String -> ParseResult ()
warning String
"The 'program-default-options' section should be unnamed"
          forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum
    parseSections (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum Field
f = do
      String -> ParseResult ()
warning forall a b. (a -> b) -> a -> b
$ String
"Unrecognized stanza on line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Field -> LineNo
lineNo Field
f)
      forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum

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



-- | Pretty-print the package environment.
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment PackageEnvironment
pkgEnv = Maybe PackageEnvironment -> PackageEnvironment -> String
showPackageEnvironmentWithComments forall a. Maybe a
Nothing PackageEnvironment
pkgEnv

-- | Pretty-print the package environment with default values for empty fields
-- commented out (just like the default Cabal config file).
showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)
                                      -> PackageEnvironment
                                      -> String
showPackageEnvironmentWithComments :: Maybe PackageEnvironment -> PackageEnvironment -> String
showPackageEnvironmentWithComments Maybe PackageEnvironment
mdefPkgEnv PackageEnvironment
pkgEnv = Doc -> String
Disp.render forall a b. (a -> b) -> a -> b
$
      forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields (ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
ConstraintSourceUnknown)
               Maybe PackageEnvironment
mdefPkgEnv PackageEnvironment
pkgEnv
  Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
  Doc -> Doc -> Doc
$+$ forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection String
"install-dirs" String
"" [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields
                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageEnvironment -> InstallDirs (Flag PathTemplate)
installDirsSection Maybe PackageEnvironment
mdefPkgEnv) (PackageEnvironment -> InstallDirs (Flag PathTemplate)
installDirsSection PackageEnvironment
pkgEnv)
  where
    installDirsSection :: PackageEnvironment -> InstallDirs (Flag PathTemplate)
installDirsSection = SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig