Commit 3c01c8a5 authored by nominolo@gmail.com's avatar nominolo@gmail.com
Browse files

Fix #224. We do not yet warn if the user specified a dependency that

did not occur in the package (it is just silently ignored.)
parent 96e43ac8
......@@ -71,6 +71,7 @@ import Data.Char ( isAlphaNum )
import Data.Maybe ( catMaybes, maybeToList )
import Data.List ( nub )
import Data.Map ( Map, unionsWith, fromListWith, toList )
import qualified Data.Map as M
import Data.Monoid
------------------------------------------------------------------------------
......@@ -224,21 +225,37 @@ resolveWithFlags :: Monoid a =>
-> OS -- ^ OS as returned by Distribution.System.buildOS
-> Arch -- ^ Arch as returned by Distribution.System.buildArch
-> (CompilerFlavor, Version) -- ^ Compiler flavour + version
-> [Dependency] -- ^ Additional constraints
-> [CondTree ConfVar [Dependency] a]
-> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.
-> (Either [Dependency] -- missing dependencies
([a], [Dependency], [(String, Bool)]))
resolveWithFlags dom os arch impl trees checkDeps =
-- ^ In the returned dependencies, there will be no duplicates by name
resolveWithFlags dom os arch impl constrs trees checkDeps =
case try dom [] of
Right r -> Right r
Left dbt -> Left $ findShortest dbt
where
extraConstrs = toDepMap constrs
-- simplify trees by (partially) evaluating all conditions and converting
-- dependencies to dependency maps.
simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps
. mapTreeConds (fst . simplifyWithSysParams os arch impl))
trees
-- version to combine dependencies where the result will only contain keys
-- from the left (first) map. If a key also exists in the right map, both
-- constraints will be intersected.
leftJoin :: Map String VersionRange -> Map String VersionRange
-> Map String VersionRange
leftJoin left extra =
M.foldWithKey tightenConstraint left extra
where tightenConstraint n c l =
case M.lookup n l of
Nothing -> l
Just vr -> M.insert n (IntersectVersionRanges vr c) l
-- @try@ recursively tries all possible flag assignments in the domain and
-- either succeeds or returns a binary tree with the missing dependencies
-- encountered in each run. Since the tree is constructed lazily, we
......@@ -247,7 +264,8 @@ resolveWithFlags dom os arch impl trees checkDeps =
let (depss, as) = unzip
. map (simplifyCondTree (env flags))
$ simplifiedTrees
deps = (fromDepMap $ unionsWith IntersectVersionRanges depss)
deps = fromDepMap $ leftJoin (unionsWith IntersectVersionRanges depss)
extraConstrs
in case (checkDeps deps, deps) of
(DepOk, ds) -> Right (as, ds, flags)
(MissingDeps mds, _) -> Left (BTN mds)
......@@ -366,12 +384,13 @@ finalizePackageDescription ::
-> OS -- ^ OS-name
-> Arch -- ^ Arch-name
-> (CompilerFlavor, Version) -- ^ Compiler + Version
-> [Dependency] -- ^ Additional constraints
-> GenericPackageDescription
-> Either [Dependency]
(PackageDescription, [(String,Bool)])
-- ^ Either missing dependencies or the resolved package
-- description along with the flag assignments chosen.
finalizePackageDescription userflags mpkgs os arch impl
finalizePackageDescription userflags mpkgs os arch impl constraints
(GenericPackageDescription pkg flags mlib0 exes0) =
case resolveFlags of
Right ((mlib, exes'), deps, flagVals) ->
......@@ -396,7 +415,7 @@ finalizePackageDescription userflags mpkgs os arch impl
untag PDNull x = x -- actually this should not happen, but let's be liberal
resolveFlags =
case resolveWithFlags flagChoices os arch impl condTrees check of
case resolveWithFlags flagChoices os arch impl constraints condTrees check of
Right (as, ds, fs) ->
let (mlib, exes) = untagRslts as in
Right ( (fmap libFillInDefaults mlib,
......
......@@ -296,6 +296,7 @@ configure (pkg_descr0, pbi) cfg
Distribution.System.buildOS
Distribution.System.buildArch
(flavor, version)
(configConstraints cfg)
ppd
of Right r -> return r
Left missing ->
......
......@@ -68,7 +68,8 @@ module Distribution.Simple.Setup (
import Distribution.Compiler ()
import Distribution.ReadE
import Distribution.Text (display)
import Distribution.Text (display, parse)
import Distribution.Package ( Dependency(..) )
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
import Distribution.Simple.Compiler
......@@ -248,6 +249,8 @@ data ConfigFlags = ConfigFlags {
configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi
configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC
configStripExes :: Flag Bool, -- ^Enable executable stripping
configConstraints :: [Dependency], -- ^Additional constraints for
-- dependencies
configConfigurationsFlags :: [(String, Bool)]
}
deriving Show
......@@ -457,6 +460,12 @@ configureOptions showOrParseArgs =
"A list of directories to search for external libraries"
configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})
(reqArg' "PATH" (\x -> [x]) id)
,option "" ["constraint"]
"A list of additional constraints on the dependencies."
configConstraints (\v flags -> flags { configConstraints = v})
(reqArg "DEPENDENCY"
(readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))
(map (\x -> display x)))
]
where
readFlagList :: String -> [(String, Bool)]
......@@ -504,6 +513,7 @@ instance Monoid ConfigFlags where
configSplitObjs = mempty,
configStripExes = mempty,
configExtraLibDirs = mempty,
configConstraints = mempty,
configExtraIncludeDirs = mempty,
configConfigurationsFlags = mempty
}
......@@ -531,6 +541,7 @@ instance Monoid ConfigFlags where
configSplitObjs = combine configSplitObjs,
configStripExes = combine configSplitObjs,
configExtraLibDirs = combine configExtraLibDirs,
configConstraints = combine configConstraints,
configExtraIncludeDirs = combine configExtraIncludeDirs,
configConfigurationsFlags = combine configConfigurationsFlags
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment