{-# LANGUAGE DeriveGeneric #-}
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(..) )
data PackageEnvironment = PackageEnvironment {
PackageEnvironment -> SavedConfig
pkgEnvSavedConfig :: SavedConfig
} deriving (forall x. PackageEnvironment -> Rep PackageEnvironment x)
-> (forall x. Rep PackageEnvironment x -> PackageEnvironment)
-> Generic PackageEnvironment
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 = PackageEnvironment
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
mappend :: PackageEnvironment -> PackageEnvironment -> PackageEnvironment
mappend = PackageEnvironment -> PackageEnvironment -> PackageEnvironment
forall a. Semigroup a => a -> a -> a
(<>)
instance Semigroup PackageEnvironment where
<> :: PackageEnvironment -> PackageEnvironment -> PackageEnvironment
(<>) = PackageEnvironment -> PackageEnvironment -> PackageEnvironment
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend
userPackageEnvironmentFile :: FilePath
userPackageEnvironmentFile :: FilePath
userPackageEnvironmentFile = FilePath
"cabal.config"
data PackageEnvironmentType
= UserPackageEnvironment
| AmbientPackageEnvironment
classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment FilePath
pkgEnvDir = do
Bool
isUser <- FilePath -> IO Bool
configExists FilePath
userPackageEnvironmentFile
PackageEnvironmentType -> IO PackageEnvironmentType
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> PackageEnvironmentType
classify Bool
isUser)
where
configExists :: FilePath -> IO Bool
configExists FilePath
fname = FilePath -> IO Bool
doesFileExist (FilePath
pkgEnvDir FilePath -> FilePath -> FilePath
</> FilePath
fname)
classify :: Bool -> PackageEnvironmentType
classify :: Bool -> PackageEnvironmentType
classify Bool
True = PackageEnvironmentType
UserPackageEnvironment
classify Bool
False = PackageEnvironmentType
AmbientPackageEnvironment
userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath
-> IO PackageEnvironment
userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity FilePath
pkgEnvDir Maybe FilePath
globalConfigLocation = do
let path :: FilePath
path = FilePath
pkgEnvDir FilePath -> FilePath -> FilePath
</> FilePath
userPackageEnvironmentFile
Maybe (ParseResult PackageEnvironment)
minp <- ConstraintSource
-> PackageEnvironment
-> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile (FilePath -> ConstraintSource
ConstraintSourceUserConfig FilePath
path)
PackageEnvironment
forall a. Monoid a => a
mempty FilePath
path
case (Maybe (ParseResult PackageEnvironment)
minp, Maybe FilePath
globalConfigLocation) of
(Just ParseResult PackageEnvironment
parseRes, Maybe FilePath
_) -> FilePath -> ParseResult PackageEnvironment -> IO PackageEnvironment
forall b. Monoid b => FilePath -> ParseResult b -> IO b
processConfigParse FilePath
path ParseResult PackageEnvironment
parseRes
(Maybe (ParseResult PackageEnvironment)
_, Just FilePath
globalLoc) -> do
Maybe (ParseResult PackageEnvironment)
minp' <- ConstraintSource
-> PackageEnvironment
-> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile (FilePath -> ConstraintSource
ConstraintSourceUserConfig FilePath
globalLoc)
PackageEnvironment
forall a. Monoid a => a
mempty FilePath
globalLoc
IO PackageEnvironment
-> (ParseResult PackageEnvironment -> IO PackageEnvironment)
-> Maybe (ParseResult PackageEnvironment)
-> IO PackageEnvironment
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"no constraints file found at " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
globalLoc)
IO () -> IO PackageEnvironment -> IO PackageEnvironment
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageEnvironment -> IO PackageEnvironment
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
forall a. Monoid a => a
mempty)
(FilePath -> ParseResult PackageEnvironment -> IO PackageEnvironment
forall b. Monoid b => FilePath -> ParseResult b -> IO b
processConfigParse FilePath
globalLoc)
Maybe (ParseResult PackageEnvironment)
minp'
(Maybe (ParseResult PackageEnvironment), Maybe FilePath)
_ -> do
Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath
"no user package environment file found at " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkgEnvDir)
PackageEnvironment -> IO PackageEnvironment
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
forall a. Monoid a => a
mempty
where
processConfigParse :: FilePath -> ParseResult b -> IO b
processConfigParse FilePath
path (ParseOk [PWarning]
warns b
parseResult) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PWarning] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
[FilePath] -> FilePath
unlines ((PWarning -> FilePath) -> [PWarning] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> PWarning -> FilePath
showPWarning FilePath
path) [PWarning]
warns)
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
parseResult
processConfigParse FilePath
path (ParseFailed PError
err) = do
let (Maybe LineNo
line, FilePath
msg) = PError -> (Maybe LineNo, FilePath)
locatedErrorMsg PError
err
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Error parsing package environment file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> (LineNo -> FilePath) -> Maybe LineNo -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (\LineNo
n -> FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LineNo -> FilePath
forall a. Show a => a -> FilePath
show LineNo
n) Maybe LineNo
line FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
forall a. Monoid a => a
mempty
loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig Verbosity
verbosity FilePath
pkgEnvDir Maybe FilePath
globalConfigLocation =
(PackageEnvironment -> SavedConfig)
-> IO PackageEnvironment -> IO SavedConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageEnvironment -> SavedConfig
pkgEnvSavedConfig (IO PackageEnvironment -> IO SavedConfig)
-> IO PackageEnvironment -> IO SavedConfig
forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> Maybe FilePath -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity FilePath
pkgEnvDir Maybe FilePath
globalConfigLocation
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
src =
[ FilePath
-> ((UserConstraint, ConstraintSource) -> Doc)
-> ParsecParser (UserConstraint, ConstraintSource)
-> (PackageEnvironment -> [(UserConstraint, ConstraintSource)])
-> ([(UserConstraint, ConstraintSource)]
-> PackageEnvironment -> PackageEnvironment)
-> FieldDescr PackageEnvironment
forall a b.
FilePath
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaNewLineListFieldParsec FilePath
"constraints"
(UserConstraint -> Doc
forall a. Pretty a => a -> Doc
pretty (UserConstraint -> Doc)
-> ((UserConstraint, ConstraintSource) -> UserConstraint)
-> (UserConstraint, ConstraintSource)
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserConstraint, ConstraintSource) -> UserConstraint
forall a b. (a, b) -> a
fst) ((\UserConstraint
pc -> (UserConstraint
pc, ConstraintSource
src)) (UserConstraint -> (UserConstraint, ConstraintSource))
-> ParsecParser UserConstraint
-> ParsecParser (UserConstraint, ConstraintSource)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser UserConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec)
([(UserConstraint, ConstraintSource)]
-> [(UserConstraint, ConstraintSource)]
forall b. [(UserConstraint, b)] -> [(UserConstraint, b)]
sortConstraints ([(UserConstraint, ConstraintSource)]
-> [(UserConstraint, ConstraintSource)])
-> (PackageEnvironment -> [(UserConstraint, ConstraintSource)])
-> PackageEnvironment
-> [(UserConstraint, ConstraintSource)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigExFlags -> [(UserConstraint, ConstraintSource)]
configExConstraints
(ConfigExFlags -> [(UserConstraint, ConstraintSource)])
-> (PackageEnvironment -> ConfigExFlags)
-> PackageEnvironment
-> [(UserConstraint, ConstraintSource)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigExFlags
savedConfigureExFlags (SavedConfig -> ConfigExFlags)
-> (PackageEnvironment -> SavedConfig)
-> PackageEnvironment
-> ConfigExFlags
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 }))
, FilePath
-> (PackageVersionConstraint -> Doc)
-> ParsecParser PackageVersionConstraint
-> (PackageEnvironment -> [PackageVersionConstraint])
-> ([PackageVersionConstraint]
-> PackageEnvironment -> PackageEnvironment)
-> FieldDescr PackageEnvironment
forall a b.
FilePath
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldParsec FilePath
"preferences"
PackageVersionConstraint -> Doc
forall a. Pretty a => a -> Doc
pretty ParsecParser PackageVersionConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
(ConfigExFlags -> [PackageVersionConstraint]
configPreferences (ConfigExFlags -> [PackageVersionConstraint])
-> (PackageEnvironment -> ConfigExFlags)
-> PackageEnvironment
-> [PackageVersionConstraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigExFlags
savedConfigureExFlags (SavedConfig -> ConfigExFlags)
-> (PackageEnvironment -> SavedConfig)
-> PackageEnvironment
-> ConfigExFlags
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 }))
]
[FieldDescr PackageEnvironment]
-> [FieldDescr PackageEnvironment]
-> [FieldDescr PackageEnvironment]
forall a. [a] -> [a] -> [a]
++ (FieldDescr SavedConfig -> FieldDescr PackageEnvironment)
-> [FieldDescr SavedConfig] -> [FieldDescr PackageEnvironment]
forall a b. (a -> b) -> [a] -> [b]
map FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv [FieldDescr SavedConfig]
configFieldDescriptions'
where
configFieldDescriptions' :: [FieldDescr SavedConfig]
configFieldDescriptions' :: [FieldDescr SavedConfig]
configFieldDescriptions' = (FieldDescr SavedConfig -> Bool)
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter
(\(FieldDescr FilePath
name SavedConfig -> Doc
_ LineNo -> FilePath -> SavedConfig -> ParseResult SavedConfig
_) -> FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"preference" Bool -> Bool -> Bool
&& FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"constraint")
(ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions ConstraintSource
src)
toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv FieldDescr SavedConfig
fieldDescr =
(PackageEnvironment -> SavedConfig)
-> (SavedConfig -> PackageEnvironment -> PackageEnvironment)
-> FieldDescr SavedConfig
-> FieldDescr PackageEnvironment
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 (ConfigExFlags -> ConfigExFlags)
-> (PackageEnvironment -> ConfigExFlags)
-> PackageEnvironment
-> ConfigExFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigExFlags
savedConfigureExFlags (SavedConfig -> ConfigExFlags)
-> (PackageEnvironment -> SavedConfig)
-> PackageEnvironment
-> ConfigExFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig
(PackageEnvironment -> ConfigExFlags)
-> PackageEnvironment -> ConfigExFlags
forall a b. (a -> b) -> a -> b
$ PackageEnvironment
pkgEnv
}
}
sortConstraints :: [(UserConstraint, b)] -> [(UserConstraint, b)]
sortConstraints = ((UserConstraint, b) -> (UserConstraint, b) -> Ordering)
-> [(UserConstraint, b)] -> [(UserConstraint, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((UserConstraint, b) -> PackageName)
-> (UserConstraint, b) -> (UserConstraint, b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((UserConstraint, b) -> PackageName)
-> (UserConstraint, b) -> (UserConstraint, b) -> Ordering)
-> ((UserConstraint, b) -> PackageName)
-> (UserConstraint, b)
-> (UserConstraint, b)
-> Ordering
forall a b. (a -> b) -> a -> b
$ UserConstraint -> PackageName
userConstraintPackageName (UserConstraint -> PackageName)
-> ((UserConstraint, b) -> UserConstraint)
-> (UserConstraint, b)
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserConstraint, b) -> UserConstraint
forall a b. (a, b) -> a
fst)
readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile :: ConstraintSource
-> PackageEnvironment
-> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile ConstraintSource
src PackageEnvironment
initial FilePath
file =
IO (Maybe (ParseResult PackageEnvironment))
-> IO (Maybe (ParseResult PackageEnvironment))
forall a. IO (Maybe a) -> IO (Maybe a)
handleNotExists (IO (Maybe (ParseResult PackageEnvironment))
-> IO (Maybe (ParseResult PackageEnvironment)))
-> IO (Maybe (ParseResult PackageEnvironment))
-> IO (Maybe (ParseResult PackageEnvironment))
forall a b. (a -> b) -> a -> b
$
(ByteString -> Maybe (ParseResult PackageEnvironment))
-> IO ByteString -> IO (Maybe (ParseResult PackageEnvironment))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParseResult PackageEnvironment
-> Maybe (ParseResult PackageEnvironment)
forall a. a -> Maybe a
Just (ParseResult PackageEnvironment
-> Maybe (ParseResult PackageEnvironment))
-> (ByteString -> ParseResult PackageEnvironment)
-> ByteString
-> Maybe (ParseResult PackageEnvironment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintSource
-> PackageEnvironment
-> ByteString
-> ParseResult PackageEnvironment
parsePackageEnvironment ConstraintSource
src PackageEnvironment
initial) (FilePath -> IO ByteString
BS.readFile FilePath
file)
where
handleNotExists :: IO (Maybe a) -> IO (Maybe a)
handleNotExists IO (Maybe a)
action = IO (Maybe a) -> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO (Maybe a)
action ((IOException -> IO (Maybe a)) -> IO (Maybe a))
-> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \IOException
ioe ->
if IOException -> Bool
isDoesNotExistError IOException
ioe
then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
else IOException -> IO (Maybe a)
forall a. IOException -> IO a
ioError IOException
ioe
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) = (Field -> Bool) -> [Field] -> ([Field], [Field])
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, [(FilePath, FilePath)]
paths, [(FilePath, [FilePath])]
args) <-
((HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> Field
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])]))
-> (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> [Field]
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> Field
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
parseSections
(SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
config, InstallDirs (Flag PathTemplate)
installDirs0, [], [])
[Field]
knownSections
PackageEnvironment -> ParseResult PackageEnvironment
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 :: [(FilePath, FilePath)]
configProgramPaths = [(FilePath, FilePath)]
paths,
configProgramArgs :: [(FilePath, [FilePath])]
configProgramArgs = [(FilePath, [FilePath])]
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
_ FilePath
"haddock" FilePath
_ [Field]
_) = Bool
True
isKnownSection (ParseUtils.Section LineNo
_ FilePath
"install-dirs" FilePath
_ [Field]
_) = Bool
True
isKnownSection (ParseUtils.Section LineNo
_ FilePath
"program-locations" FilePath
_ [Field]
_) = Bool
True
isKnownSection (ParseUtils.Section LineNo
_ FilePath
"program-default-options" FilePath
_ [Field]
_) = Bool
True
isKnownSection Field
_ = Bool
False
parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment
parse :: [Field] -> ParseResult PackageEnvironment
parse = [FieldDescr PackageEnvironment]
-> PackageEnvironment -> [Field] -> ParseResult PackageEnvironment
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),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> Field
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
parseSections accum :: (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
accum@(HaddockFlags
h,InstallDirs (Flag PathTemplate)
d,[(FilePath, FilePath)]
p,[(FilePath, [FilePath])]
a)
(ParseUtils.Section LineNo
_ FilePath
"haddock" FilePath
name [Field]
fs)
| FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" = do HaddockFlags
h' <- [FieldDescr HaddockFlags]
-> HaddockFlags -> [Field] -> ParseResult HaddockFlags
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr HaddockFlags]
haddockFlagsFields HaddockFlags
h [Field]
fs
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h', InstallDirs (Flag PathTemplate)
d, [(FilePath, FilePath)]
p, [(FilePath, [FilePath])]
a)
| Bool
otherwise = do
FilePath -> ParseResult ()
warning FilePath
"The 'haddock' section should be unnamed"
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
accum
parseSections (HaddockFlags
h,InstallDirs (Flag PathTemplate)
d,[(FilePath, FilePath)]
p,[(FilePath, [FilePath])]
a)
(ParseUtils.Section LineNo
line FilePath
"install-dirs" FilePath
name [Field]
fs)
| FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" = do InstallDirs (Flag PathTemplate)
d' <- [FieldDescr (InstallDirs (Flag PathTemplate))]
-> InstallDirs (Flag PathTemplate)
-> [Field]
-> ParseResult (InstallDirs (Flag PathTemplate))
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields InstallDirs (Flag PathTemplate)
d [Field]
fs
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d',[(FilePath, FilePath)]
p,[(FilePath, [FilePath])]
a)
| Bool
otherwise =
LineNo
-> FilePath
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall a. LineNo -> FilePath -> ParseResult a
syntaxError LineNo
line (FilePath
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])]))
-> FilePath
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall a b. (a -> b) -> a -> b
$
FilePath
"Named 'install-dirs' section: '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'. Note that named 'install-dirs' sections are not allowed in the '"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
userPackageEnvironmentFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' file."
parseSections accum :: (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
accum@(HaddockFlags
h, InstallDirs (Flag PathTemplate)
d,[(FilePath, FilePath)]
p,[(FilePath, [FilePath])]
a)
(ParseUtils.Section LineNo
_ FilePath
"program-locations" FilePath
name [Field]
fs)
| FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" = do [(FilePath, FilePath)]
p' <- [FieldDescr [(FilePath, FilePath)]]
-> [(FilePath, FilePath)]
-> [Field]
-> ParseResult [(FilePath, FilePath)]
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(FilePath, FilePath)]]
withProgramsFields [(FilePath, FilePath)]
p [Field]
fs
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(FilePath, FilePath)]
p', [(FilePath, [FilePath])]
a)
| Bool
otherwise = do
FilePath -> ParseResult ()
warning FilePath
"The 'program-locations' section should be unnamed"
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
accum
parseSections accum :: (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
accum@(HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(FilePath, FilePath)]
p, [(FilePath, [FilePath])]
a)
(ParseUtils.Section LineNo
_ FilePath
"program-default-options" FilePath
name [Field]
fs)
| FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" = do [(FilePath, [FilePath])]
a' <- [FieldDescr [(FilePath, [FilePath])]]
-> [(FilePath, [FilePath])]
-> [Field]
-> ParseResult [(FilePath, [FilePath])]
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(FilePath, [FilePath])]]
withProgramOptionsFields [(FilePath, [FilePath])]
a [Field]
fs
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(FilePath, FilePath)]
p, [(FilePath, [FilePath])]
a')
| Bool
otherwise = do
FilePath -> ParseResult ()
warning FilePath
"The 'program-default-options' section should be unnamed"
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
accum
parseSections (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
accum Field
f = do
FilePath -> ParseResult ()
warning (FilePath -> ParseResult ()) -> FilePath -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Unrecognized stanza on line " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LineNo -> FilePath
forall a. Show a => a -> FilePath
show (Field -> LineNo
lineNo Field
f)
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate),
[(FilePath, FilePath)], [(FilePath, [FilePath])])
accum
type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate)
, [(String, FilePath)], [(String, [String])])
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment :: PackageEnvironment -> FilePath
showPackageEnvironment PackageEnvironment
pkgEnv = Maybe PackageEnvironment -> PackageEnvironment -> FilePath
showPackageEnvironmentWithComments Maybe PackageEnvironment
forall a. Maybe a
Nothing PackageEnvironment
pkgEnv
showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)
-> PackageEnvironment
-> String
Maybe PackageEnvironment
mdefPkgEnv PackageEnvironment
pkgEnv = Doc -> FilePath
Disp.render (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$
[FieldDescr PackageEnvironment]
-> Maybe PackageEnvironment -> PackageEnvironment -> Doc
forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields (ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
ConstraintSourceUnknown)
Maybe PackageEnvironment
mdefPkgEnv PackageEnvironment
pkgEnv
Doc -> Doc -> Doc
$+$ FilePath -> Doc
Disp.text FilePath
""
Doc -> Doc -> Doc
$+$ FilePath
-> FilePath
-> [FieldDescr (InstallDirs (Flag PathTemplate))]
-> Maybe (InstallDirs (Flag PathTemplate))
-> InstallDirs (Flag PathTemplate)
-> Doc
forall a.
FilePath -> FilePath -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection FilePath
"install-dirs" FilePath
"" [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields
((PackageEnvironment -> InstallDirs (Flag PathTemplate))
-> Maybe PackageEnvironment
-> Maybe (InstallDirs (Flag PathTemplate))
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 (SavedConfig -> InstallDirs (Flag PathTemplate))
-> (PackageEnvironment -> SavedConfig)
-> PackageEnvironment
-> InstallDirs (Flag PathTemplate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig