cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs

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