Configuration.hs 35.4 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1
-- -fno-warn-deprecations for use of Map.foldWithKey
2
{-# OPTIONS_GHC -fno-warn-deprecations #-}
3 4
-----------------------------------------------------------------------------
-- |
5
-- Module      :  Distribution.PackageDescription.Configuration
6
-- Copyright   :  Thomas Schilling, 2007
7
-- License     :  BSD3
8
--
Duncan Coutts's avatar
Duncan Coutts committed
9
-- Maintainer  :  cabal-devel@haskell.org
10 11
-- Portability :  portable
--
Duncan Coutts's avatar
Duncan Coutts committed
12
-- This is about the cabal configurations feature. It exports
13
-- 'finalizePD' and 'flattenPackageDescription' which are
Duncan Coutts's avatar
Duncan Coutts committed
14 15 16
-- functions for converting 'GenericPackageDescription's down to
-- 'PackageDescription's. It has code for working with the tree of conditions
-- and resolving or flattening conditions.
17

18
module Distribution.PackageDescription.Configuration (
19
    finalizePD,
20 21 22 23 24 25
    finalizePackageDescription,
    flattenPackageDescription,

    -- Utils
    parseCondition,
    freeVars,
26
    extractCondition,
27
    extractConditions,
28
    addBuildableCondition,
29 30 31 32
    mapCondTree,
    mapTreeData,
    mapTreeConds,
    mapTreeConstrs,
33 34
    transformAllBuildInfos,
    transformAllBuildDepends,
35
  ) where
36

37 38
import Prelude ()
import Distribution.Compat.Prelude
39

Duncan Coutts's avatar
Duncan Coutts committed
40
import Distribution.Package
41
import Distribution.PackageDescription
42
import Distribution.PackageDescription.Utils
43
import Distribution.Version
44
import Distribution.Compiler
45
import Distribution.System
46
import Distribution.Simple.Utils
47
import Distribution.Text
48 49
import Distribution.Compat.ReadP as ReadP hiding ( char )
import qualified Distribution.Compat.ReadP as ReadP ( char )
50
import Distribution.Types.ComponentRequestedSpec
51

52
import qualified Data.Map as Map
53
import Data.Tree ( Tree(Node) )
54

55 56
------------------------------------------------------------------------------

57 58
-- | Simplify the condition and return its free variables.
simplifyCondition :: Condition c
59 60
                  -> (c -> Either d Bool)   -- ^ (partial) variable assignment
                  -> (Condition d, [d])
61
simplifyCondition cond i = fv . walk $ cond
62
  where
63
    walk cnd = case cnd of
64
      Var v   -> either Var Lit (i v)
65 66 67 68 69 70 71
      Lit b   -> Lit b
      CNot c  -> case walk c of
                   Lit True -> Lit False
                   Lit False -> Lit True
                   c' -> CNot c'
      COr c d -> case (walk c, walk d) of
                   (Lit False, d') -> d'
72
                   (Lit True, _)   -> Lit True
73
                   (c', Lit False) -> c'
74
                   (_, Lit True)   -> Lit True
75 76 77 78 79 80 81
                   (c',d')         -> COr c' d'
      CAnd c d -> case (walk c, walk d) of
                    (Lit False, _) -> Lit False
                    (Lit True, d') -> d'
                    (_, Lit False) -> Lit False
                    (c', Lit True) -> c'
                    (c',d')        -> CAnd c' d'
82
    -- gather free vars
83 84
    fv c = (c, fv' c)
    fv' c = case c of
85
      Var v     -> [v]
86
      Lit _      -> []
87 88 89 90
      CNot c'    -> fv' c'
      COr c1 c2  -> fv' c1 ++ fv' c2
      CAnd c1 c2 -> fv' c1 ++ fv' c2

Ian D. Bollinger's avatar
Ian D. Bollinger committed
91
-- | Simplify a configuration condition using the OS and arch names.  Returns
92
--   the names of all the flags occurring in the condition.
93
simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar
94
                      -> (Condition FlagName, [FlagName])
95
simplifyWithSysParams os arch cinfo cond = (cond', flags)
96
  where
97
    (cond', flags) = simplifyCondition cond interp
98
    interp (OS os')    = Right $ os' == os
99
    interp (Arch arch') = Right $ arch' == arch
100 101 102 103 104 105 106 107 108 109
    interp (Impl comp vr)
      | matchImpl (compilerInfoId cinfo) = Right True
      | otherwise = case compilerInfoCompat cinfo of
          -- fixme: treat Nothing as unknown, rather than empty list once we
          --        support partial resolution of system parameters
          Nothing     -> Right False
          Just compat -> Right (any matchImpl compat)
          where
            matchImpl (CompilerId c v) = comp == c && v `withinRange` vr
    interp (Flag f) = Left f
110

111
-- TODO: Add instances and check
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
--
-- prop_sC_idempotent cond a o = cond' == cond''
--   where
--     cond'  = simplifyCondition cond a o
--     cond'' = simplifyCondition cond' a o
--
-- prop_sC_noLits cond a o = isLit res || not (hasLits res)
--   where
--     res = simplifyCondition cond a o
--     hasLits (Lit _) = True
--     hasLits (CNot c) = hasLits c
--     hasLits (COr l r) = hasLits l || hasLits r
--     hasLits (CAnd l r) = hasLits l || hasLits r
--     hasLits _ = False
--
127

128
-- | Parse a configuration condition from a string.
129
parseCondition :: ReadP r (Condition ConfVar)
130 131 132 133
parseCondition = condOr
  where
    condOr   = sepBy1 condAnd (oper "||") >>= return . foldl1 COr
    condAnd  = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd
134
    cond     = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond
135
                      +++ archCond +++ flagCond +++ implCond )
136
    inparens   = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp)
137
    notCond  = ReadP.char '!' >> sp >> cond >>= return . CNot
138 139
    osCond   = string "os" >> sp >> inparens osIdent >>= return . Var
    archCond = string "arch" >> sp >> inparens archIdent >>= return . Var
140
    flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var
141
    implCond = string "impl" >> sp >> inparens implIdent >>= return . Var
142
    boolLiteral   = fmap Lit  parse
143 144
    archIdent     = fmap Arch parse
    osIdent       = fmap OS   parse
145
    flagIdent     = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar)
146
    isIdentChar c = isAlphaNum c || c == '_' || c == '-'
147 148
    oper s        = sp >> string s >> sp
    sp            = skipSpaces
149
    implIdent     = do i <- parse
Duncan Coutts's avatar
Duncan Coutts committed
150
                       vr <- sp >> option anyVersion parse
151
                       return $ Impl i vr
152

153 154
------------------------------------------------------------------------------

155
mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
156 157 158 159 160 161 162 163 164 165 166 167
            -> CondTree v c a -> CondTree w d b
mapCondTree fa fc fcnd (CondNode a c ifs) =
    CondNode (fa a) (fc c) (map g ifs)
  where
    g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t,
                           fmap (mapCondTree fa fc fcnd) me)

mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
mapTreeConstrs f = mapCondTree id f id

mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
mapTreeConds f = mapCondTree id id f
168

169 170
mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
mapTreeData f = mapCondTree f id id
171

172 173
-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for
--   clarity.
174
data DepTestRslt d = DepOk | MissingDeps d
175

176
instance Semigroup d => Monoid (DepTestRslt d) where
177
    mempty = DepOk
178
    mappend = (<>)
179

180 181 182 183
instance Semigroup d => Semigroup (DepTestRslt d) where
    DepOk <> x     = x
    x     <> DepOk = x
    (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')
184

185

Mikhail Glushenkov's avatar
Typo.  
Mikhail Glushenkov committed
186
-- | Try to find a flag assignment that satisfies the constraints of all trees.
187 188 189 190
--
-- Returns either the missing dependencies, or a tuple containing the
-- resulting data, the associated dependencies, and the chosen flag
-- assignments.
191
--
192 193 194
-- In case of failure, the union of the dependencies that led to backtracking
-- on all branches is returned.
-- [TODO: Could also be specified with a function argument.]
195
--
196
-- TODO: The current algorithm is rather naive.  A better approach would be to:
197 198 199 200 201 202 203 204
--
-- * Rule out possible paths, by taking a look at the associated dependencies.
--
-- * Infer the required values for the conditions of these paths, and
--   calculate the required domains for the variables used in these
--   conditions.  Then picking a flag assignment would be linear (I guess).
--
-- This would require some sort of SAT solving, though, thus it's not
Ian Lynagh's avatar
Ian Lynagh committed
205
-- implemented unless we really need it.
206
--
207
resolveWithFlags ::
208
     [(FlagName,[Bool])]
209
        -- ^ Domain for each flag name, will be tested in order.
210
  -> ComponentRequestedSpec
211
  -> OS      -- ^ OS as returned by Distribution.System.buildOS
212
  -> Arch    -- ^ Arch as returned by Distribution.System.buildArch
213
  -> CompilerInfo  -- ^ Compiler information
214
  -> [Dependency]  -- ^ Additional constraints
215
  -> [CondTree ConfVar [Dependency] PDTagged]
216
  -> ([Dependency] -> DepTestRslt [Dependency])  -- ^ Dependency test function.
217
  -> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
218 219
       -- ^ Either the missing dependencies (error case), or a pair of
       -- (set of build targets with dependencies, chosen flag assignments)
220
resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
221
    either (Left . fromDepMapUnion) Right $ explore (build [] dom)
222
  where
223
    extraConstrs = toDepMap constrs
224

225 226
    -- simplify trees by (partially) evaluating all conditions and converting
    -- dependencies to dependency maps.
227
    simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged]
228
    simplifiedTrees = map ( mapTreeConstrs toDepMap  -- convert to maps
229
                          . addBuildableCondition pdTaggedBuildInfo
230 231
                          . mapTreeConds (fst . simplifyWithSysParams os arch impl))
                          trees
232

233 234 235 236 237 238 239 240
    -- @explore@ searches a tree of assignments, backtracking whenever a flag
    -- introduces a dependency that cannot be satisfied.  If there is no
    -- solution, @explore@ returns the union of all dependencies that caused
    -- it to backtrack.  Since the tree is constructed lazily, we avoid some
    -- computation overhead in the successful case.
    explore :: Tree FlagAssignment
            -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)
    explore (Node flags ts) =
241 242 243 244
        let targetSet = TargetSet $ flip map simplifiedTrees $
                -- apply additional constraints to all dependencies
                first (`constrainBy` extraConstrs) .
                simplifyCondTree (env flags)
245
            deps = overallDependencies enabled targetSet
246
        in case checkDeps (fromDepMap deps) of
247 248 249 250 251 252 253 254 255 256 257 258
             DepOk | null ts   -> Right (targetSet, flags)
                   | otherwise -> tryAll $ map explore ts
             MissingDeps mds   -> Left (toDepMapUnion mds)

    -- Builds a tree of all possible flag assignments.  Internal nodes
    -- have only partial assignments.
    build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment
    build assigned [] = Node assigned []
    build assigned ((fn, vals) : unassigned) =
        Node assigned $ map (\v -> build ((fn, v) : assigned) unassigned) vals

    tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a
259 260
    tryAll = foldr mp mz

261
    -- special version of `mplus' for our local purposes
262
    mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a
263
    mp m@(Right _) _           = m
264 265 266 267 268 269
    mp _           m@(Right _) = m
    mp (Left xs)   (Left ys)   =
        let union = Map.foldrWithKey (Map.insertWith' combine)
                    (unDepMapUnion xs) (unDepMapUnion ys)
            combine x y = simplifyVersionRange $ unionVersionRanges x y
        in union `seq` Left (DepMapUnion union)
270 271

    -- `mzero'
272 273
    mz :: Either DepMapUnion a
    mz = Left (DepMapUnion Map.empty)
274

kristenk's avatar
kristenk committed
275
    env :: FlagAssignment -> FlagName -> Either FlagName Bool
276
    env flags flag = (maybe (Left flag) Right . lookup flag) flags
277

278
    pdTaggedBuildInfo :: PDTagged -> BuildInfo
279 280
    pdTaggedBuildInfo (Lib l) = libBuildInfo l
    pdTaggedBuildInfo (SubLib _ l) = libBuildInfo l
281 282 283 284 285
    pdTaggedBuildInfo (Exe _ e) = buildInfo e
    pdTaggedBuildInfo (Test _ t) = testBuildInfo t
    pdTaggedBuildInfo (Bench _ b) = benchmarkBuildInfo b
    pdTaggedBuildInfo PDNull = mempty

286 287 288 289
-- | Transforms a 'CondTree' by putting the input under the "then" branch of a
-- conditional that is True when Buildable is True. If 'addBuildableCondition'
-- can determine that Buildable is always True, it returns the input unchanged.
-- If Buildable is always False, it returns the empty 'CondTree'.
290 291 292 293 294 295 296 297 298
addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo)
                      -> CondTree v c a
                      -> CondTree v c a
addBuildableCondition getInfo t =
  case extractCondition (buildable . getInfo) t of
    Lit True  -> t
    Lit False -> CondNode mempty mempty []
    c         -> CondNode mempty mempty [(c, t, Nothing)]

299 300
-- Note: extracting buildable conditions.
-- --------------------------------------
301
--
302 303 304 305 306
-- If the conditions in a cond tree lead to Buildable being set to False, then
-- none of the dependencies for this cond tree should actually be taken into
-- account. On the other hand, some of the flags may only be decided in the
-- solver, so we cannot necessarily make the decision whether a component is
-- Buildable or not prior to solving.
307
--
308 309 310 311 312 313 314 315 316
-- What we are doing here is to partially evaluate a condition tree in order to
-- extract the condition under which Buildable is True. The predicate determines
-- whether data under a 'CondTree' is buildable.


-- | Extract the condition matched by the given predicate from a cond tree.
--
-- We use this mainly for extracting buildable conditions (see the Note above),
-- but the function is in fact more general.
317 318 319 320 321 322 323 324 325 326 327 328
extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
extractCondition p = go
  where
    go (CondNode x _ cs) | not (p x) = Lit False
                         | otherwise = goList cs

    goList []               = Lit True
    goList ((c, t, e) : cs) =
      let
        ct = go t
        ce = maybe (Lit True) go e
      in
329 330 331 332 333 334 335 336
        ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs

-- | Extract conditions matched by the given predicate from all cond trees in a
-- 'GenericPackageDescription'.
extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription
                     -> [Condition ConfVar]
extractConditions f gpkg =
  concat [
337 338
      extractCondition (f . libBuildInfo)             <$> maybeToList (condLibrary gpkg)
    , extractCondition (f . libBuildInfo)       . snd <$> condSubLibraries   gpkg
339 340 341 342 343
    , extractCondition (f . buildInfo)          . snd <$> condExecutables gpkg
    , extractCondition (f . testBuildInfo)      . snd <$> condTestSuites  gpkg
    , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks  gpkg
    ]

344 345 346 347 348 349

-- | A map of dependencies that combines version ranges using 'unionVersionRanges'.
newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName VersionRange }

toDepMapUnion :: [Dependency] -> DepMapUnion
toDepMapUnion ds =
350
  DepMapUnion $ Map.fromListWith unionVersionRanges [ (p,vr) | Dependency p vr <- ds ]
351 352

fromDepMapUnion :: DepMapUnion -> [Dependency]
353
fromDepMapUnion m = [ Dependency p vr | (p,vr) <- Map.toList (unDepMapUnion m) ]
354

nominolo@gmail.com's avatar
nominolo@gmail.com committed
355
-- | A map of dependencies.  Newtyped since the default monoid instance is not
Duncan Coutts's avatar
Duncan Coutts committed
356
--   appropriate.  The monoid instance uses 'intersectVersionRanges'.
Duncan Coutts's avatar
Duncan Coutts committed
357
newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange }
358
  deriving (Show, Read)
359

nominolo@gmail.com's avatar
nominolo@gmail.com committed
360
instance Monoid DependencyMap where
361
    mempty = DependencyMap Map.empty
362
    mappend = (<>)
363 364 365

instance Semigroup DependencyMap where
    (DependencyMap a) <> (DependencyMap b) =
366
        DependencyMap (Map.unionWith intersectVersionRanges a b)
nominolo@gmail.com's avatar
nominolo@gmail.com committed
367 368

toDepMap :: [Dependency] -> DependencyMap
369
toDepMap ds =
370
  DependencyMap $ Map.fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ]
nominolo@gmail.com's avatar
nominolo@gmail.com committed
371 372

fromDepMap :: DependencyMap -> [Dependency]
373
fromDepMap m = [ Dependency p vr | (p,vr) <- Map.toList (unDependencyMap m) ]
374

375 376
-- | Flattens a CondTree using a partial flag assignment.  When a condition
-- cannot be evaluated, both branches are ignored.
377
simplifyCondTree :: (Monoid a, Monoid d) =>
378 379
                    (v -> Either v Bool)
                 -> CondTree v d a
380 381
                 -> (d, a)
simplifyCondTree env (CondNode a d ifs) =
382
    mconcat $ (d, a) : mapMaybe simplifyIf ifs
383
  where
384
    simplifyIf (cnd, t, me) =
385 386 387
        case simplifyCondition cnd env of
          (Lit True, _) -> Just $ simplifyCondTree env t
          (Lit False, _) -> fmap (simplifyCondTree env) me
388
          _ -> Nothing
389

390 391
-- | Flatten a CondTree.  This will resolve the CondTree by taking all
--  possible paths into account.  Note that since branches represent exclusive
Ian Lynagh's avatar
Ian Lynagh committed
392
--  choices this may not result in a \"sane\" result.
393 394
ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)
ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)
395
  where f (_, t, me) = ignoreConditions t
