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