1{-# LANGUAGE RecordWildCards #-} 2{-# LANGUAGE GeneralizedNewtypeDeriving #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4{-# LANGUAGE OverloadedStrings #-} 5-- | DSL for testing the modular solver 6module UnitTests.Distribution.Solver.Modular.DSL ( 7 ExampleDependency(..) 8 , Dependencies(..) 9 , ExSubLib(..) 10 , ExTest(..) 11 , ExExe(..) 12 , ExConstraint(..) 13 , ExPreference(..) 14 , ExampleDb 15 , ExampleVersionRange 16 , ExamplePkgVersion 17 , ExamplePkgName 18 , ExampleFlagName 19 , ExFlag(..) 20 , ExampleAvailable(..) 21 , ExampleInstalled(..) 22 , ExampleQualifier(..) 23 , ExampleVar(..) 24 , EnableAllTests(..) 25 , dependencies 26 , publicDependencies 27 , unbuildableDependencies 28 , exAv 29 , exAvNoLibrary 30 , exInst 31 , exSubLib 32 , exTest 33 , exExe 34 , exFlagged 35 , exResolve 36 , extractInstallPlan 37 , declareFlags 38 , withSubLibrary 39 , withSubLibraries 40 , withSetupDeps 41 , withTest 42 , withTests 43 , withExe 44 , withExes 45 , runProgress 46 , mkSimpleVersion 47 , mkVersionRange 48 ) where 49 50import Prelude () 51import Distribution.Solver.Compat.Prelude 52import Distribution.Utils.Generic 53 54-- base 55import Control.Arrow (second) 56import qualified Data.Map as Map 57import qualified Distribution.Compat.NonEmptySet as NonEmptySet 58 59-- Cabal 60import qualified Distribution.CabalSpecVersion as C 61import qualified Distribution.Compiler as C 62import qualified Distribution.InstalledPackageInfo as IPI 63import Distribution.License (License(..)) 64import qualified Distribution.ModuleName as Module 65import qualified Distribution.Package as C 66 hiding (HasUnitId(..)) 67import qualified Distribution.Types.ExeDependency as C 68import qualified Distribution.Types.ForeignLib as C 69import qualified Distribution.Types.LegacyExeDependency as C 70import qualified Distribution.Types.LibraryVisibility as C 71import qualified Distribution.Types.PkgconfigDependency as C 72import qualified Distribution.Types.PkgconfigVersion as C 73import qualified Distribution.Types.PkgconfigVersionRange as C 74import qualified Distribution.Types.UnqualComponentName as C 75import qualified Distribution.Types.CondTree as C 76import qualified Distribution.PackageDescription as C 77import qualified Distribution.PackageDescription.Check as C 78import qualified Distribution.Simple.PackageIndex as C.PackageIndex 79import Distribution.Simple.Setup (BooleanFlag(..)) 80import qualified Distribution.System as C 81import Distribution.Text (display) 82import qualified Distribution.Verbosity as C 83import qualified Distribution.Version as C 84import Language.Haskell.Extension (Extension(..), Language(..)) 85 86-- cabal-install 87import Distribution.Client.Dependency 88import Distribution.Client.Dependency.Types 89import Distribution.Client.Types 90import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan 91 92import Distribution.Solver.Types.ComponentDeps (ComponentDeps) 93import qualified Distribution.Solver.Types.ComponentDeps as CD 94import Distribution.Solver.Types.ConstraintSource 95import Distribution.Solver.Types.Flag 96import Distribution.Solver.Types.LabeledPackageConstraint 97import Distribution.Solver.Types.OptionalStanza 98import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex 99import Distribution.Solver.Types.PackageConstraint 100import qualified Distribution.Solver.Types.PackagePath as P 101import qualified Distribution.Solver.Types.PkgConfigDb as PC 102import Distribution.Solver.Types.Settings 103import Distribution.Solver.Types.SolverPackage 104import Distribution.Solver.Types.SourcePackage 105import Distribution.Solver.Types.Variable 106 107{------------------------------------------------------------------------------- 108 Example package database DSL 109 110 In order to be able to set simple examples up quickly, we define a very 111 simple version of the package database here explicitly designed for use in 112 tests. 113 114 The design of `ExampleDb` takes the perspective of the solver, not the 115 perspective of the package DB. This makes it easier to set up tests for 116 various parts of the solver, but makes the mapping somewhat awkward, because 117 it means we first map from "solver perspective" `ExampleDb` to the package 118 database format, and then the modular solver internally in `IndexConversion` 119 maps this back to the solver specific data structures. 120 121 IMPLEMENTATION NOTES 122 -------------------- 123 124 TODO: Perhaps these should be made comments of the corresponding data type 125 definitions. For now these are just my own conclusions and may be wrong. 126 127 * The difference between `GenericPackageDescription` and `PackageDescription` 128 is that `PackageDescription` describes a particular _configuration_ of a 129 package (for instance, see documentation for `checkPackage`). A 130 `GenericPackageDescription` can be turned into a `PackageDescription` in 131 two ways: 132 133 a. `finalizePD` does the proper translation, by taking 134 into account the platform, available dependencies, etc. and picks a 135 flag assignment (or gives an error if no flag assignment can be found) 136 b. `flattenPackageDescription` ignores flag assignment and just joins all 137 components together. 138 139 The slightly odd thing is that a `GenericPackageDescription` contains a 140 `PackageDescription` as a field; both of the above functions do the same 141 thing: they take the embedded `PackageDescription` as a basis for the result 142 value, but override `library`, `executables`, `testSuites`, `benchmarks` 143 and `buildDepends`. 144 * The `condTreeComponents` fields of a `CondTree` is a list of triples 145 `(condition, then-branch, else-branch)`, where the `else-branch` is 146 optional. 147-------------------------------------------------------------------------------} 148 149type ExamplePkgName = String 150type ExamplePkgVersion = Int 151type ExamplePkgHash = String -- for example "installed" packages 152type ExampleFlagName = String 153type ExampleSubLibName = String 154type ExampleTestName = String 155type ExampleExeName = String 156type ExampleVersionRange = C.VersionRange 157 158data Dependencies = Dependencies { 159 depsVisibility :: C.LibraryVisibility 160 , depsIsBuildable :: Bool 161 , depsExampleDependencies :: [ExampleDependency] 162 } deriving Show 163 164instance Semigroup Dependencies where 165 deps1 <> deps2 = Dependencies { 166 depsVisibility = depsVisibility deps1 <> depsVisibility deps2 167 , depsIsBuildable = depsIsBuildable deps1 && depsIsBuildable deps2 168 , depsExampleDependencies = depsExampleDependencies deps1 ++ depsExampleDependencies deps2 169 } 170 171instance Monoid Dependencies where 172 mempty = Dependencies { 173 depsVisibility = mempty 174 , depsIsBuildable = True 175 , depsExampleDependencies = [] 176 } 177 mappend = (<>) 178 179dependencies :: [ExampleDependency] -> Dependencies 180dependencies deps = mempty { depsExampleDependencies = deps } 181 182publicDependencies :: Dependencies 183publicDependencies = mempty { depsVisibility = C.LibraryVisibilityPublic } 184 185unbuildableDependencies :: Dependencies 186unbuildableDependencies = mempty { depsIsBuildable = False } 187 188data ExampleDependency = 189 -- | Simple dependency on any version 190 ExAny ExamplePkgName 191 192 -- | Simple dependency on a fixed version 193 | ExFix ExamplePkgName ExamplePkgVersion 194 195 -- | Simple dependency on a range of versions, with an inclusive lower bound 196 -- and an exclusive upper bound. 197 | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion 198 199 -- | Sub-library dependency 200 | ExSubLibAny ExamplePkgName ExampleSubLibName 201 202 -- | Sub-library dependency on a fixed version 203 | ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion 204 205 -- | Build-tool-depends dependency 206 | ExBuildToolAny ExamplePkgName ExampleExeName 207 208 -- | Build-tool-depends dependency on a fixed version 209 | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion 210 211 -- | Legacy build-tools dependency 212 | ExLegacyBuildToolAny ExamplePkgName 213 214 -- | Legacy build-tools dependency on a fixed version 215 | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion 216 217 -- | Dependencies indexed by a flag 218 | ExFlagged ExampleFlagName Dependencies Dependencies 219 220 -- | Dependency on a language extension 221 | ExExt Extension 222 223 -- | Dependency on a language version 224 | ExLang Language 225 226 -- | Dependency on a pkg-config package 227 | ExPkg (ExamplePkgName, ExamplePkgVersion) 228 deriving Show 229 230-- | Simplified version of D.Types.GenericPackageDescription.Flag for use in 231-- example source packages. 232data ExFlag = ExFlag { 233 exFlagName :: ExampleFlagName 234 , exFlagDefault :: Bool 235 , exFlagType :: FlagType 236 } deriving Show 237 238data ExSubLib = ExSubLib ExampleSubLibName Dependencies 239 240data ExTest = ExTest ExampleTestName Dependencies 241 242data ExExe = ExExe ExampleExeName Dependencies 243 244exSubLib :: ExampleSubLibName -> [ExampleDependency] -> ExSubLib 245exSubLib name deps = ExSubLib name (dependencies deps) 246 247exTest :: ExampleTestName -> [ExampleDependency] -> ExTest 248exTest name deps = ExTest name (dependencies deps) 249 250exExe :: ExampleExeName -> [ExampleDependency] -> ExExe 251exExe name deps = ExExe name (dependencies deps) 252 253exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] 254 -> ExampleDependency 255exFlagged n t e = ExFlagged n (dependencies t) (dependencies e) 256 257data ExConstraint = 258 ExVersionConstraint ConstraintScope ExampleVersionRange 259 | ExFlagConstraint ConstraintScope ExampleFlagName Bool 260 | ExStanzaConstraint ConstraintScope [OptionalStanza] 261 deriving Show 262 263data ExPreference = 264 ExPkgPref ExamplePkgName ExampleVersionRange 265 | ExStanzaPref ExamplePkgName [OptionalStanza] 266 deriving Show 267 268data ExampleAvailable = ExAv { 269 exAvName :: ExamplePkgName 270 , exAvVersion :: ExamplePkgVersion 271 , exAvDeps :: ComponentDeps Dependencies 272 273 -- Setting flags here is only necessary to override the default values of 274 -- the fields in C.Flag. 275 , exAvFlags :: [ExFlag] 276 } deriving Show 277 278data ExampleVar = 279 P ExampleQualifier ExamplePkgName 280 | F ExampleQualifier ExamplePkgName ExampleFlagName 281 | S ExampleQualifier ExamplePkgName OptionalStanza 282 283data ExampleQualifier = 284 QualNone 285 | QualIndep ExamplePkgName 286 | QualSetup ExamplePkgName 287 288 -- The two package names are the build target and the package containing the 289 -- setup script. 290 | QualIndepSetup ExamplePkgName ExamplePkgName 291 292 -- The two package names are the package depending on the exe and the 293 -- package containing the exe. 294 | QualExe ExamplePkgName ExamplePkgName 295 296-- | Whether to enable tests in all packages in a test case. 297newtype EnableAllTests = EnableAllTests Bool 298 deriving BooleanFlag 299 300-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb', 301-- given: 302-- 303-- 1. The name 'ExamplePkgName' of the available package, 304-- 2. The version 'ExamplePkgVersion' available 305-- 3. The list of dependency constraints ('ExampleDependency') 306-- for this package's library component. 'ExampleDependency' 307-- provides a number of pre-canned dependency types to look at. 308-- 309exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] 310 -> ExampleAvailable 311exAv n v ds = (exAvNoLibrary n v) { exAvDeps = CD.fromLibraryDeps (dependencies ds) } 312 313-- | Constructs an 'ExampleAvailable' package without a default library 314-- component. 315exAvNoLibrary :: ExamplePkgName -> ExamplePkgVersion -> ExampleAvailable 316exAvNoLibrary n v = ExAv { exAvName = n 317 , exAvVersion = v 318 , exAvDeps = CD.empty 319 , exAvFlags = [] } 320 321-- | Override the default settings (e.g., manual vs. automatic) for a subset of 322-- a package's flags. 323declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable 324declareFlags flags ex = ex { 325 exAvFlags = flags 326 } 327 328withSubLibrary :: ExampleAvailable -> ExSubLib -> ExampleAvailable 329withSubLibrary ex lib = withSubLibraries ex [lib] 330 331withSubLibraries :: ExampleAvailable -> [ExSubLib] -> ExampleAvailable 332withSubLibraries ex libs = 333 let subLibCDs = CD.fromList [(CD.ComponentSubLib $ C.mkUnqualComponentName name, deps) 334 | ExSubLib name deps <- libs] 335 in ex { exAvDeps = exAvDeps ex <> subLibCDs } 336 337withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable 338withSetupDeps ex setupDeps = ex { 339 exAvDeps = exAvDeps ex <> CD.fromSetupDeps (dependencies setupDeps) 340 } 341 342withTest :: ExampleAvailable -> ExTest -> ExampleAvailable 343withTest ex test = withTests ex [test] 344 345withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable 346withTests ex tests = 347 let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps) 348 | ExTest name deps <- tests] 349 in ex { exAvDeps = exAvDeps ex <> testCDs } 350 351withExe :: ExampleAvailable -> ExExe -> ExampleAvailable 352withExe ex exe = withExes ex [exe] 353 354withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable 355withExes ex exes = 356 let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps) 357 | ExExe name deps <- exes] 358 in ex { exAvDeps = exAvDeps ex <> exeCDs } 359 360-- | An installed package in 'ExampleDb'; construct me with 'exInst'. 361data ExampleInstalled = ExInst { 362 exInstName :: ExamplePkgName 363 , exInstVersion :: ExamplePkgVersion 364 , exInstHash :: ExamplePkgHash 365 , exInstBuildAgainst :: [ExamplePkgHash] 366 } deriving Show 367 368-- | Constructs an example installed package given: 369-- 370-- 1. The name of the package 'ExamplePkgName', i.e., 'String' 371-- 2. The version of the package 'ExamplePkgVersion', i.e., 'Int' 372-- 3. The IPID for the package 'ExamplePkgHash', i.e., 'String' 373-- (just some unique identifier for the package.) 374-- 4. The 'ExampleInstalled' packages which this package was 375-- compiled against.) 376-- 377exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash 378 -> [ExampleInstalled] -> ExampleInstalled 379exInst pn v hash deps = ExInst pn v hash (map exInstHash deps) 380 381-- | An example package database is a list of installed packages 382-- 'ExampleInstalled' and available packages 'ExampleAvailable'. 383-- Generally, you want to use 'exInst' and 'exAv' to construct 384-- these packages. 385type ExampleDb = [Either ExampleInstalled ExampleAvailable] 386 387type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a 388 389type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a 390 391exDbPkgs :: ExampleDb -> [ExamplePkgName] 392exDbPkgs = map (either exInstName exAvName) 393 394exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage 395exAvSrcPkg ex = 396 let pkgId = exAvPkgId ex 397 398 flags :: [C.PackageFlag] 399 flags = 400 let declaredFlags :: Map ExampleFlagName C.PackageFlag 401 declaredFlags = 402 Map.fromListWith 403 (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2]) 404 [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex] 405 406 usedFlags :: Map ExampleFlagName C.PackageFlag 407 usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] 408 where 409 names = extractFlags $ CD.flatDeps (exAvDeps ex) 410 in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: 411 Map.elems $ declaredFlags `Map.union` usedFlags 412 413 subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)] 414 foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)] 415 testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] 416 benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)] 417 executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] 418 setup = case depsExampleDependencies $ CD.setupDeps (exAvDeps ex) of 419 [] -> Nothing 420 deps -> Just C.SetupBuildInfo { 421 C.setupDepends = mkSetupDeps deps, 422 C.defaultSetupDepends = False 423 } 424 package = SourcePackage 425 { srcpkgPackageId = pkgId 426 , srcpkgSource = LocalTarballPackage "<<path>>" 427 , srcpkgDescrOverride = Nothing 428 , srcpkgDescription = C.GenericPackageDescription { 429 C.packageDescription = C.emptyPackageDescription { 430 C.package = pkgId 431 , C.setupBuildInfo = setup 432 , C.licenseRaw = Right BSD3 433 , C.buildTypeRaw = if isNothing setup 434 then Just C.Simple 435 else Just C.Custom 436 , C.category = "category" 437 , C.maintainer = "maintainer" 438 , C.description = "description" 439 , C.synopsis = "synopsis" 440 , C.licenseFiles = ["LICENSE"] 441 -- Version 2.0 is required for internal libraries. 442 , C.specVersion = C.CabalSpecV2_0 443 } 444 , C.gpdScannedVersion = Nothing 445 , C.genPackageFlags = flags 446 , C.condLibrary = 447 let mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi } 448 -- Avoid using the Monoid instance for [a] when getting 449 -- the library dependencies, to allow for the possibility 450 -- that the package doesn't have a library: 451 libDeps = lookup CD.ComponentLib (CD.toList (exAvDeps ex)) 452 in mkTopLevelCondTree defaultLib mkLib <$> libDeps 453 , C.condSubLibraries = 454 let mkTree = mkTopLevelCondTree defaultSubLib mkLib 455 mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi } 456 in map (second mkTree) subLibraries 457 , C.condForeignLibs = 458 let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib) 459 mkLib bi = mempty { C.foreignLibBuildInfo = bi } 460 in map (second mkTree) foreignLibraries 461 , C.condExecutables = 462 let mkTree = mkTopLevelCondTree defaultExe (const mkExe) 463 mkExe bi = mempty { C.buildInfo = bi } 464 in map (second mkTree) executables 465 , C.condTestSuites = 466 let mkTree = mkTopLevelCondTree defaultTest (const mkTest) 467 mkTest bi = mempty { C.testBuildInfo = bi } 468 in map (second mkTree) testSuites 469 , C.condBenchmarks = 470 let mkTree = mkTopLevelCondTree defaultBenchmark (const mkBench) 471 mkBench bi = mempty { C.benchmarkBuildInfo = bi } 472 in map (second mkTree) benchmarks 473 } 474 } 475 pkgCheckErrors = 476 -- We ignore these warnings because some unit tests test that the 477 -- solver allows unknown extensions/languages when the compiler 478 -- supports them. 479 let ignore = ["Unknown extensions:", "Unknown languages:"] 480 in [ err | err <- C.checkPackage (srcpkgDescription package) Nothing 481 , not $ any (`isPrefixOf` C.explanation err) ignore ] 482 in if null pkgCheckErrors 483 then package 484 else error $ "invalid GenericPackageDescription for package " 485 ++ display pkgId ++ ": " ++ show pkgCheckErrors 486 where 487 defaultTopLevelBuildInfo :: C.BuildInfo 488 defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 } 489 490 defaultLib :: C.Library 491 defaultLib = mempty { 492 C.libBuildInfo = defaultTopLevelBuildInfo 493 , C.exposedModules = [Module.fromString "Module"] 494 , C.libVisibility = C.LibraryVisibilityPublic 495 } 496 497 defaultSubLib :: C.Library 498 defaultSubLib = mempty { 499 C.libBuildInfo = defaultTopLevelBuildInfo 500 , C.exposedModules = [Module.fromString "Module"] 501 } 502 503 defaultExe :: C.Executable 504 defaultExe = mempty { 505 C.buildInfo = defaultTopLevelBuildInfo 506 , C.modulePath = "Main.hs" 507 } 508 509 defaultTest :: C.TestSuite 510 defaultTest = mempty { 511 C.testBuildInfo = defaultTopLevelBuildInfo 512 , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs" 513 } 514 515 defaultBenchmark :: C.Benchmark 516 defaultBenchmark = mempty { 517 C.benchmarkBuildInfo = defaultTopLevelBuildInfo 518 , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1,0]) "Benchmark.hs" 519 } 520 521 -- Split the set of dependencies into the set of dependencies of the library, 522 -- the dependencies of the test suites and extensions. 523 splitTopLevel :: [ExampleDependency] 524 -> ( [ExampleDependency] 525 , [Extension] 526 , Maybe Language 527 , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config 528 , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools 529 , [(ExamplePkgName, C.VersionRange)] -- legacy build tools 530 ) 531 splitTopLevel [] = 532 ([], [], Nothing, [], [], []) 533 splitTopLevel (ExBuildToolAny p e:deps) = 534 let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps 535 in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes) 536 splitTopLevel (ExBuildToolFix p e v:deps) = 537 let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps 538 in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes) 539 splitTopLevel (ExLegacyBuildToolAny p:deps) = 540 let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps 541 in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes) 542 splitTopLevel (ExLegacyBuildToolFix p v:deps) = 543 let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps 544 in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes) 545 splitTopLevel (ExExt ext:deps) = 546 let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps 547 in (other, ext:exts, lang, pcpkgs, exes, legacyExes) 548 splitTopLevel (ExLang lang:deps) = 549 case splitTopLevel deps of 550 (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes) 551 _ -> error "Only 1 Language dependency is supported" 552 splitTopLevel (ExPkg pkg:deps) = 553 let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps 554 in (other, exts, lang, pkg:pcpkgs, exes, legacyExes) 555 splitTopLevel (dep:deps) = 556 let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps 557 in (dep:other, exts, lang, pcpkgs, exes, legacyExes) 558 559 -- Extract the total set of flags used 560 extractFlags :: Dependencies -> [ExampleFlagName] 561 extractFlags deps = concatMap go (depsExampleDependencies deps) 562 where 563 go :: ExampleDependency -> [ExampleFlagName] 564 go (ExAny _) = [] 565 go (ExFix _ _) = [] 566 go (ExRange _ _ _) = [] 567 go (ExSubLibAny _ _) = [] 568 go (ExSubLibFix _ _ _) = [] 569 go (ExBuildToolAny _ _) = [] 570 go (ExBuildToolFix _ _ _) = [] 571 go (ExLegacyBuildToolAny _) = [] 572 go (ExLegacyBuildToolFix _ _) = [] 573 go (ExFlagged f a b) = f : extractFlags a ++ extractFlags b 574 go (ExExt _) = [] 575 go (ExLang _) = [] 576 go (ExPkg _) = [] 577 578 -- Convert 'Dependencies' into a tree of a specific component type, using 579 -- the given top level component and function for creating a component at 580 -- any level. 581 mkTopLevelCondTree :: forall a. Semigroup a => 582 a 583 -> (C.LibraryVisibility -> C.BuildInfo -> a) 584 -> Dependencies 585 -> DependencyTree a 586 mkTopLevelCondTree defaultTopLevel mkComponent deps = 587 let condNode = mkCondTree mkComponent deps 588 in condNode { C.condTreeData = defaultTopLevel <> C.condTreeData condNode } 589 590 -- Convert 'Dependencies' into a tree of a specific component type, using 591 -- the given function to generate each component. 592 mkCondTree :: (C.LibraryVisibility -> C.BuildInfo -> a) -> Dependencies -> DependencyTree a 593 mkCondTree mkComponent deps = 594 let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel (depsExampleDependencies deps) 595 (directDeps, flaggedDeps) = splitDeps libraryDeps 596 component = mkComponent (depsVisibility deps) bi 597 bi = mempty { 598 C.otherExtensions = exts 599 , C.defaultLanguage = mlang 600 , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr 601 | (p, e, vr) <- buildTools] 602 , C.buildTools = [ C.LegacyExeDependency n vr 603 | (n,vr) <- legacyBuildTools] 604 , C.pkgconfigDepends = [ C.PkgconfigDependency n' v' 605 | (n,v) <- pcpkgs 606 , let n' = C.mkPkgconfigName n 607 , let v' = C.PcThisVersion (mkSimplePkgconfigVersion v) ] 608 , C.buildable = depsIsBuildable deps 609 } 610 in C.CondNode { 611 C.condTreeData = component 612 -- TODO: Arguably, build-tools dependencies should also 613 -- effect constraints on conditional tree. But no way to 614 -- distinguish between them 615 , C.condTreeConstraints = map mkDirect directDeps 616 , C.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps 617 } 618 619 mkDirect :: (ExamplePkgName, C.LibraryName, C.VersionRange) -> C.Dependency 620 mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (NonEmptySet.singleton name) 621 622 mkFlagged :: (C.LibraryVisibility -> C.BuildInfo -> a) 623 -> (ExampleFlagName, Dependencies, Dependencies) 624 -> DependencyComponent a 625 mkFlagged mkComponent (f, a, b) = 626 C.CondBranch (C.Var (C.PackageFlag (C.mkFlagName f))) 627 (mkCondTree mkComponent a) 628 (Just (mkCondTree mkComponent b)) 629 630 -- Split a set of dependencies into direct dependencies and flagged 631 -- dependencies. A direct dependency is a tuple of the name of package and 632 -- its version range meant to be converted to a 'C.Dependency' with 633 -- 'mkDirect' for example. A flagged dependency is the set of dependencies 634 -- guarded by a flag. 635 splitDeps :: [ExampleDependency] 636 -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)] 637 , [(ExampleFlagName, Dependencies, Dependencies)] 638 ) 639 splitDeps [] = 640 ([], []) 641 splitDeps (ExAny p:deps) = 642 let (directDeps, flaggedDeps) = splitDeps deps 643 in ((p, C.LMainLibName, C.anyVersion):directDeps, flaggedDeps) 644 splitDeps (ExFix p v:deps) = 645 let (directDeps, flaggedDeps) = splitDeps deps 646 in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) 647 splitDeps (ExRange p v1 v2:deps) = 648 let (directDeps, flaggedDeps) = splitDeps deps 649 in ((p, C.LMainLibName, mkVersionRange v1 v2):directDeps, flaggedDeps) 650 splitDeps (ExSubLibAny p lib:deps) = 651 let (directDeps, flaggedDeps) = splitDeps deps 652 in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion):directDeps, flaggedDeps) 653 splitDeps (ExSubLibFix p lib v:deps) = 654 let (directDeps, flaggedDeps) = splitDeps deps 655 in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) 656 splitDeps (ExFlagged f a b:deps) = 657 let (directDeps, flaggedDeps) = splitDeps deps 658 in (directDeps, (f, a, b):flaggedDeps) 659 splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep 660 661 -- custom-setup only supports simple dependencies 662 mkSetupDeps :: [ExampleDependency] -> [C.Dependency] 663 mkSetupDeps deps = 664 case splitDeps deps of 665 (directDeps, []) -> map mkDirect directDeps 666 _ -> error "mkSetupDeps: custom setup has non-simple deps" 667 668mkSimpleVersion :: ExamplePkgVersion -> C.Version 669mkSimpleVersion n = C.mkVersion [n, 0, 0] 670 671mkSimplePkgconfigVersion :: ExamplePkgVersion -> C.PkgconfigVersion 672mkSimplePkgconfigVersion = C.versionToPkgconfigVersion . mkSimpleVersion 673 674mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange 675mkVersionRange v1 v2 = 676 C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1) 677 (C.earlierVersion $ mkSimpleVersion v2) 678 679mkFlag :: ExFlag -> C.PackageFlag 680mkFlag flag = C.MkPackageFlag { 681 C.flagName = C.mkFlagName $ exFlagName flag 682 , C.flagDescription = "" 683 , C.flagDefault = exFlagDefault flag 684 , C.flagManual = 685 case exFlagType flag of 686 Manual -> True 687 Automatic -> False 688 } 689 690mkDefaultFlag :: ExampleFlagName -> C.PackageFlag 691mkDefaultFlag flag = C.MkPackageFlag { 692 C.flagName = C.mkFlagName flag 693 , C.flagDescription = "" 694 , C.flagDefault = True 695 , C.flagManual = False 696 } 697 698exAvPkgId :: ExampleAvailable -> C.PackageIdentifier 699exAvPkgId ex = C.PackageIdentifier { 700 pkgName = C.mkPackageName (exAvName ex) 701 , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0] 702 } 703 704exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo 705exInstInfo ex = IPI.emptyInstalledPackageInfo { 706 IPI.installedUnitId = C.mkUnitId (exInstHash ex) 707 , IPI.sourcePackageId = exInstPkgId ex 708 , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex) 709 } 710 711exInstPkgId :: ExampleInstalled -> C.PackageIdentifier 712exInstPkgId ex = C.PackageIdentifier { 713 pkgName = C.mkPackageName (exInstName ex) 714 , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0] 715 } 716 717exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage 718exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg 719 720exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex 721exInstIdx = C.PackageIndex.fromList . map exInstInfo 722 723exResolve :: ExampleDb 724 -- List of extensions supported by the compiler, or Nothing if unknown. 725 -> Maybe [Extension] 726 -- List of languages supported by the compiler, or Nothing if unknown. 727 -> Maybe [Language] 728 -> PC.PkgConfigDb 729 -> [ExamplePkgName] 730 -> Maybe Int 731 -> CountConflicts 732 -> FineGrainedConflicts 733 -> MinimizeConflictSet 734 -> IndependentGoals 735 -> ReorderGoals 736 -> AllowBootLibInstalls 737 -> OnlyConstrained 738 -> EnableBackjumping 739 -> SolveExecutables 740 -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) 741 -> [ExConstraint] 742 -> [ExPreference] 743 -> C.Verbosity 744 -> EnableAllTests 745 -> Progress String String CI.SolverInstallPlan.SolverInstallPlan 746exResolve db exts langs pkgConfigDb targets mbj countConflicts 747 fineGrainedConflicts minimizeConflictSet indepGoals reorder 748 allowBootLibInstalls onlyConstrained enableBj solveExes goalOrder 749 constraints prefs verbosity enableAllTests 750 = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params 751 where 752 defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag 753 compiler = defaultCompiler { C.compilerInfoExtensions = exts 754 , C.compilerInfoLanguages = langs 755 } 756 (inst, avai) = partitionEithers db 757 instIdx = exInstIdx inst 758 avaiIdx = SourcePackageDb { 759 packageIndex = exAvIdx avai 760 , packagePreferences = Map.empty 761 } 762 enableTests 763 | asBool enableAllTests = fmap (\p -> PackageConstraint 764 (scopeToplevel (C.mkPackageName p)) 765 (PackagePropertyStanzas [TestStanzas])) 766 (exDbPkgs db) 767 | otherwise = [] 768 targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets 769 params = addConstraints (fmap toConstraint constraints) 770 $ addConstraints (fmap toLpc enableTests) 771 $ addPreferences (fmap toPref prefs) 772 $ setCountConflicts countConflicts 773 $ setFineGrainedConflicts fineGrainedConflicts 774 $ setMinimizeConflictSet minimizeConflictSet 775 $ setIndependentGoals indepGoals 776 $ setReorderGoals reorder 777 $ setMaxBackjumps mbj 778 $ setAllowBootLibInstalls allowBootLibInstalls 779 $ setOnlyConstrained onlyConstrained 780 $ setEnableBackjumping enableBj 781 $ setSolveExecutables solveExes 782 $ setGoalOrder goalOrder 783 $ setSolverVerbosity verbosity 784 $ standardInstallPolicy instIdx avaiIdx targets' 785 toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown 786 787 toConstraint (ExVersionConstraint scope v) = 788 toLpc $ PackageConstraint scope (PackagePropertyVersion v) 789 toConstraint (ExFlagConstraint scope fn b) = 790 toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)])) 791 toConstraint (ExStanzaConstraint scope stanzas) = 792 toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas) 793 794 toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v 795 toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas 796 797extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan 798 -> [(ExamplePkgName, ExamplePkgVersion)] 799extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList 800 where 801 confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int) 802 confPkg (CI.SolverInstallPlan.Configured pkg) = srcPkg pkg 803 confPkg _ = Nothing 804 805 srcPkg :: SolverPackage UnresolvedPkgLoc -> Maybe (String, Int) 806 srcPkg cpkg = 807 let C.PackageIdentifier pn ver = C.packageId (solverPkgSource cpkg) 808 in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver) 809 810{------------------------------------------------------------------------------- 811 Auxiliary 812-------------------------------------------------------------------------------} 813 814-- | Run Progress computation 815runProgress :: Progress step e a -> ([step], Either e a) 816runProgress = go 817 where 818 go (Step s p) = let (ss, result) = go p in (s:ss, result) 819 go (Fail e) = ([], Left e) 820 go (Done a) = ([], Right a) 821