396
                       : maybeToList (fmap ignoreConditions me)
397

398 399
freeVars :: CondTree ConfVar c a  -> [FlagName]
freeVars t = [ f | Flag f <- freeVars' t ]
400 401 402 403 404 405 406 407 408 409
  where
    freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
    compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
    condfv c = case c of
      Var v      -> [v]
      Lit _      -> []
      CNot c'    -> condfv c'
      COr c1 c2  -> condfv c1 ++ condfv c2
      CAnd c1 c2 -> condfv c1 ++ condfv c2

410 411 412 413 414 415 416 417

------------------------------------------------------------------------------

-- | 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.
418
overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap
419
overallDependencies enabled (TargetSet targets) = mconcat depss
420
  where
421 422
    (depss, _) = unzip $ filter (removeDisabledSections . snd) targets
    removeDisabledSections :: PDTagged -> Bool
423 424 425
    -- UGH. The embedded componentName in the 'Component's here is
    -- BLANK.  I don't know whose fault this is but I'll use the tag
    -- instead. -- ezyang
426 427 428 429 430
    removeDisabledSections (Lib _)     = componentNameRequested enabled CLibName
    removeDisabledSections (SubLib t _) = componentNameRequested enabled (CSubLibName t)
    removeDisabledSections (Exe t _)   = componentNameRequested enabled (CExeName t)
    removeDisabledSections (Test t _)  = componentNameRequested enabled (CTestName t)
    removeDisabledSections (Bench t _) = componentNameRequested enabled (CBenchName t)
431
    removeDisabledSections PDNull      = True
432 433 434 435 436 437 438 439 440 441

-- 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 $
442 443
      Map.foldWithKey tightenConstraint (unDependencyMap left)
                                        (unDependencyMap extra)
444
  where tightenConstraint n c l =
445
            case Map.lookup n l of
446
              Nothing -> l
447
              Just vr -> Map.insert n (intersectVersionRanges vr c) l
448 449 450

-- | Collect up the targets in a TargetSet of tagged targets, storing the
-- dependencies as we go.
ttuegel's avatar
ttuegel committed
451
flattenTaggedTargets :: TargetSet PDTagged ->
452 453
        (Maybe Library
        , [(String, Library)], [(String, Executable)], [(String, TestSuite)]
454
        , [(String, Benchmark)])
455
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], [], []) targets
456
  where
