{-# 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
$cfrom :: forall x. PackageEnvironment -> Rep PackageEnvironment x
from :: forall x. PackageEnvironment -> Rep PackageEnvironment x
$cto :: forall x. Rep PackageEnvironment x -> PackageEnvironment
to :: forall x. Rep PackageEnvironment x -> PackageEnvironment
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 :: String
userPackageEnvironmentFile = String
"cabal.config"
data PackageEnvironmentType
= UserPackageEnvironment
| AmbientPackageEnvironment
classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment :: String -> IO PackageEnvironmentType
classifyPackageEnvironment String
pkgEnvDir = do
Bool
isUser <- String -> IO Bool
configExists String
userPackageEnvironmentFile
PackageEnvironmentType -> IO PackageEnvironmentType
forall a. a -> IO a
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
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)
PackageEnvironment
forall a. Monoid a => a
mempty String
path
case (Maybe (ParseResult PackageEnvironment)
minp, Maybe String
globalConfigLocation) of
(Just ParseResult PackageEnvironment
parseRes, Maybe String
_) -> String -> ParseResult PackageEnvironment -> IO PackageEnvironment
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)
PackageEnvironment
forall a. Monoid a => a
mempty String
globalLoc
IO PackageEnvironment
-> (ParseResult PackageEnvironment -> IO PackageEnvironment)
-> Maybe (ParseResult PackageEnvironment)
-> IO PackageEnvironment
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> String -> IO ()
warn Verbosity
verbosity (String
"no constraints file found at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
globalLoc)
IO () -> IO PackageEnvironment -> IO PackageEnvironment
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageEnvironment -> IO PackageEnvironment
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
forall a. Monoid a => a
mempty)
(String -> ParseResult PackageEnvironment -> IO PackageEnvironment
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgEnvDir)
PackageEnvironment -> IO PackageEnvironment
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
forall a. Monoid a => a
mempty
where
processConfigParse :: String -> ParseResult b -> IO b
processConfigParse String
path (ParseOk [PWarning]
warns b
parseResult) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PWarning] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines ((PWarning -> String) -> [PWarning] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
showPWarning String
path) [PWarning]
warns)
b -> IO b
forall a. a -> IO a
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error parsing package environment file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (LineNo -> String) -> Maybe LineNo -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\LineNo
n -> String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show LineNo
n) Maybe LineNo
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
b -> IO b
forall a. a -> IO a
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 -> String -> Maybe String -> IO SavedConfig
loadUserConfig Verbosity
verbosity String
pkgEnvDir Maybe String
globalConfigLocation =
(PackageEnvironment -> SavedConfig)
-> IO PackageEnvironment -> IO SavedConfig
forall a b. (a -> b) -> IO a -> IO b
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 -> String -> Maybe String -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity String
pkgEnvDir Maybe String
globalConfigLocation
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
src =
[ String
-> ((UserConstraint, ConstraintSource) -> Doc)
-> ParsecParser (UserConstraint, ConstraintSource)
-> (PackageEnvironment -> [(UserConstraint, ConstraintSource)])
-> ([(UserConstraint, ConstraintSource)]
-> PackageEnvironment -> PackageEnvironment)
-> FieldDescr PackageEnvironment
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaNewLineListFieldParsec String
"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 a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser UserConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m UserConstraint
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 }))
, String
-> (PackageVersionConstraint -> Doc)
-> ParsecParser PackageVersionConstraint
-> (PackageEnvironment -> [PackageVersionConstraint])
-> ([PackageVersionConstraint]
-> PackageEnvironment -> PackageEnvironment)
-> FieldDescr PackageEnvironment
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldParsec String
"preferences"
PackageVersionConstraint -> Doc
forall a. Pretty a => a -> Doc
pretty ParsecParser PackageVersionConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m PackageVersionConstraint
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 String
name SavedConfig -> Doc
_ LineNo -> String -> SavedConfig -> ParseResult SavedConfig
_) -> String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"preference" Bool -> Bool -> Bool
&& String
name String -> String -> Bool
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 =
(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
-> String
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile ConstraintSource
src PackageEnvironment
initial String
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 a b. (a -> b) -> IO a -> IO b
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) (String -> IO ByteString
BS.readFile String
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 a. a -> IO 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, [(String, String)]
paths, [(String, [String])]
args) <-
((HaddockFlags, InstallDirs (Flag PathTemplate),
[(String, String)], [(String, [String])])
-> Field
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])]))
-> (HaddockFlags, InstallDirs (Flag PathTemplate),
[(String, String)], [(String, [String])])
-> [Field]
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
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
PackageEnvironment -> ParseResult PackageEnvironment
forall a. a -> ParseResult a
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 = [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), [(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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = 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), [(String, String)],
[(String, [String])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. a -> ParseResult a
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"
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. a -> ParseResult a
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = 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), [(String, String)],
[(String, [String])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d',[(String, String)]
p,[(String, [String])]
a)
| Bool
otherwise =
LineNo
-> String
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. LineNo -> String -> ParseResult a
syntaxError LineNo
line (String
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])]))
-> String
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a b. (a -> b) -> a -> b
$
String
"Named 'install-dirs' section: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. Note that named 'install-dirs' sections are not allowed in the '"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
userPackageEnvironmentFile String -> String -> String
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do [(String, String)]
p' <- [FieldDescr [(String, String)]]
-> [(String, String)] -> [Field] -> ParseResult [(String, String)]
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(String, String)]]
withProgramsFields [(String, String)]
p [Field]
fs
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. a -> ParseResult a
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"
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. a -> ParseResult a
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do [(String, [String])]
a' <- [FieldDescr [(String, [String])]]
-> [(String, [String])]
-> [Field]
-> ParseResult [(String, [String])]
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(String, [String])]]
withProgramOptionsFields [(String, [String])]
a [Field]
fs
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. a -> ParseResult a
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"
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. a -> ParseResult a
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 (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized stanza on line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show (Field -> LineNo
lineNo Field
f)
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
-> ParseResult
(HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
[(String, [String])])
accum
type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate)
, [(String, FilePath)], [(String, [String])])
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment PackageEnvironment
pkgEnv = Maybe PackageEnvironment -> PackageEnvironment -> String
showPackageEnvironmentWithComments Maybe PackageEnvironment
forall a. Maybe a
Nothing PackageEnvironment
pkgEnv
showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)
-> PackageEnvironment
-> String
Maybe PackageEnvironment
mdefPkgEnv PackageEnvironment
pkgEnv = Doc -> String
Disp.render (Doc -> String) -> Doc -> String
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
$+$ String -> Doc
Disp.text String
""
Doc -> Doc -> Doc
$+$ String
-> String
-> [FieldDescr (InstallDirs (Flag PathTemplate))]
-> Maybe (InstallDirs (Flag PathTemplate))
-> InstallDirs (Flag PathTemplate)
-> Doc
forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection String
"install-dirs" String
"" [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields
((PackageEnvironment -> InstallDirs (Flag PathTemplate))
-> Maybe PackageEnvironment
-> Maybe (InstallDirs (Flag PathTemplate))
forall a b. (a -> b) -> Maybe a -> Maybe b
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