Commit 8906bc19 authored by rubbernecking.trumpet.stephen's avatar rubbernecking.trumpet.stephen
Browse files

Ticket #89 part 1: add targetBuildDepends field to PackageDescription's target-specific BuildInfos

This provides dependencies specifically for each library and executable target.
buildDepends is calculated as the union of the individual targetBuildDepends,
giving a result that's exactly equivalent to the old behaviour.
parent f3fb9a9c
......@@ -336,9 +336,10 @@ data BuildInfo = BuildInfo {
options :: [(CompilerFlavor,[String])],
ghcProfOptions :: [String],
ghcSharedOptions :: [String],
customFieldsBI :: [(String,String)] -- ^Custom fields starting
customFieldsBI :: [(String,String)], -- ^Custom fields starting
-- with x-, stored in a
-- simple assoc-list.
targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target
}
deriving (Show,Read,Eq)
......@@ -363,7 +364,8 @@ instance Monoid BuildInfo where
options = [],
ghcProfOptions = [],
ghcSharedOptions = [],
customFieldsBI = []
customFieldsBI = [],
targetBuildDepends = []
}
mappend a b = BuildInfo {
buildable = buildable a && buildable b,
......@@ -385,7 +387,8 @@ instance Monoid BuildInfo where
options = combine options,
ghcProfOptions = combine ghcProfOptions,
ghcSharedOptions = combine ghcSharedOptions,
customFieldsBI = combine customFieldsBI
customFieldsBI = combine customFieldsBI,
targetBuildDepends = combineNub targetBuildDepends
}
where
combine field = field a `mappend` field b
......
......@@ -77,6 +77,7 @@ import Distribution.Simple.Utils (currentDir, lowercase)
import Distribution.Text
( Text(parse) )
import Distribution.Compat.ReadP as ReadP hiding ( char )
import Control.Arrow (first)
import qualified Distribution.Compat.ReadP as ReadP ( char )
import Data.Char ( isAlphaNum )
......@@ -243,9 +244,9 @@ resolveWithFlags :: Monoid a =>
-> [Dependency] -- ^ Additional constraints
-> [CondTree ConfVar [Dependency] a]
-> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.
-> Either [Dependency] -- missing dependencies
([a], [Dependency], FlagAssignment)
-- ^ In the returned dependencies, there will be no duplicates by name
-> Either [Dependency] (TargetSet a, FlagAssignment)
-- ^ Either the missing dependencies (error case), or a pair of
-- (set of build targets with dependencies, chosen flag assignments)
resolveWithFlags dom os arch impl constrs trees checkDeps =
case try dom [] of
Right r -> Right r
......@@ -259,32 +260,20 @@ resolveWithFlags dom os arch impl constrs trees checkDeps =
. 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 :: DependencyMap -> DependencyMap -> DependencyMap
leftJoin left extra =
DependencyMap $
M.foldWithKey tightenConstraint (unDependencyMap left)
(unDependencyMap 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
-- avoid some computation overhead in the successful case.
try [] flags =
let (depss, as) = unzip
. map (simplifyCondTree (env flags))
$ simplifiedTrees
deps = fromDepMap $ leftJoin (mconcat depss)
extraConstrs
in case (checkDeps deps, deps) of
(DepOk, ds) -> Right (as, ds, flags)
(MissingDeps mds, _) -> Left (BTN mds)
let targetSet = TargetSet $ flip map simplifiedTrees $
-- apply additional constraints to all dependencies
first (`constrainBy` extraConstrs) .
simplifyCondTree (env flags)
deps = overallDependencies targetSet
in case checkDeps (fromDepMap deps) of
DepOk -> Right (targetSet, flags)
MissingDeps mds -> Left (BTN mds)
try ((n, vals):rest) flags =
tryAll $ map (\v -> try rest ((n, v):flags)) vals
......@@ -395,6 +384,56 @@ freeVars t = [ f | Flag f <- freeVars' t ]
COr c1 c2 -> condfv c1 ++ condfv c2
CAnd c1 c2 -> condfv c1 ++ condfv c2
------------------------------------------------------------------------------
-- | A set of targets with their package dependencies
newtype TargetSet a = TargetSet [(DependencyMap, a)]
-- | Combine the target-specific dependencies in a TargetSet to give the
-- dependencies for the package as a whole.
overallDependencies :: Monoid a => TargetSet a -> DependencyMap
overallDependencies (TargetSet targets) = mconcat depss
where
(depss, _) = unzip targets
-- Apply extra constraints to a dependency map.
-- Combines 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.
constrainBy :: DependencyMap -- ^ Input map
-> DependencyMap -- ^ Extra constraints
-> DependencyMap
constrainBy left extra =
DependencyMap $
M.foldWithKey tightenConstraint (unDependencyMap left)
(unDependencyMap extra)
where tightenConstraint n c l =
case M.lookup n l of
Nothing -> l
Just vr -> M.insert n (intersectVersionRanges vr c) l
-- | Collect up the targets in a TargetSet of tagged targets, storing the
-- dependencies as we go.
flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(String, Executable)])
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
where
untag (_, Lib _) (Just _, _) = bug "Only one library expected"
untag (deps, Lib l) (Nothing, exes) = (Just l', exes)
where
l' = l {
libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
}
untag (deps, Exe n e) (mlib, exes)
| any ((== n) . fst) exes = bug "Exe with same name found"
| otherwise = (mlib, exes ++ [(n, e')])
where
e' = e {
buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }
}
untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal
------------------------------------------------------------------------------
-- Convert GenericPackageDescription to PackageDescription
--
......@@ -447,10 +486,10 @@ finalizePackageDescription ::
finalizePackageDescription userflags mpkgs os arch impl constraints
(GenericPackageDescription pkg flags mlib0 exes0) =
case resolveFlags of
Right ((mlib, exes'), deps, flagVals) ->
Right ((mlib, exes'), targetSet, flagVals) ->
Right ( pkg { library = mlib
, executables = exes'
, buildDepends = deps
, buildDepends = fromDepMap $ overallDependencies targetSet
}
, flagVals )
Left missing -> Left missing
......@@ -459,22 +498,13 @@ finalizePackageDescription userflags mpkgs os arch impl constraints
condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )
++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0
untagRslts = foldr untag (Nothing, [])
where
untag (Lib _) (Just _, _) = bug "Only one library expected"
untag (Lib l) (Nothing, exes) = (Just l, exes)
untag (Exe n e) (mlib, exes)
| any ((== n) . fst) exes = bug "Exe with same name found"
| otherwise = (mlib, exes ++ [(n, e)])
untag PDNull x = x -- actually this should not happen, but let's be liberal
resolveFlags =
case resolveWithFlags flagChoices os arch impl constraints condTrees check of
Right (as, ds, fs) ->
let (mlib, exes) = untagRslts as in
Right (targetSet, fs) ->
let (mlib, exes) = flattenTaggedTargets targetSet in
Right ( (fmap libFillInDefaults mlib,
map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes),
ds, fs)
targetSet, fs)
Left missing -> Left missing
flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags
......
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