457 458 459 460 461 462 463 464
    untag (_, Lib _) (Just _, _, _, _, _) = userBug "Only one library expected"
    untag (deps, Lib l) (Nothing, libs, exes, tests, bms) =
        (Just l', libs, exes, tests, bms)
      where
        l' = l {
                libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
            }
    untag (deps, SubLib n l) (mb_lib, libs, exes, tests, bms)
465 466 467 468
        | any ((== n) . fst) libs =
          userBug $ "There exist several libs with the same name: '" ++ n ++ "'"
        -- NB: libraries live in a different namespace than everything else
        -- TODO: no, (new-style) TESTS live in same namespace!!
469
        | otherwise = (mb_lib, (n, l'):libs, exes, tests, bms)
470 471 472 473
      where
        l' = l {
                libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
            }
474
    untag (deps, Exe n e) (mb_lib, libs, exes, tests, bms)
475 476 477 478 479 480
        | any ((== n) . fst) exes =
          userBug $ "There exist several exes with the same name: '" ++ n ++ "'"
        | any ((== n) . fst) tests =
          userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"
        | any ((== n) . fst) bms =
          userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"
481
        | otherwise = (mb_lib, libs, (n, e'):exes, tests, bms)
482 483 484 485
      where
        e' = e {
                buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }
            }
486
    untag (deps, Test n t) (mb_lib, libs, exes, tests, bms)
487 488 489 490 491 492
        | any ((== n) . fst) tests =
          userBug $ "There exist several tests with the same name: '" ++ n ++ "'"
        | any ((== n) . fst) exes =
          userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"
        | any ((== n) . fst) bms =
          userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"
493
        | otherwise = (mb_lib, libs, exes, (n, t'):tests, bms)
ttuegel's avatar
ttuegel committed
494 495 496 497 498
      where
        t' = t {
            testBuildInfo = (testBuildInfo t)
                { targetBuildDepends = fromDepMap deps }
            }
499
    untag (deps, Bench n b) (mb_lib, libs, exes, tests, bms)
500 501 502 503 504 505
        | any ((== n) . fst) bms =
          userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"
        | any ((== n) . fst) exes =
          userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"
        | any ((== n) . fst) tests =
          userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"
506
        | otherwise = (mb_lib, libs, exes, tests, (n, b'):bms)
507 508 509 510 511
      where
        b' = b {
            benchmarkBuildInfo = (benchmarkBuildInfo b)
                { targetBuildDepends = fromDepMap deps }
            }
512 513 514
    untag (_, PDNull) x = x  -- actually this should not happen, but let's be liberal


515 516 517 518
------------------------------------------------------------------------------
-- Convert GenericPackageDescription to PackageDescription
--

519
-- ezyang: Arguably, this should be:
520
--      data PDTagged = PDComp Component
521
--                    | PDNull
522 523
data PDTagged = Lib Library
              | SubLib String Library
524 525 526 527 528
              | Exe String Executable
              | Test String TestSuite
              | Bench String Benchmark
              | PDNull
              deriving Show
529 530 531

instance Monoid PDTagged where
    mempty = PDNull
532
    mappend = (<>)
533 534 535 536

instance Semigroup PDTagged where
    PDNull    <> x      = x
    x         <> PDNull = x
537 538
    Lib l     <> Lib l' = Lib (l <> l')
    SubLib n l <> SubLib n' l' | n == n' = SubLib n (l <> l')
539 540 541 542
    Exe n e   <> Exe   n' e' | n == n' = Exe n (e <> e')
    Test n t  <> Test  n' t' | n == n' = Test n (t <> t')
    Bench n b <> Bench n' b' | n == n' = Bench n (b <> b')
    _         <> _  = cabalBug "Cannot combine incompatible tags"
543

nominolo@gmail.com's avatar
nominolo@gmail.com committed
544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560
-- | Create a package description with all configurations resolved.
--
-- This function takes a `GenericPackageDescription` and several environment
-- parameters and tries to generate `PackageDescription` by finding a flag
-- assignment that result in satisfiable dependencies.
--
-- It takes as inputs a not necessarily complete specifications of flags
-- assignments, an optional package index as well as platform parameters.  If
-- some flags are not assigned explicitly, this function will try to pick an
-- assignment that causes this function to succeed.  The package index is
-- optional since on some platforms we cannot determine which packages have
-- been installed before.  When no package index is supplied, every dependency
-- is assumed to be satisfiable, therefore all not explicitly assigned flags
-- will get their default values.
--
-- This function will fail if it cannot find a flag assignment that leads to
-- satisfiable dependencies.  (It will not try alternative assignments for
561 562 563 564
-- explicitly specified flags.)  In case of failure it will return the missing
-- dependencies that it encountered when trying different flag assignments.
-- On success, it will return the package description and the full flag
-- assignment chosen.
565
--
566 567 568 569
-- Note that this drops any stanzas which have @buildable: False@.  While
-- this is arguably the right thing to do, it means we give bad error
-- messages in some situations, see #3858.
--
570
finalizePD ::
571
     FlagAssignment  -- ^ Explicitly specified flag assignments
