DSL.hs 25.1 KB
Newer Older
1
{-# LANGUAGE RecordWildCards #-}
2
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3
{-# LANGUAGE ScopedTypeVariables #-}
4
-- | DSL for testing the modular solver
5
module UnitTests.Distribution.Solver.Modular.DSL (
6
    ExampleDependency(..)
7
  , Dependencies(..)
8
  , ExTest(..)
9
  , ExExe(..)
10
  , ExPreference(..)
11
  , ExampleDb
12
13
  , ExampleVersionRange
  , ExamplePkgVersion
14
15
16
  , ExamplePkgName
  , ExampleAvailable(..)
  , ExampleInstalled(..)
17
18
  , ExampleQualifier(..)
  , ExampleVar(..)
19
  , EnableAllTests(..)
20
21
  , exAv
  , exInst
22
  , exFlag
23
24
25
  , exResolve
  , extractInstallPlan
  , withSetupDeps
26
27
  , withTest
  , withTests
28
29
  , withExe
  , withExes
30
  , runProgress
31
32
  ) where

kristenk's avatar
kristenk committed
33
34
35
import Prelude ()
import Distribution.Client.Compat.Prelude

36
37
-- base
import Data.Either (partitionEithers)
kristenk's avatar
kristenk committed
38
import Data.List (elemIndex)
39
import Data.Ord (comparing)
40
41
42
import qualified Data.Map as Map

-- Cabal
43
44
import qualified Distribution.Compiler                 as C
import qualified Distribution.InstalledPackageInfo     as IPI
45
46
import           Distribution.License (License(..))
import qualified Distribution.ModuleName               as Module
47
import qualified Distribution.Package                  as C
48
  hiding (HasUnitId(..))
49
import qualified Distribution.PackageDescription       as C
50
import qualified Distribution.PackageDescription.Check as C
51
import qualified Distribution.Simple.PackageIndex      as C.PackageIndex
52
import           Distribution.Simple.Setup (BooleanFlag(..))
53
import qualified Distribution.System                   as C
54
import           Distribution.Text (display)
55
56
import qualified Distribution.Version                  as C
import Language.Haskell.Extension (Extension(..), Language(..))
57
58
59
60
61

-- cabal-install
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
import Distribution.Client.Types
62
import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan
63
64
65

import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
66
import           Distribution.Solver.Types.ConstraintSource
67
import           Distribution.Solver.Types.LabeledPackageConstraint
68
69
import           Distribution.Solver.Types.OptionalStanza
import qualified Distribution.Solver.Types.PackageIndex      as CI.PackageIndex
70
import qualified Distribution.Solver.Types.PackagePath as P
71
72
73
74
import qualified Distribution.Solver.Types.PkgConfigDb as PC
import           Distribution.Solver.Types.Settings
import           Distribution.Solver.Types.SolverPackage
import           Distribution.Solver.Types.SourcePackage
75
import           Distribution.Solver.Types.Variable
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

{-------------------------------------------------------------------------------
  Example package database DSL

  In order to be able to set simple examples up quickly, we define a very
  simple version of the package database here explicitly designed for use in
  tests.

  The design of `ExampleDb` takes the perspective of the solver, not the
  perspective of the package DB. This makes it easier to set up tests for
  various parts of the solver, but makes the mapping somewhat awkward,  because
  it means we first map from "solver perspective" `ExampleDb` to the package
  database format, and then the modular solver internally in `IndexConversion`
  maps this back to the solver specific data structures.

  IMPLEMENTATION NOTES
  --------------------

  TODO: Perhaps these should be made comments of the corresponding data type
  definitions. For now these are just my own conclusions and may be wrong.

  * The difference between `GenericPackageDescription` and `PackageDescription`
    is that `PackageDescription` describes a particular _configuration_ of a
    package (for instance, see documentation for `checkPackage`). A
Mikhail Glushenkov's avatar
Typo.    
Mikhail Glushenkov committed
100
    `GenericPackageDescription` can be turned into a `PackageDescription` in
101
102
    two ways:

103
      a. `finalizePD` does the proper translation, by taking
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
         into account the platform, available dependencies, etc. and picks a
         flag assignment (or gives an error if no flag assignment can be found)
      b. `flattenPackageDescription` ignores flag assignment and just joins all
         components together.

    The slightly odd thing is that a `GenericPackageDescription` contains a
    `PackageDescription` as a field; both of the above functions do the same
    thing: they take the embedded `PackageDescription` as a basis for the result
    value, but override `library`, `executables`, `testSuites`, `benchmarks`
    and `buildDepends`.
  * The `condTreeComponents` fields of a `CondTree` is a list of triples
    `(condition, then-branch, else-branch)`, where the `else-branch` is
    optional.
-------------------------------------------------------------------------------}

type ExamplePkgName    = String
type ExamplePkgVersion = Int
type ExamplePkgHash    = String  -- for example "installed" packages
type ExampleFlagName   = String
type ExampleTestName   = String
124
type ExampleExeName    = String
125
type ExampleVersionRange = C.VersionRange
126

127
data Dependencies = NotBuildable | Buildable [ExampleDependency]
128
  deriving Show
129
130
131
132
133
134
135
136

data ExampleDependency =
    -- | Simple dependency on any version
    ExAny ExamplePkgName

    -- | Simple dependency on a fixed version
  | ExFix ExamplePkgName ExamplePkgVersion

137
138
139
140
141
142
    -- | Build-tools dependency
  | ExBuildToolAny ExamplePkgName

    -- | Build-tools dependency on a fixed version
  | ExBuildToolFix ExamplePkgName ExamplePkgVersion

143
    -- | Dependencies indexed by a flag
144
  | ExFlag ExampleFlagName Dependencies Dependencies
145

146
147
148
149
150
151
    -- | Dependency on a language extension
  | ExExt Extension

    -- | Dependency on a language version
  | ExLang Language

152
153
    -- | Dependency on a pkg-config package
  | ExPkg (ExamplePkgName, ExamplePkgVersion)
154
  deriving Show
155

156
157
data ExTest = ExTest ExampleTestName [ExampleDependency]

158
159
data ExExe = ExExe ExampleExeName [ExampleDependency]

160
161
162
163
exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]
       -> ExampleDependency
exFlag n t e = ExFlag n (Buildable t) (Buildable e)

164
165
166
data ExPreference =
    ExPkgPref ExamplePkgName ExampleVersionRange
  | ExStanzaPref ExamplePkgName [OptionalStanza]
167

168
169
170
171
data ExampleAvailable = ExAv {
    exAvName    :: ExamplePkgName
  , exAvVersion :: ExamplePkgVersion
  , exAvDeps    :: ComponentDeps [ExampleDependency]
172
  } deriving Show
173

174
175
176
177
178
179
180
181
182
183
184
data ExampleVar =
    P ExampleQualifier ExamplePkgName
  | F ExampleQualifier ExamplePkgName ExampleFlagName
  | S ExampleQualifier ExamplePkgName OptionalStanza

data ExampleQualifier =
    None
  | Indep Int
  | Setup ExamplePkgName
  | IndepSetup Int ExamplePkgName

185
186
-- | Whether to enable tests in all packages in a test case.
newtype EnableAllTests = EnableAllTests Bool
187
  deriving BooleanFlag
188

189
190
191
192
193
194
195
196
197
-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',
-- given:
--
--      1. The name 'ExamplePkgName' of the available package,
--      2. The version 'ExamplePkgVersion' available
--      3. The list of dependency constraints 'ExampleDependency'
--         that this package has.  'ExampleDependency' provides
--         a number of pre-canned dependency types to look at.
--
198
199
200
exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]
     -> ExampleAvailable
exAv n v ds = ExAv { exAvName = n, exAvVersion = v
201
                   , exAvDeps = CD.fromLibraryDeps ds }
202
203
204
205
206
207

withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable
withSetupDeps ex setupDeps = ex {
      exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps
    }

208
209
210
211
212
213
214
215
216
withTest :: ExampleAvailable -> ExTest -> ExampleAvailable
withTest ex test = withTests ex [test]

withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable
withTests ex tests =
  let testCDs = CD.fromList [(CD.ComponentTest name, deps)
                            | ExTest name deps <- tests]
  in ex { exAvDeps = exAvDeps ex <> testCDs }

217
218
219
220
221
222
223
224
225
withExe :: ExampleAvailable -> ExExe -> ExampleAvailable
withExe ex exe = withExes ex [exe]

withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable
withExes ex exes =
  let exeCDs = CD.fromList [(CD.ComponentExe name, deps)
                           | ExExe name deps <- exes]
  in ex { exAvDeps = exAvDeps ex <> exeCDs }

226
-- | An installed package in 'ExampleDb'; construct me with 'exInst'.
227
228
229
230
data ExampleInstalled = ExInst {
    exInstName         :: ExamplePkgName
  , exInstVersion      :: ExamplePkgVersion
  , exInstHash         :: ExamplePkgHash
231
232
  , exInstBuildAgainst :: [ExamplePkgHash]
  } deriving Show
233

234
235
236
237
238
239
240
241
242
-- | Constructs an example installed package given:
--
--      1. The name of the package 'ExamplePkgName', i.e., 'String'
--      2. The version of the package 'ExamplePkgVersion', i.e., 'Int'
--      3. The IPID for the package 'ExamplePkgHash', i.e., 'String'
--         (just some unique identifier for the package.)
--      4. The 'ExampleInstalled' packages which this package was
--         compiled against.)
--
243
244
exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash
       -> [ExampleInstalled] -> ExampleInstalled
245
exInst pn v hash deps = ExInst pn v hash (map exInstHash deps)
246

247
248
249
250
-- | An example package database is a list of installed packages
-- 'ExampleInstalled' and available packages 'ExampleAvailable'.
-- Generally, you want to use 'exInst' and 'exAv' to construct
-- these packages.
251
252
253
254
type ExampleDb = [Either ExampleInstalled ExampleAvailable]

type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a

255
256
257
258
type DependencyComponent a = ( C.Condition C.ConfVar
                             , DependencyTree a
                             , Maybe (DependencyTree a))

259
260
261
exDbPkgs :: ExampleDb -> [ExamplePkgName]
exDbPkgs = map (either exInstName exAvName)

262
exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage
263
exAvSrcPkg ex =
264
    let pkgId = exAvPkgId ex
265
        testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]
266
        executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]
267
268
269
270
271
272
        setup = case CD.setupDeps (exAvDeps ex) of
                  []   -> Nothing
                  deps -> Just C.SetupBuildInfo {
                            C.setupDepends = mkSetupDeps deps,
                            C.defaultSetupDepends = False
                          }
273
        package = SourcePackage {
274
275
276
277
278
279
280
281
282
283
284
285
286
            packageInfoId        = pkgId
          , packageSource        = LocalTarballPackage "<<path>>"
          , packageDescrOverride = Nothing
          , packageDescription   = C.GenericPackageDescription {
                C.packageDescription = C.emptyPackageDescription {
                    C.package        = pkgId
                  , C.library        = error "not yet configured: library"
                  , C.subLibraries   = error "not yet configured: subLibraries"
                  , C.executables    = error "not yet configured: executables"
                  , C.testSuites     = error "not yet configured: testSuites"
                  , C.benchmarks     = error "not yet configured: benchmarks"
                  , C.buildDepends   = error "not yet configured: buildDepends"
                  , C.setupBuildInfo = setup
287
288
289
290
291
292
293
294
295
296
                  , C.license = BSD3
                  , C.buildType = if isNothing setup
                                  then Just C.Simple
                                  else Just C.Custom
                  , C.category = "category"
                  , C.maintainer = "maintainer"
                  , C.description = "description"
                  , C.synopsis = "synopsis"
                  , C.licenseFiles = ["LICENSE"]
                  , C.specVersionRaw = Left $ C.mkVersion [1,12]
297
298
299
300
301
302
303
                  }
              , C.genPackageFlags = nub $ concatMap extractFlags $
                                    CD.libraryDeps (exAvDeps ex)
                                     ++ concatMap snd testSuites
                                     ++ concatMap snd executables
              , C.condLibrary =
                  let mkLib bi = mempty { C.libBuildInfo = bi }
304
                  in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $
305
306
307
                     Buildable (CD.libraryDeps (exAvDeps ex))
              , C.condSubLibraries = []
              , C.condExecutables =
308
                  let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable
309
310
311
                      mkExe bi = mempty { C.buildInfo = bi }
                  in map (\(t, deps) -> (t, mkTree deps)) executables
              , C.condTestSuites =
312
                  let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable
313
314
315
316
317
                      mkTest bi = mempty { C.testBuildInfo = bi }
                  in map (\(t, deps) -> (t, mkTree deps)) testSuites
              , C.condBenchmarks  = []
              }
            }
318
319
320
321
322
323
324
325
        pkgCheckErrors =
          let ignore = ["Unknown extensions:", "Unknown languages:"]
          in [ err | err <- C.checkPackage (packageDescription package) Nothing
             , not $ any (`isPrefixOf` C.explanation err) ignore ]
    in if null pkgCheckErrors
       then package
       else error $ "invalid GenericPackageDescription for package "
                 ++ display pkgId ++ ": " ++ show pkgCheckErrors
326
  where
327
328
329
330
331
332
333
334
335
336
337
338
339
340
    defaultTopLevelBuildInfo :: C.BuildInfo
    defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 }

    defaultLib :: C.Library
    defaultLib = mempty { C.exposedModules = [Module.fromString "Module"] }

    defaultExe :: C.Executable
    defaultExe = mempty { C.modulePath = "Main.hs" }

    defaultTest :: C.TestSuite
    defaultTest = mempty {
        C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs"
      }

341
342
    -- Split the set of dependencies into the set of dependencies of the library,
    -- the dependencies of the test suites and extensions.
343
344
    splitTopLevel :: [ExampleDependency]
                  -> ( [ExampleDependency]
345
346
                     , [Extension]
                     , Maybe Language
347
                     , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config
348
                     , [(ExamplePkgName, Maybe Int)] -- build tools
349
                     )
350
    splitTopLevel [] =
351
352
353
354
355
356
357
        ([], [], Nothing, [], [])
    splitTopLevel (ExBuildToolAny p:deps) =
      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps
      in (other, exts, lang, pcpkgs, (p, Nothing):exes)
    splitTopLevel (ExBuildToolFix p v:deps) =
      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps
      in (other, exts, lang, pcpkgs, (p, Just v):exes)
358
    splitTopLevel (ExExt ext:deps) =
359
360
      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps
      in (other, ext:exts, lang, pcpkgs, exes)
361
362
    splitTopLevel (ExLang lang:deps) =
        case splitTopLevel deps of
363
            (other, exts, Nothing, pcpkgs, exes) -> (other, exts, Just lang, pcpkgs, exes)
364
            _ -> error "Only 1 Language dependency is supported"
365
    splitTopLevel (ExPkg pkg:deps) =
366
367
      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps
      in (other, exts, lang, pkg:pcpkgs, exes)
368
    splitTopLevel (dep:deps) =
369
370
      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps
      in (dep:other, exts, lang, pcpkgs, exes)
371
372

    -- Extract the total set of flags used
373
374
375
    extractFlags :: ExampleDependency -> [C.Flag]
    extractFlags (ExAny _)      = []
    extractFlags (ExFix _ _)    = []
376
377
    extractFlags (ExBuildToolAny _)   = []
    extractFlags (ExBuildToolFix _ _) = []
378
379
380
    extractFlags (ExFlag f a b) = C.MkFlag {
                                      C.flagName        = C.FlagName f
                                    , C.flagDescription = ""
381
                                    , C.flagDefault     = True
382
383
                                    , C.flagManual      = False
                                    }
384
385
386
387
388
                                : concatMap extractFlags (deps a ++ deps b)
      where
        deps :: Dependencies -> [ExampleDependency]
        deps NotBuildable = []
        deps (Buildable ds) = ds
389
390
    extractFlags (ExExt _)      = []
    extractFlags (ExLang _)     = []
391
    extractFlags (ExPkg _)      = []
392

393
    -- Convert a tree of BuildInfos into a tree of a specific component type.
394
395
    -- 'defaultTopLevel' contains the default values for the component, and
    -- 'mkComponent' creates a component from a 'BuildInfo'.
kristenk's avatar
kristenk committed
396
    mkCondTree :: forall a. Semigroup a =>
397
                  a -> (C.BuildInfo -> a)
398
399
               -> DependencyTree C.BuildInfo
               -> DependencyTree a
400
    mkCondTree defaultTopLevel mkComponent (C.CondNode topData topConstraints topComps) =
401
        C.CondNode {
402
403
404
405
            C.condTreeData =
                defaultTopLevel <> mkComponent (defaultTopLevelBuildInfo <> topData)
          , C.condTreeConstraints = topConstraints
          , C.condTreeComponents = goComponents topComps
406
407
          }
      where