572
  -> ComponentRequestedSpec
Ian D. Bollinger's avatar
Ian D. Bollinger committed
573
  -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
574 575
                          -- available packages?  If this is unknown then use
                          -- True.
576
  -> Platform      -- ^ The 'Arch' and 'OS'
577
  -> CompilerInfo  -- ^ Compiler information
578
  -> [Dependency]  -- ^ Additional constraints
579 580
  -> GenericPackageDescription
  -> Either [Dependency]
581
            (PackageDescription, FlagAssignment)
582 583
             -- ^ Either missing dependencies or the resolved package
             -- description along with the flag assignments chosen.
584
finalizePD userflags enabled satisfyDep
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
585
        (Platform arch os) impl constraints
586
        (GenericPackageDescription pkg flags mb_lib0 sub_libs0 exes0 tests0 bms0) =
587
    case resolveFlags of
588 589 590
      Right ((mb_lib', sub_libs', exes', tests', bms'), targetSet, flagVals) ->
        Right ( pkg { library = mb_lib'
                    , subLibraries = sub_libs'
591
                    , executables = exes'
592
                    , testSuites = tests'
593
                    , benchmarks = bms'
594
                    , buildDepends = fromDepMap (overallDependencies enabled targetSet)
595 596
                    }
              , flagVals )
597

598
      Left missing -> Left missing
599
  where
ttuegel's avatar
ttuegel committed
600
    -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data
601 602
    condTrees =    maybeToList (fmap (mapTreeData Lib) mb_lib0)
                ++ map (\(name,tree) -> mapTreeData (SubLib name) tree) sub_libs0
603
                ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0
ttuegel's avatar
ttuegel committed
604
                ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0
605
                ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0
606 607

    resolveFlags =
608
        case resolveWithFlags flagChoices enabled os arch impl constraints condTrees check of
609
          Right (targetSet, fs) ->
610 611 612
              let (mb_lib, sub_libs, exes, tests, bms) = flattenTaggedTargets targetSet in
              Right ( (fmap (\l -> (libFillInDefaults l) { libName = Nothing }) mb_lib,
                       map (\(n,l) -> (libFillInDefaults l) { libName = Just n }) sub_libs,
ttuegel's avatar
ttuegel committed
613
                       map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,
614 615
                       map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests,
                       map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),
616
                     targetSet, fs)
617 618
          Left missing      -> Left missing

619 620 621 622 623 624
    flagChoices    = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags
    d2c manual n b = case lookup n userflags of
                     Just val -> [val]
                     Nothing
                      | manual -> [b]
                      | otherwise -> [b, not b]
625
    --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
626 627 628 629
    check ds     = let missingDeps = filter (not . satisfyDep) ds
                   in if null missingDeps
                      then DepOk
                      else MissingDeps missingDeps
630

631
{-# DEPRECATED finalizePackageDescription "This function now always assumes tests and benchmarks are disabled; use finalizePD with ComponentRequestedSpec to specify something more specific." #-}
632 633 634 635 636 637 638 639 640 641 642
finalizePackageDescription ::
     FlagAssignment  -- ^ Explicitly specified flag assignments
  -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of
                          -- available packages?  If this is unknown then use
                          -- True.
  -> Platform      -- ^ The 'Arch' and 'OS'
  -> CompilerInfo  -- ^ Compiler information
  -> [Dependency]  -- ^ Additional constraints
  -> GenericPackageDescription
  -> Either [Dependency]
            (PackageDescription, FlagAssignment)
643
finalizePackageDescription flags = finalizePD flags defaultComponentRequestedSpec
644

645 646 647 648
{-
let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])
let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] [])

649 650
let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])]
let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index
651 652 653 654
let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds
resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks   ===>  Right ...
resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks  ===>  Left ...
-}
655 656 657 658 659 660 661

-- | Flatten a generic package description by ignoring all conditions and just
-- join the field descriptors into on package description.  Note, however,
-- that this may lead to inconsistent field values, since all values are
-- joined into one field, which may not be possible in the original package
-- description, due to the use of exclusive choices (if ... else ...).
--
662
-- TODO: One particularly tricky case is defaulting.  In the original package
nominolo@gmail.com's avatar
nominolo@gmail.com committed
663
-- description, e.g., the source directory might either be the default or a
664 665 666 667 668
-- certain, explicitly set path.  Since defaults are filled in only after the
-- package has been resolved and when no explicit value has been set, the
-- default path will be missing from the package description returned by this
-- function.
flattenPackageDescription :: GenericPackageDescription -> PackageDescription
669 670 671
flattenPackageDescription (GenericPackageDescription pkg _ mlib0 sub_libs0 exes0 tests0 bms0) =
    pkg { library = mlib
        , subLibraries = reverse sub_libs
672
        , executables = reverse exes
673
        , testSuites = reverse tests
674
        , benchmarks = reverse bms
675
        , buildDepends = ldeps ++ reverse sub_ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps
676 677
        }
  where