408
409
410
411
        go :: DependencyTree C.BuildInfo -> DependencyTree a
        go (C.CondNode ctData constraints comps) =
            C.CondNode (mkComponent ctData) constraints (goComponents comps)

412
413
        goComponents :: [DependencyComponent C.BuildInfo]
                     -> [DependencyComponent a]
414
        goComponents comps = [(cond, go t, go <$> me) | (cond, t, me) <- comps]
415
416
417

    mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo
    mkBuildInfoTree NotBuildable =
418
      C.CondNode {
419
             C.condTreeData        = mempty { C.buildable = False }
420
421
422
           , C.condTreeConstraints = []
           , C.condTreeComponents  = []
           }
423
424
425
426
427
428
429
430
431
    mkBuildInfoTree (Buildable deps) =
      let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps
          (directDeps, flaggedDeps) = splitDeps libraryDeps
          bi = mempty {
                  C.otherExtensions = exts
                , C.defaultLanguage = mlang
                , C.buildTools = map mkDirect buildTools
                , C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- pcpkgs]
              }
432
      in C.CondNode {
433
             C.condTreeData        = bi -- Necessary for language extensions
434
435
436
           -- TODO: Arguably, build-tools dependencies should also
           -- effect constraints on conditional tree. But no way to
           -- distinguish between them
437
           , C.condTreeConstraints = map mkDirect directDeps
438
           , C.condTreeComponents  = map mkFlagged flaggedDeps
439
440
441
           }

    mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency
442
443
    mkDirect (dep, Nothing) = C.Dependency (C.mkPackageName dep) C.anyVersion
    mkDirect (dep, Just n)  = C.Dependency (C.mkPackageName dep) (C.thisVersion v)
444
      where
445
        v = C.mkVersion [n, 0, 0]
446

447
448
449
450
451
452
453
    mkFlagged :: (ExampleFlagName, Dependencies, Dependencies)
              -> ( C.Condition C.ConfVar
                 , DependencyTree C.BuildInfo
                 , Maybe (DependencyTree C.BuildInfo))
    mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
                                    , mkBuildInfoTree a
                                    , Just (mkBuildInfoTree b)
454
                                    )
455

456
457
458
459
460
    -- Split a set of dependencies into direct dependencies and flagged
    -- dependencies. A direct dependency is a tuple of the name of package and
    -- maybe its version (no version means any version) meant to be converted
    -- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is
    -- the set of dependencies guarded by a flag.
461
462
    splitDeps :: [ExampleDependency]
              -> ( [(ExamplePkgName, Maybe Int)]
463
                 , [(ExampleFlagName, Dependencies, Dependencies)]
464
465
466
467
468
469
470
471
472
473
474
475
                 )
    splitDeps [] =
      ([], [])
    splitDeps (ExAny p:deps) =
      let (directDeps, flaggedDeps) = splitDeps deps
      in ((p, Nothing):directDeps, flaggedDeps)
    splitDeps (ExFix p v:deps) =
      let (directDeps, flaggedDeps) = splitDeps deps
      in ((p, Just v):directDeps, flaggedDeps)
    splitDeps (ExFlag f a b:deps) =
      let (directDeps, flaggedDeps) = splitDeps deps
      in (directDeps, (f, a, b):flaggedDeps)
476
    splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep
477

478
    -- custom-setup only supports simple dependencies
479
480
481
482
483
484
    mkSetupDeps :: [ExampleDependency] -> [C.Dependency]
    mkSetupDeps deps =
      let (directDeps, []) = splitDeps deps in map mkDirect directDeps

exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
exAvPkgId ex = C.PackageIdentifier {
485
      pkgName    = C.mkPackageName (exAvName ex)
486
    , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]
487
488
    }

489
490
491
492
493
exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo
exInstInfo ex = IPI.emptyInstalledPackageInfo {
      IPI.installedUnitId    = C.mkUnitId (exInstHash ex)
    , IPI.sourcePackageId    = exInstPkgId ex
    , IPI.depends            = map C.mkUnitId (exInstBuildAgainst ex)
494
495
496
497
    }

exInstPkgId :: ExampleInstalled -> C.PackageIdentifier
exInstPkgId ex = C.PackageIdentifier {
498
      pkgName    = C.mkPackageName (exInstName ex)
499
    , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0]
500
501
    }

502
exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage
503
504
505
506
507
508
exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg

exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex
exInstIdx = C.PackageIndex.fromList . map exInstInfo

exResolve :: ExampleDb
509
510
511
512
          -- List of extensions supported by the compiler, or Nothing if unknown.
          -> Maybe [Extension]
          -- List of languages supported by the compiler, or Nothing if unknown.
          -> Maybe [Language]
513
          -> PC.PkgConfigDb
514
          -> [ExamplePkgName]
515
          -> Solver
516
          -> Maybe Int
517
          -> IndependentGoals
518
          -> ReorderGoals
519
          -> EnableBackjumping
520
          -> Maybe [ExampleVar]
521
          -> [ExPreference]
522
          -> EnableAllTests
523
          -> Progress String String CI.SolverInstallPlan.SolverInstallPlan
524
exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
525
          enableBj vars prefs enableAllTests
526
    = resolveDependencies C.buildPlatform compiler pkgConfigDb solver params
527
  where
528
    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
529
530
    compiler = defaultCompiler { C.compilerInfoExtensions = exts
                               , C.compilerInfoLanguages  = langs
531
                               }
532
533
534
535
536
537
    (inst, avai) = partitionEithers db
    instIdx      = exInstIdx inst
    avaiIdx      = SourcePackageDb {
                       packageIndex       = exAvIdx avai
                     , packagePreferences = Map.empty
                     }
538
    enableTests
539
540
541
542
        | asBool enableAllTests = fmap (\p -> PackageConstraintStanzas
                                              (C.mkPackageName p) [TestStanzas])
                                       (exDbPkgs db)
        | otherwise             = []
543
    targets'     = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets
544
545
    params       =   addPreferences (fmap toPref prefs)
                   $ addConstraints (fmap toLpc enableTests)
546
547
                   $ setIndependentGoals indepGoals
                   $ setReorderGoals reorder
548
                   $ setMaxBackjumps mbj
549
                   $ setEnableBackjumping enableBj
550
                   $ setGoalOrder goalOrder
551
                   $ standardInstallPolicy instIdx avaiIdx targets'
552
    toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown
553
554
555

    toPref (ExPkgPref n v)          = PackageVersionPreference (C.mkPackageName n) v
    toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas
556

557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
    goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
    goalOrder = (orderFromList . map toVariable) `fmap` vars

    -- Sort elements in the list ahead of elements not in the list. Otherwise,
    -- follow the order in the list.
    orderFromList :: Eq a => [a] -> a -> a -> Ordering
    orderFromList xs =
        comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)

    toVariable :: ExampleVar -> Variable P.QPN
    toVariable (P q pn)        = PackageVar (toQPN q pn)
    toVariable (F q pn fn)     = FlagVar    (toQPN q pn) (C.FlagName fn)
    toVariable (S q pn stanza) = StanzaVar  (toQPN q pn) stanza

    toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
572
    toQPN q pn = P.Q pp (C.mkPackageName pn)
573
574
575
576
      where
        pp = case q of
               None           -> P.PackagePath P.DefaultNamespace P.Unqualified
               Indep x        -> P.PackagePath (P.Independent x) P.Unqualified
577
578
               Setup p        -> P.PackagePath P.DefaultNamespace (P.Setup (C.mkPackageName p))
               IndepSetup x p -> P.PackagePath (P.Independent x) (P.Setup (C.mkPackageName p))
579

580
extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan
581
                   -> [(ExamplePkgName, ExamplePkgVersion)]
582
extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList
583
  where
584
    confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int)
585
    confPkg (CI.SolverInstallPlan.Configured pkg) = Just $ srcPkg pkg
586
587
    confPkg _                               = Nothing

588
    srcPkg :: SolverPackage UnresolvedPkgLoc -> (String, Int)
589
    srcPkg cpkg =
590
591
      let C.PackageIdentifier pn ver = packageInfoId (solverPkgSource cpkg)
      in (C.unPackageName pn, head (C.versionNumbers ver))
592
593
594
595
596
597
598
599
600
601
602
603

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Run Progress computation
runProgress :: Progress step e a -> ([step], Either e a)
runProgress = go
  where
    go (Step s p) = let (ss, result) = go p in (s:ss, result)
    go (Fail e)   = ([], Left e)
    go (Done a)   = ([], Right a)