678 679 680 681 682
    (mlib, ldeps) = case mlib0 of
        Just lib -> let (l,ds) = ignoreConditions lib in
                    (Just ((libFillInDefaults l) { libName = Nothing }), ds)
        Nothing -> (Nothing, [])
    (sub_libs, sub_ldeps) = foldr flattenLib ([],[]) sub_libs0
683
    (exes, edeps) = foldr flattenExe ([],[]) exes0
ttuegel's avatar
ttuegel committed
684
    (tests, tdeps) = foldr flattenTst ([],[]) tests0
685
    (bms, bdeps) = foldr flattenBm ([],[]) bms0
686 687
    flattenLib (n, t) (es, ds) =
        let (e, ds') = ignoreConditions t in
688
        ( (libFillInDefaults $ e { libName = Just n }) : es, ds' ++ ds )
689 690 691
    flattenExe (n, t) (es, ds) =
        let (e, ds') = ignoreConditions t in
        ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )
ttuegel's avatar
ttuegel committed
692 693 694
    flattenTst (n, t) (es, ds) =
        let (e, ds') = ignoreConditions t in
        ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds )
695 696 697
    flattenBm (n, t) (es, ds) =
        let (e, ds') = ignoreConditions t in
        ( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds )
698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713

-- This is in fact rather a hack.  The original version just overrode the
-- default values, however, when adding conditions we had to switch to a
-- modifier-based approach.  There, nothing is ever overwritten, but only
-- joined together.
--
-- This is the cleanest way i could think of, that doesn't require
-- changing all field parsing functions to return modifiers instead.
libFillInDefaults :: Library -> Library
libFillInDefaults lib@(Library { libBuildInfo = bi }) =
    lib { libBuildInfo = biFillInDefaults bi }

exeFillInDefaults :: Executable -> Executable
exeFillInDefaults exe@(Executable { buildInfo = bi }) =
    exe { buildInfo = biFillInDefaults bi }

714 715
testFillInDefaults :: TestSuite -> TestSuite
testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) =
ttuegel's avatar
ttuegel committed
716 717
    tst { testBuildInfo = biFillInDefaults bi }

718 719 720 721
benchFillInDefaults :: Benchmark -> Benchmark
benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) =
    bm { benchmarkBuildInfo = biFillInDefaults bi }

722 723 724 725 726
biFillInDefaults :: BuildInfo -> BuildInfo
biFillInDefaults bi =
    if null (hsSourceDirs bi)
    then bi { hsSourceDirs = [currentDir] }
    else bi
727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743

-- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@
-- to all nested 'BuildInfo'/'SetupBuildInfo' values.
transformAllBuildInfos :: (BuildInfo -> BuildInfo)
                       -> (SetupBuildInfo -> SetupBuildInfo)
                       -> GenericPackageDescription
                       -> GenericPackageDescription
transformAllBuildInfos onBuildInfo onSetupBuildInfo gpd = gpd'
  where
    onLibrary    lib  = lib { libBuildInfo  = onBuildInfo $ libBuildInfo  lib }
    onExecutable exe  = exe { buildInfo     = onBuildInfo $ buildInfo     exe }
    onTestSuite  tst  = tst { testBuildInfo = onBuildInfo $ testBuildInfo tst }
    onBenchmark  bmk  = bmk { benchmarkBuildInfo =
                                 onBuildInfo $ benchmarkBuildInfo bmk }

    pd = packageDescription gpd
    pd'  = pd {
744 745
      library        = fmap onLibrary        (library pd),
      subLibraries   = map  onLibrary        (subLibraries pd),
746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784
      executables    = map  onExecutable     (executables pd),
      testSuites     = map  onTestSuite      (testSuites pd),
      benchmarks     = map  onBenchmark      (benchmarks pd),
      setupBuildInfo = fmap onSetupBuildInfo (setupBuildInfo pd)
      }

    gpd' = transformAllCondTrees onLibrary onExecutable
           onTestSuite onBenchmark id
           $ gpd { packageDescription = pd' }

-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
-- @build-depends@ fields.
transformAllBuildDepends :: (Dependency -> Dependency)
                         -> GenericPackageDescription
                         -> GenericPackageDescription
transformAllBuildDepends f gpd = gpd'
  where
    onBI  bi  = bi  { targetBuildDepends = map f $ targetBuildDepends bi }
    onSBI stp = stp { setupDepends       = map f $ setupDepends stp      }
    onPD  pd  = pd  { buildDepends       = map f $ buildDepends pd       }

    pd'   = onPD $ packageDescription gpd
    gpd'  = transformAllCondTrees id id id id (map f)
            . transformAllBuildInfos onBI onSBI
            $ gpd { packageDescription = pd' }

-- | Walk all 'CondTree's inside a 'GenericPackageDescription' and apply
-- appropriate transformations to all nodes. Helper function used by
-- 'transformAllBuildDepends' and 'transformAllBuildInfos'.
transformAllCondTrees :: (Library -> Library)
                      -> (Executable -> Executable)
                      -> (TestSuite -> TestSuite)
                      -> (Benchmark -> Benchmark)
                      -> ([Dependency] -> [Dependency])
                      -> GenericPackageDescription -> GenericPackageDescription
transformAllCondTrees onLibrary onExecutable
  onTestSuite onBenchmark onDepends gpd = gpd'
  where
    gpd'    = gpd {
785 786
      condLibrary        = condLib',
      condSubLibraries   = condSubLibs',
787 788 789 790 791
      condExecutables    = condExes',
      condTestSuites     = condTests',
      condBenchmarks     = condBenchs'
      }

792 793
    condLib    = condLibrary        gpd
    condSubLibs = condSubLibraries  gpd
794 795 796 797
    condExes   = condExecutables    gpd
    condTests  = condTestSuites     gpd
    condBenchs = condBenchmarks     gpd

798 799
    condLib'    = fmap (onCondTree onLibrary) condLib
    condSubLibs' = map (mapSnd $ onCondTree onLibrary)    condSubLibs
800 801 802 803 804 805 806 807 808 809
    condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes
    condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests
    condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs

    mapSnd :: (a -> b) -> (c,a) -> (c,b)
    mapSnd = fmap

    onCondTree :: (a -> b) -> CondTree v [Dependency] a
               -> CondTree v [Dependency] b
    onCondTree g = mapCondTree g onDepends id