ProjectPlanning.hs 132 KB
Newer Older
1
{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-}
2 3 4
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
5
{-# LANGUAGE DeriveDataTypeable #-}
Duncan Coutts's avatar
Duncan Coutts committed
6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29

-- | Planning how to build everything in a project.
--
module Distribution.Client.ProjectPlanning (
    -- * elaborated install plan types
    ElaboratedInstallPlan,
    ElaboratedConfiguredPackage(..),
    ElaboratedPlanPackage,
    ElaboratedSharedConfig(..),
    ElaboratedReadyPackage,
    BuildStyle(..),
    CabalFileText,

    -- * Producing the elaborated install plan
    rebuildInstallPlan,

    -- * Build targets
    PackageTarget(..),
    ComponentTarget(..),
    SubComponentTarget(..),
    showComponentTarget,

    -- * Selecting a plan subset
    pruneInstallPlanToTargets,
30
    pruneInstallPlanToDependencies,
Duncan Coutts's avatar
Duncan Coutts committed
31 32 33

    -- * Utils required for building
    pkgHasEphemeralBuildTargets,
34
    elabBuildTargetWholeComponents,
Duncan Coutts's avatar
Duncan Coutts committed
35 36 37 38

    -- * Setup.hs CLI flags for building
    setupHsScriptOptions,
    setupHsConfigureFlags,
39
    setupHsConfigureArgs,
Duncan Coutts's avatar
Duncan Coutts committed
40 41 42 43 44 45 46 47 48 49 50 51 52 53
    setupHsBuildFlags,
    setupHsBuildArgs,
    setupHsReplFlags,
    setupHsReplArgs,
    setupHsCopyFlags,
    setupHsRegisterFlags,
    setupHsHaddockFlags,

    packageHashInputs,

    -- TODO: [code cleanup] utils that should live in some shared place?
    createPackageDBIfMissing
  ) where

54 55 56
import Prelude ()
import Distribution.Client.Compat.Prelude

57
import           Distribution.Client.ProjectPlanning.Types
Duncan Coutts's avatar
Duncan Coutts committed
58 59 60
import           Distribution.Client.PackageHash
import           Distribution.Client.RebuildMonad
import           Distribution.Client.ProjectConfig
61
import           Distribution.Client.ProjectPlanOutput
Duncan Coutts's avatar
Duncan Coutts committed
62

63
import           Distribution.Client.Types
Duncan Coutts's avatar
Duncan Coutts committed
64
import qualified Distribution.Client.InstallPlan as InstallPlan
65
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
Duncan Coutts's avatar
Duncan Coutts committed
66 67 68 69 70 71 72 73
import           Distribution.Client.Dependency
import           Distribution.Client.Dependency.Types
import qualified Distribution.Client.IndexUtils as IndexUtils
import           Distribution.Client.Targets (userToPackageConstraint)
import           Distribution.Client.DistDirLayout
import           Distribution.Client.SetupWrapper
import           Distribution.Client.JobControl
import           Distribution.Client.FetchUtils
74
import qualified Hackage.Security.Client as Sec
Duncan Coutts's avatar
Duncan Coutts committed
75
import           Distribution.Client.Setup hiding (packageName, cabalVersion)
76
import           Distribution.Utils.NubList
77 78 79
import           Distribution.Utils.LogProgress
import           Distribution.Utils.Progress (failProgress)
import           Distribution.Utils.MapAccum
Duncan Coutts's avatar
Duncan Coutts committed
80

81 82
import qualified Distribution.Solver.Types.ComponentDeps as CD
import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)
83
import           Distribution.Solver.Types.ConstraintSource
84
import           Distribution.Solver.Types.LabeledPackageConstraint
85 86
import           Distribution.Solver.Types.OptionalStanza
import           Distribution.Solver.Types.PkgConfigDb
87
import           Distribution.Solver.Types.ResolverPackage
88 89
import           Distribution.Solver.Types.SolverId
import           Distribution.Solver.Types.SolverPackage
90
import           Distribution.Solver.Types.InstSolverPackage
91
import           Distribution.Solver.Types.SourcePackage
92
import           Distribution.Solver.Types.Settings
93

94
import           Distribution.ModuleName
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
95 96
import           Distribution.Package hiding
  (InstalledPackageId, installedPackageId)
97 98 99
import           Distribution.Types.Dependency
import           Distribution.Types.PkgconfigDependency
import           Distribution.Types.UnqualComponentName
Duncan Coutts's avatar
Duncan Coutts committed
100 101 102 103 104 105 106 107 108 109 110 111
import           Distribution.System
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Configuration as PD
import           Distribution.Simple.PackageIndex (InstalledPackageIndex)
import           Distribution.Simple.Compiler hiding (Flag)
import qualified Distribution.Simple.GHC   as GHC   --TODO: [code cleanup] eliminate
import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate
import           Distribution.Simple.Program
import           Distribution.Simple.Program.Db
import           Distribution.Simple.Program.Find
import qualified Distribution.Simple.Setup as Cabal
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
112 113
import           Distribution.Simple.Setup
  (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault)
Duncan Coutts's avatar
Duncan Coutts committed
114 115 116 117 118
import qualified Distribution.Simple.Configure as Cabal
import qualified Distribution.Simple.LocalBuildInfo as Cabal
import           Distribution.Simple.LocalBuildInfo (ComponentName(..))
import qualified Distribution.Simple.Register as Cabal
import qualified Distribution.Simple.InstallDirs as InstallDirs
119
import qualified Distribution.InstalledPackageInfo as IPI
Duncan Coutts's avatar
Duncan Coutts committed
120

121 122
import           Distribution.Backpack.ConfiguredComponent
import           Distribution.Backpack.LinkedComponent
123
import           Distribution.Backpack.ComponentsGraph
124 125 126
import           Distribution.Backpack.ModuleShape
import           Distribution.Backpack.FullUnitId
import           Distribution.Backpack
127
import           Distribution.Types.ComponentInclude
128

Duncan Coutts's avatar
Duncan Coutts committed
129 130 131 132 133
import           Distribution.Simple.Utils hiding (matchFileGlob)
import           Distribution.Version
import           Distribution.Verbosity
import           Distribution.Text

134
import qualified Distribution.Compat.Graph as Graph
135
import           Distribution.Compat.Graph(IsNode(..))
136

137
import           Text.PrettyPrint hiding ((<>))
Duncan Coutts's avatar
Duncan Coutts committed
138 139 140 141
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           Control.Monad
142
import qualified Data.Traversable as T
Duncan Coutts's avatar
Duncan Coutts committed
143 144
import           Control.Monad.State as State
import           Control.Exception
145
import           Data.List (groupBy)
146
import           Data.Either
Duncan Coutts's avatar
Duncan Coutts committed
147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
import           Data.Function
import           System.FilePath

------------------------------------------------------------------------------
-- * Elaborated install plan
------------------------------------------------------------------------------

-- "Elaborated" -- worked out with great care and nicety of detail;
--                 executed with great minuteness: elaborate preparations;
--                 elaborate care.
--
-- So here's the idea:
--
-- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc
-- all passed in as separate args and which are then further selected,
-- transformed etc during the execution of the build. Instead we construct
-- an elaborated install plan that includes everything we will need, and then
-- during the execution of the plan we do as little transformation of this
-- info as possible.
--
-- So we're trying to split the work into two phases: construction of the
-- elaborated install plan (which as far as possible should be pure) and
-- then simple execution of that plan without any smarts, just doing what the
-- plan says to do.
--
-- So that means we need a representation of this fully elaborated install
-- plan. The representation consists of two parts:
--
-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a
--   representation of source packages that includes a lot more detail about
--   that package's individual configuration
--
-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for
--   every package in a plan. Rather than duplicate that info every entry in
--   the 'GenericInstallPlan' we keep that separately.
--
-- The division between the shared and per-package config is /not set in stone
-- for all time/. For example if we wanted to generalise the install plan to
-- describe a situation where we want to build some packages with GHC and some
-- with GHCJS then the platform and compiler would no longer be shared between
-- all packages but would have to be per-package (probably with some sanity
-- condition on the graph structure).
--

191
-- Refer to ProjectPlanning.Types for details of these important types:
Duncan Coutts's avatar
Duncan Coutts committed
192

193 194 195 196 197
-- type ElaboratedInstallPlan = ...
-- type ElaboratedPlanPackage = ...
-- data ElaboratedSharedConfig = ...
-- data ElaboratedConfiguredPackage = ...
-- data BuildStyle =
Duncan Coutts's avatar
Duncan Coutts committed
198 199


200
-- | Check that an 'ElaboratedConfiguredPackage' actually makes
201
-- sense under some 'ElaboratedSharedConfig'.
202 203 204 205 206 207 208 209 210 211
sanityCheckElaboratedConfiguredPackage
    :: ElaboratedSharedConfig
    -> ElaboratedConfiguredPackage
    -> a
    -> a
sanityCheckElaboratedConfiguredPackage sharedConfig
                             elab@ElaboratedConfiguredPackage{..} =
    (case elabPkgOrComp of
        ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg
        ElabComponent comp -> sanityCheckElaboratedComponent elab comp)
Duncan Coutts's avatar
Duncan Coutts committed
212

213 214 215 216
    -- either a package is being built inplace, or the
    -- 'installedPackageId' we assigned is consistent with
    -- the 'hashedInstalledPackageId' we would compute from
    -- the elaborated configured package
217
  . assert (elabBuildStyle == BuildInplaceOnly ||
218
     elabComponentId == hashedInstalledPackageId
219 220 221 222 223
                            (packageHashInputs sharedConfig elab))

    -- the stanzas explicitly disabled should not be available
  . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested)
                `Set.intersection` elabStanzasAvailable))
Duncan Coutts's avatar
Duncan Coutts committed
224

225 226 227
    -- either a package is built inplace, or we are not attempting to
    -- build any test suites or benchmarks (we never build these
    -- for remote packages!)
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
  . assert (elabBuildStyle == BuildInplaceOnly ||
     Set.null elabStanzasAvailable)

sanityCheckElaboratedComponent
    :: ElaboratedConfiguredPackage
    -> ElaboratedComponent
    -> a
    -> a
sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..}
                               ElaboratedComponent{..} =

    -- Should not be building bench or test if not inplace.
    assert (elabBuildStyle == BuildInplaceOnly ||
     case compComponentName of
        Nothing              -> True
        Just CLibName        -> True
        Just (CSubLibName _) -> True
        Just (CExeName _)    -> True
246 247 248 249
        -- This is interesting: there's no way to declare a dependency
        -- on a foreign library at the moment, but you may still want
        -- to install these to the store
        Just (CFLibName _)   -> True
250 251 252 253 254 255 256 257 258 259 260 261 262 263
        Just (CBenchName _)  -> False
        Just (CTestName _)   -> False)


sanityCheckElaboratedPackage
    :: ElaboratedConfiguredPackage
    -> ElaboratedPackage
    -> a
    -> a
sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..}
                             ElaboratedPackage{..} =
    -- we should only have enabled stanzas that actually can be built
    -- (according to the solver)
    assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable)
264

265 266 267 268
    -- the stanzas that the user explicitly requested should be
    -- enabled (by the previous test, they are also available)
  . assert (Map.keysSet (Map.filter id elabStanzasRequested)
                `Set.isSubsetOf` pkgStanzasEnabled)
Duncan Coutts's avatar
Duncan Coutts committed
269 270 271 272 273

------------------------------------------------------------------------------
-- * Deciding what to do: making an 'ElaboratedInstallPlan'
------------------------------------------------------------------------------

274 275 276 277 278 279 280 281 282 283 284 285 286
-- | Return an up-to-date elaborated install plan and associated config.
--
-- Two variants of the install plan are returned: with and without packages
-- from the store. That is, the \"improved\" plan where source packages are
-- replaced by pre-existing installed packages from the store (when their ids
-- match), and also the original elaborated plan which uses primarily source
-- packages.

-- The improved plan is what we use for building, but the original elaborated
-- plan is useful for reporting and configuration. For example the @freeze@
-- command needs the source package info to know about flag choices and
-- dependencies of executables and setup scripts.
--
Duncan Coutts's avatar
Duncan Coutts committed
287
rebuildInstallPlan :: Verbosity
288
                   -> InstallFlags
Duncan Coutts's avatar
Duncan Coutts committed
289 290
                   -> FilePath -> DistDirLayout -> CabalDirLayout
                   -> ProjectConfig
291 292
                   -> IO ( ElaboratedInstallPlan  -- with store packages
                         , ElaboratedInstallPlan  -- with source packages
Duncan Coutts's avatar
Duncan Coutts committed
293 294
                         , ElaboratedSharedConfig
                         , ProjectConfig )
295
                      -- ^ @(improvedPlan, elaboratedPlan, _, _)@
Duncan Coutts's avatar
Duncan Coutts committed
296
rebuildInstallPlan verbosity
297
                   installFlags
Duncan Coutts's avatar
Duncan Coutts committed
298 299 300 301 302 303 304 305 306 307 308
                   projectRootDir
                   distDirLayout@DistDirLayout {
                     distDirectory,
                     distProjectCacheFile,
                     distProjectCacheDirectory
                   }
                   cabalDirLayout@CabalDirLayout {
                     cabalStoreDirectory,
                     cabalStorePackageDB
                   }
                   cliConfig =
309
    runRebuild projectRootDir $ do
Duncan Coutts's avatar
Duncan Coutts committed
310 311 312 313
    progsearchpath <- liftIO $ getSystemSearchPath
    let cliConfigPersistent = cliConfig { projectConfigBuildOnly = mempty }

    -- The overall improved plan is cached
314
    rerunIfChanged verbosity fileMonitorImprovedPlan
Duncan Coutts's avatar
Duncan Coutts committed
315 316 317 318 319 320
                   -- react to changes in command line args and the path
                   (cliConfigPersistent, progsearchpath) $ do

      -- And so is the elaborated plan that the improved plan based on
      (elaboratedPlan, elaboratedShared,
       projectConfig) <-
321
        rerunIfChanged verbosity fileMonitorElaboratedPlan
Duncan Coutts's avatar
Duncan Coutts committed
322 323 324 325 326
                       (cliConfigPersistent, progsearchpath) $ do

          (projectConfig, projectConfigTransient) <- phaseReadProjectConfig
          localPackages <- phaseReadLocalPackages projectConfig
          compilerEtc   <- phaseConfigureCompiler projectConfig
327
          _             <- phaseConfigurePrograms projectConfig compilerEtc
328 329 330 331
          (solverPlan, pkgConfigDB)
                        <- phaseRunSolver         projectConfigTransient
                                                  compilerEtc
                                                  localPackages
Duncan Coutts's avatar
Duncan Coutts committed
332 333
          (elaboratedPlan,
           elaboratedShared) <- phaseElaboratePlan projectConfigTransient
334 335 336
                                                   compilerEtc pkgConfigDB
                                                   solverPlan
                                                   localPackages
337

338
          phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
339 340 341 342
          let instantiatedPlan = phaseInstantiatePlan elaboratedPlan
          liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)

          return (instantiatedPlan, elaboratedShared, projectConfig)
Duncan Coutts's avatar
Duncan Coutts committed
343 344 345 346 347

      -- The improved plan changes each time we install something, whereas
      -- the underlying elaborated plan only changes when input config
      -- changes, so it's worth caching them separately.
      improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
348 349

      return (improvedPlan, elaboratedPlan, elaboratedShared, projectConfig)
Duncan Coutts's avatar
Duncan Coutts committed
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367

  where
    fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"
    fileMonitorSolverPlan     = newFileMonitorInCacheDir "solver-plan"
    fileMonitorSourceHashes   = newFileMonitorInCacheDir "source-hashes"
    fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"
    fileMonitorImprovedPlan   = newFileMonitorInCacheDir "improved-plan"

    newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b
    newFileMonitorInCacheDir  = newFileMonitor . distProjectCacheFile

    -- Read the cabal.project (or implicit config) and combine it with
    -- arguments from the command line
    --
    phaseReadProjectConfig :: Rebuild (ProjectConfig, ProjectConfig)
    phaseReadProjectConfig = do
      liftIO $ do
        info verbosity "Project settings changed, reconfiguring..."
368 369
        createDirectoryIfMissingVerbose verbosity True distDirectory
        createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
Duncan Coutts's avatar
Duncan Coutts committed
370

371
      projectConfig <- readProjectConfig verbosity installFlags projectRootDir
Duncan Coutts's avatar
Duncan Coutts committed
372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403

      -- The project config comming from the command line includes "build only"
      -- flags that we don't cache persistently (because like all "build only"
      -- flags they do not affect the value of the outcome) but that we do
      -- sometimes using during planning (in particular the http transport)
      let projectConfigTransient  = projectConfig <> cliConfig
          projectConfigPersistent = projectConfig
                                 <> cliConfig {
                                      projectConfigBuildOnly = mempty
                                    }
      liftIO $ writeProjectConfigFile (distProjectCacheFile "config")
                                      projectConfigPersistent
      return (projectConfigPersistent, projectConfigTransient)

    -- Look for all the cabal packages in the project
    -- some of which may be local src dirs, tarballs etc
    --
    phaseReadLocalPackages :: ProjectConfig
                           -> Rebuild [UnresolvedSourcePackage]
    phaseReadLocalPackages projectConfig = do

      localCabalFiles <- findProjectPackages projectRootDir projectConfig
      mapM (readSourcePackage verbosity) localCabalFiles


    -- Configure the compiler we're using.
    --
    -- This is moderately expensive and doesn't change that often so we cache
    -- it independently.
    --
    phaseConfigureCompiler :: ProjectConfig
                           -> Rebuild (Compiler, Platform, ProgramDb)
404 405 406 407 408 409 410 411 412 413 414 415
    phaseConfigureCompiler ProjectConfig {
                             projectConfigShared = ProjectConfigShared {
                               projectConfigHcFlavor,
                               projectConfigHcPath,
                               projectConfigHcPkg
                             },
                             projectConfigLocalPackages = PackageConfig {
                               packageConfigProgramPaths,
                               packageConfigProgramArgs,
                               packageConfigProgramPathExtra
                             }
                           } = do
Duncan Coutts's avatar
Duncan Coutts committed
416
        progsearchpath <- liftIO $ getSystemSearchPath
417
        rerunIfChanged verbosity fileMonitorCompiler
418 419 420 421
                       (hcFlavor, hcPath, hcPkg, progsearchpath,
                        packageConfigProgramPaths,
                        packageConfigProgramArgs,
                        packageConfigProgramPathExtra) $ do
Duncan Coutts's avatar
Duncan Coutts committed
422 423

          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."
424
          result@(_, _, progdb') <- liftIO $
Duncan Coutts's avatar
Duncan Coutts committed
425 426
            Cabal.configCompilerEx
              hcFlavor hcPath hcPkg
427
              progdb verbosity
Duncan Coutts's avatar
Duncan Coutts committed
428

429 430 431 432 433 434 435
        -- Note that we added the user-supplied program locations and args
        -- for /all/ programs, not just those for the compiler prog and
        -- compiler-related utils. In principle we don't know which programs
        -- the compiler will configure (and it does vary between compilers).
        -- We do know however that the compiler will only configure the
        -- programs it cares about, and those are the ones we monitor here.
          monitorFiles (programsMonitorFiles progdb')
Duncan Coutts's avatar
Duncan Coutts committed
436 437 438 439 440 441

          return result
      where
        hcFlavor = flagToMaybe projectConfigHcFlavor
        hcPath   = flagToMaybe projectConfigHcPath
        hcPkg    = flagToMaybe projectConfigHcPkg
442 443 444 445 446 447 448
        progdb   =
            userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
          . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))
          . modifyProgramSearchPath
              (++ [ ProgramSearchPathDir dir
                  | dir <- fromNubList packageConfigProgramPathExtra ])
          $ defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
449 450


451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481
    -- Configuring other programs.
    --
    -- Having configred the compiler, now we configure all the remaining
    -- programs. This is to check we can find them, and to monitor them for
    -- changes.
    --
    -- TODO: [required eventually] we don't actually do this yet.
    --
    -- We rely on the fact that the previous phase added the program config for
    -- all local packages, but that all the programs configured so far are the
    -- compiler program or related util programs.
    --
    phaseConfigurePrograms :: ProjectConfig
                           -> (Compiler, Platform, ProgramDb)
                           -> Rebuild ()
    phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do
        -- Users are allowed to specify program locations independently for
        -- each package (e.g. to use a particular version of a pre-processor
        -- for some packages). However they cannot do this for the compiler
        -- itself as that's just not going to work. So we check for this.
        liftIO $ checkBadPerPackageCompilerPaths
          (configuredPrograms compilerprogdb)
          (getMapMappend (projectConfigSpecificPackage projectConfig))

        --TODO: [required eventually] find/configure other programs that the
        -- user specifies.

        --TODO: [required eventually] find/configure all build-tools
        -- but note that some of them may be built as part of the plan.


Duncan Coutts's avatar
Duncan Coutts committed
482 483 484 485 486 487
    -- Run the solver to get the initial install plan.
    -- This is expensive so we cache it independently.
    --
    phaseRunSolver :: ProjectConfig
                   -> (Compiler, Platform, ProgramDb)
                   -> [UnresolvedSourcePackage]
488
                   -> Rebuild (SolverInstallPlan, PkgConfigDb)
Duncan Coutts's avatar
Duncan Coutts committed
489 490 491 492 493 494
    phaseRunSolver projectConfig@ProjectConfig {
                     projectConfigShared,
                     projectConfigBuildOnly
                   }
                   (compiler, platform, progdb)
                   localPackages =
495
        rerunIfChanged verbosity fileMonitorSolverPlan
496
                       (solverSettings,
Duncan Coutts's avatar
Duncan Coutts committed
497
                        localPackages, localPackagesEnabledStanzas,
498
                        compiler, platform, programDbSignature progdb) $ do
Duncan Coutts's avatar
Duncan Coutts committed
499 500 501 502

          installedPkgIndex <- getInstalledPackages verbosity
                                                    compiler progdb platform
                                                    corePackageDbs
503 504 505
          sourcePkgDb       <- getSourcePackages verbosity withRepoCtx
                                 (solverSettingIndexState solverSettings)
          pkgConfigDB       <- getPkgConfigDb verbosity progdb
Duncan Coutts's avatar
Duncan Coutts committed
506

507 508 509 510 511
          --TODO: [code cleanup] it'd be better if the Compiler contained the
          -- ConfiguredPrograms that it needs, rather than relying on the progdb
          -- since we don't need to depend on all the programs here, just the
          -- ones relevant for the compiler.

Duncan Coutts's avatar
Duncan Coutts committed
512 513 514 515 516 517
          liftIO $ do
            solver <- chooseSolver verbosity
                                   (solverSettingSolver solverSettings)
                                   (compilerInfo compiler)

            notice verbosity "Resolving dependencies..."
518
            plan <- foldProgress logMsg die return $
Duncan Coutts's avatar
Duncan Coutts committed
519 520 521
              planPackages compiler platform solver solverSettings
                           installedPkgIndex sourcePkgDb pkgConfigDB
                           localPackages localPackagesEnabledStanzas
522
            return (plan, pkgConfigDB)
Duncan Coutts's avatar
Duncan Coutts committed
523 524 525 526 527
      where
        corePackageDbs = [GlobalPackageDB]
        withRepoCtx    = projectConfigWithSolverRepoContext verbosity
                           projectConfigShared
                           projectConfigBuildOnly
528
        solverSettings = resolveSolverSettings projectConfig
Duncan Coutts's avatar
Duncan Coutts committed
529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554
        logMsg message rest = debugNoWrap verbosity message >> rest

        localPackagesEnabledStanzas =
          Map.fromList
            [ (pkgname, stanzas)
            | pkg <- localPackages
            , let pkgname            = packageName pkg
                  testsEnabled       = lookupLocalPackageConfig
                                         packageConfigTests
                                         projectConfig pkgname
                  benchmarksEnabled  = lookupLocalPackageConfig
                                         packageConfigBenchmarks
                                         projectConfig pkgname
                  stanzas =
                    Map.fromList $
                      [ (TestStanzas, enabled)
                      | enabled <- flagToList testsEnabled ]
                   ++ [ (BenchStanzas , enabled)
                      | enabled <- flagToList benchmarksEnabled ]
            ]

    -- Elaborate the solver's install plan to get a fully detailed plan. This
    -- version of the plan has the final nix-style hashed ids.
    --
    phaseElaboratePlan :: ProjectConfig
                       -> (Compiler, Platform, ProgramDb)
555
                       -> PkgConfigDb
556
                       -> SolverInstallPlan
Duncan Coutts's avatar
Duncan Coutts committed
557 558 559 560 561 562 563 564 565
                       -> [SourcePackage loc]
                       -> Rebuild ( ElaboratedInstallPlan
                                  , ElaboratedSharedConfig )
    phaseElaboratePlan ProjectConfig {
                         projectConfigShared,
                         projectConfigLocalPackages,
                         projectConfigSpecificPackage,
                         projectConfigBuildOnly
                       }
566
                       (compiler, platform, progdb) pkgConfigDB
567
                       solverPlan localPackages = do
Duncan Coutts's avatar
Duncan Coutts committed
568 569 570 571

        liftIO $ debug verbosity "Elaborating the install plan..."

        sourcePackageHashes <-
572
          rerunIfChanged verbosity fileMonitorSourceHashes
573
                         (packageLocationsSignature solverPlan) $
Duncan Coutts's avatar
Duncan Coutts committed
574 575 576
            getPackageSourceHashes verbosity withRepoCtx solverPlan

        defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler
577 578
        (elaboratedPlan, elaboratedShared)
          <- liftIO . runLogProgress verbosity $
579
              elaborateInstallPlan
580
                verbosity
581
                platform compiler progdb pkgConfigDB
582 583 584 585 586 587 588 589 590 591 592
                distDirLayout
                cabalDirLayout
                solverPlan
                localPackages
                sourcePackageHashes
                defaultInstallDirs
                projectConfigShared
                projectConfigLocalPackages
                (getMapMappend projectConfigSpecificPackage)
        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan)
        return (elaboratedPlan, elaboratedShared)
Duncan Coutts's avatar
Duncan Coutts committed
593
      where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
594
        withRepoCtx = projectConfigWithSolverRepoContext verbosity
Duncan Coutts's avatar
Duncan Coutts committed
595 596 597
                        projectConfigShared
                        projectConfigBuildOnly

598 599 600 601
    phaseInstantiatePlan :: ElaboratedInstallPlan
                         -> ElaboratedInstallPlan
    phaseInstantiatePlan plan = instantiateInstallPlan plan

602 603
    -- Update the files we maintain that reflect our current build environment.
    -- In particular we maintain a JSON representation of the elaborated
604 605
    -- install plan (but not the improved plan since that reflects the state
    -- of the build rather than just the input environment).
606 607 608 609
    --
    phaseMaintainPlanOutputs :: ElaboratedInstallPlan
                             -> ElaboratedSharedConfig
                             -> Rebuild ()
610 611 612 613 614 615
    phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do
        debug verbosity "Updating plan.json"
        writePlanExternalRepresentation
          distDirLayout
          elaboratedPlan
          elaboratedShared
616 617


Duncan Coutts's avatar
Duncan Coutts committed
618 619 620 621 622 623 624 625 626 627 628 629 630 631 632
    -- Improve the elaborated install plan. The elaborated plan consists
    -- mostly of source packages (with full nix-style hashed ids). Where
    -- corresponding installed packages already exist in the store, replace
    -- them in the plan.
    --
    -- Note that we do monitor the store's package db here, so we will redo
    -- this improvement phase when the db changes -- including as a result of
    -- executing a plan and installing things.
    --
    phaseImprovePlan :: ElaboratedInstallPlan
                     -> ElaboratedSharedConfig
                     -> Rebuild ElaboratedInstallPlan
    phaseImprovePlan elaboratedPlan elaboratedShared = do

        liftIO $ debug verbosity "Improving the install plan..."
633
        createDirectoryMonitored True storeDirectory
634 635 636 637
        liftIO $ createPackageDBIfMissing verbosity
                                          compiler progdb
                                          storePackageDb
        storePkgIdSet <- getInstalledStorePackages storeDirectory
638
        let improvedPlan = improveInstallPlanWithInstalledPackages
639
                             storePkgIdSet
Duncan Coutts's avatar
Duncan Coutts committed
640
                             elaboratedPlan
641
        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan)
642 643 644 645
        -- TODO: [nice to have] having checked which packages from the store
        -- we're using, it may be sensible to sanity check those packages
        -- by loading up the compiler package db and checking everything
        -- matches up as expected, e.g. no dangling deps, files deleted.
Duncan Coutts's avatar
Duncan Coutts committed
646 647 648 649 650
        return improvedPlan
      where
        storeDirectory  = cabalStoreDirectory (compilerId compiler)
        storePackageDb  = cabalStorePackageDB (compilerId compiler)
        ElaboratedSharedConfig {
651 652
          pkgConfigCompiler      = compiler,
          pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
653 654 655 656 657 658 659 660 661 662 663 664 665 666
        } = elaboratedShared


programsMonitorFiles :: ProgramDb -> [MonitorFilePath]
programsMonitorFiles progdb =
    [ monitor
    | prog    <- configuredPrograms progdb
    , monitor <- monitorFileSearchPath (programMonitorFiles prog)
                                       (programPath prog)
    ]

-- | Select the bits of a 'ProgramDb' to monitor for value changes.
-- Use 'programsMonitorFiles' for the files to monitor.
--
667 668
programDbSignature :: ProgramDb -> [ConfiguredProgram]
programDbSignature progdb =
Duncan Coutts's avatar
Duncan Coutts committed
669 670 671 672 673 674 675
    [ prog { programMonitorFiles = []
           , programOverrideEnv  = filter ((/="PATH") . fst)
                                          (programOverrideEnv prog) }
    | prog <- configuredPrograms progdb ]

getInstalledPackages :: Verbosity
                     -> Compiler -> ProgramDb -> Platform
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
676
                     -> PackageDBStack
Duncan Coutts's avatar
Duncan Coutts committed
677 678
                     -> Rebuild InstalledPackageIndex
getInstalledPackages verbosity compiler progdb platform packagedbs = do
679
    monitorFiles . map monitorFileOrDirectory
Duncan Coutts's avatar
Duncan Coutts committed
680 681 682 683 684 685 686
      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles
                    verbosity compiler
                    packagedbs progdb platform)
    liftIO $ IndexUtils.getInstalledPackages
               verbosity compiler
               packagedbs progdb

687 688
{-
--TODO: [nice to have] use this but for sanity / consistency checking
Duncan Coutts's avatar
Duncan Coutts committed
689 690 691 692 693
getPackageDBContents :: Verbosity
                     -> Compiler -> ProgramDb -> Platform
                     -> PackageDB
                     -> Rebuild InstalledPackageIndex
getPackageDBContents verbosity compiler progdb platform packagedb = do
694
    monitorFiles . map monitorFileOrDirectory
Duncan Coutts's avatar
Duncan Coutts committed
695 696 697 698
      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles
                    verbosity compiler
                    [packagedb] progdb platform)
    liftIO $ do
699
      createPackageDBIfMissing verbosity compiler progdb packagedb
Duncan Coutts's avatar
Duncan Coutts committed
700 701
      Cabal.getPackageDBContents verbosity compiler
                                 packagedb progdb
702
-}
Duncan Coutts's avatar
Duncan Coutts committed
703

704 705 706 707 708 709
-- | Return the 'UnitId's of all packages\/components already installed in the
-- store.
--
getInstalledStorePackages :: FilePath -- ^ store directory
                          -> Rebuild (Set UnitId)
getInstalledStorePackages storeDirectory = do
710
    paths <- getDirectoryContentsMonitored storeDirectory
711
    return $ Set.fromList [ newSimpleUnitId (mkComponentId path)
712
                          | path <- paths, valid path ]
713
  where
714
    valid ('.':_)      = False
715
    valid "package.db" = False
716
    valid _            = True
717

Duncan Coutts's avatar
Duncan Coutts committed
718
getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
719 720
                  -> IndexUtils.IndexState -> Rebuild SourcePackageDb
getSourcePackages verbosity withRepoCtx idxState = do
Duncan Coutts's avatar
Duncan Coutts committed
721
    (sourcePkgDb, repos) <-
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
722
      liftIO $
Duncan Coutts's avatar
Duncan Coutts committed
723
        withRepoCtx $ \repoctx -> do
724 725
          sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity
                                                                  repoctx idxState
Duncan Coutts's avatar
Duncan Coutts committed
726 727
          return (sourcePkgDb, repoContextRepos repoctx)

728
    monitorFiles . map monitorFile
Duncan Coutts's avatar
Duncan Coutts committed
729 730 731 732
                 . IndexUtils.getSourcePackagesMonitorFiles
                 $ repos
    return sourcePkgDb

733 734 735 736

-- | Create a package DB if it does not currently exist. Note that this action
-- is /not/ safe to run concurrently.
--
Duncan Coutts's avatar
Duncan Coutts committed
737
createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb
738 739 740 741 742
                         -> PackageDB -> IO ()
createPackageDBIfMissing verbosity compiler progdb
                         (SpecificPackageDB dbPath) = do
    exists <- liftIO $ Cabal.doesPackageDBExist dbPath
    unless exists $ do
743
      createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
744 745
      Cabal.createPackageDB verbosity compiler progdb False dbPath
createPackageDBIfMissing _ _ _ _ = return ()
Duncan Coutts's avatar
Duncan Coutts committed
746 747


748 749 750 751 752
getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb
getPkgConfigDb verbosity progdb = do
    dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb
    -- Just monitor the dirs so we'll notice new .pc files.
    -- Alternatively we could monitor all the .pc files too.
753
    mapM_ monitorDirectoryStatus dirs
754 755 756
    liftIO $ readPkgConfigDb verbosity progdb


757 758 759 760 761
-- | Select the config values to monitor for changes package source hashes.
packageLocationsSignature :: SolverInstallPlan
                          -> [(PackageId, PackageLocation (Maybe FilePath))]
packageLocationsSignature solverPlan =
    [ (packageId pkg, packageSource pkg)
762 763
    | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})
        <- SolverInstallPlan.toList solverPlan
764 765 766
    ]


Duncan Coutts's avatar
Duncan Coutts committed
767 768 769 770 771 772 773 774 775
-- | Get the 'HashValue' for all the source packages where we use hashes,
-- and download any packages required to do so.
--
-- Note that we don't get hashes for local unpacked packages.
--
getPackageSourceHashes :: Verbosity
                       -> (forall a. (RepoContext -> IO a) -> IO a)
                       -> SolverInstallPlan
                       -> Rebuild (Map PackageId PackageSourceHash)
776
getPackageSourceHashes verbosity withRepoCtx solverPlan = do
Duncan Coutts's avatar
Duncan Coutts committed
777

778
    -- Determine if and where to get the package's source hash from.
Duncan Coutts's avatar
Duncan Coutts committed
779
    --
780 781 782
    let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))]
        allPkgLocations =
          [ (packageId pkg, packageSource pkg)
783 784
          | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})
              <- SolverInstallPlan.toList solverPlan ]
785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814

        -- Tarballs that were local in the first place.
        -- We'll hash these tarball files directly.
        localTarballPkgs :: [(PackageId, FilePath)]
        localTarballPkgs =
          [ (pkgid, tarball)
          | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ]

        -- Tarballs from remote URLs. We must have downloaded these already
        -- (since we extracted the .cabal file earlier)
        --TODO: [required eventually] finish remote tarball functionality
--        allRemoteTarballPkgs =
--          [ (pkgid, )
--          | (pkgid, RemoteTarballPackage ) <- allPkgLocations ]

        -- Tarballs from repositories, either where the repository provides
        -- hashes as part of the repo metadata, or where we will have to
        -- download and hash the tarball.
        repoTarballPkgsWithMetadata    :: [(PackageId, Repo)]
        repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)]
        (repoTarballPkgsWithMetadata,
         repoTarballPkgsWithoutMetadata) =
          partitionEithers
          [ case repo of
              RepoSecure{} -> Left  (pkgid, repo)
              _            -> Right (pkgid, repo)
          | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ]

    -- For tarballs from repos that do not have hashes available we now have
    -- to check if the packages were downloaded already.
Duncan Coutts's avatar
Duncan Coutts committed
815
    --
816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844
    (repoTarballPkgsToDownload,
     repoTarballPkgsDownloaded)
      <- fmap partitionEithers $
         liftIO $ sequence
           [ do mtarball <- checkRepoTarballFetched repo pkgid
                case mtarball of
                  Nothing      -> return (Left  (pkgid, repo))
                  Just tarball -> return (Right (pkgid, tarball))
           | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ]

    (hashesFromRepoMetadata,
     repoTarballPkgsNewlyDownloaded) <-
      -- Avoid having to initialise the repository (ie 'withRepoCtx') if we
      -- don't have to. (The main cost is configuring the http client.)
      if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata
      then return (Map.empty, [])
      else liftIO $ withRepoCtx $ \repoctx -> do

      -- For tarballs from repos that do have hashes available as part of the
      -- repo metadata we now load up the index for each repo and retrieve
      -- the hashes for the packages
      --
      hashesFromRepoMetadata <-
        Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions
        fmap (Map.fromList . concat) $
        sequence
          -- Reading the repo index is expensive so we group the packages by repo
          [ repoContextWithSecureRepo repoctx repo $ \secureRepo ->
              Sec.withIndex secureRepo $ \repoIndex ->
Duncan Coutts's avatar
Duncan Coutts committed
845
                sequence
846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874
                  [ do hash <- Sec.trusted <$> -- strip off Trusted tag
                               Sec.indexLookupHash repoIndex pkgid
                       -- Note that hackage-security currently uses SHA256
                       -- but this API could in principle give us some other
                       -- choice in future.
                       return (pkgid, hashFromTUF hash)
                  | pkgid <- pkgids ]
          | (repo, pkgids) <-
                map (\grp@((_,repo):_) -> (repo, map fst grp))
              . groupBy ((==)    `on` (remoteRepoName . repoRemote . snd))
              . sortBy  (compare `on` (remoteRepoName . repoRemote . snd))
              $ repoTarballPkgsWithMetadata
          ]

      -- For tarballs from repos that do not have hashes available, download
      -- the ones we previously determined we need.
      --
      repoTarballPkgsNewlyDownloaded <-
        sequence
          [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid
               return (pkgid, tarball)
          | (pkgid, repo) <- repoTarballPkgsToDownload ]

      return (hashesFromRepoMetadata,
              repoTarballPkgsNewlyDownloaded)

    -- Hash tarball files for packages where we have to do that. This includes
    -- tarballs that were local in the first place, plus tarballs from repos,
    -- either previously cached or freshly downloaded.
Duncan Coutts's avatar
Duncan Coutts committed
875
    --
876 877 878 879 880 881
    let allTarballFilePkgs :: [(PackageId, FilePath)]
        allTarballFilePkgs = localTarballPkgs
                          ++ repoTarballPkgsDownloaded
                          ++ repoTarballPkgsNewlyDownloaded
    hashesFromTarballFiles <- liftIO $
      fmap Map.fromList $
Duncan Coutts's avatar
Duncan Coutts committed
882 883 884
      sequence
        [ do srchash <- readFileHashValue tarball
             return (pkgid, srchash)
885 886 887 888 889 890 891 892
        | (pkgid, tarball) <- allTarballFilePkgs
        ]
    monitorFiles [ monitorFile tarball
                 | (_pkgid, tarball) <- allTarballFilePkgs ]

    -- Return the combination
    return $! hashesFromRepoMetadata
           <> hashesFromTarballFiles
Duncan Coutts's avatar
Duncan Coutts committed
893 894 895 896 897 898 899 900 901 902 903 904 905 906


-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------

planPackages :: Compiler
             -> Platform
             -> Solver -> SolverSettings
             -> InstalledPackageIndex
             -> SourcePackageDb
             -> PkgConfigDb
             -> [UnresolvedSourcePackage]
             -> Map PackageName (Map OptionalStanza Bool)
907
             -> Progress String String SolverInstallPlan
Duncan Coutts's avatar
Duncan Coutts committed
908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929
planPackages comp platform solver SolverSettings{..}
             installedPkgIndex sourcePkgDb pkgConfigDB
             localPackages pkgStanzasEnable =

    resolveDependencies
      platform (compilerInfo comp)
      pkgConfigDB solver
      resolverParams

  where

    --TODO: [nice to have] disable multiple instances restriction in the solver, but then
    -- make sure we can cope with that in the output.
    resolverParams =

        setMaxBackjumps solverSettingMaxBackjumps

        --TODO: [required eventually] should only be configurable for custom installs
   -- . setIndependentGoals solverSettingIndependentGoals

      . setReorderGoals solverSettingReorderGoals

930 931
      . setCountConflicts solverSettingCountConflicts

Duncan Coutts's avatar
Duncan Coutts committed
932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947
        --TODO: [required eventually] should only be configurable for custom installs
   -- . setAvoidReinstalls solverSettingAvoidReinstalls

        --TODO: [required eventually] should only be configurable for custom installs
   -- . setShadowPkgs solverSettingShadowPkgs

      . setStrongFlags solverSettingStrongFlags

        --TODO: [required eventually] decide if we need to prefer installed for
        -- global packages, or prefer latest even for global packages. Perhaps
        -- should be configurable but with a different name than "upgrade-dependencies".
      . setPreferenceDefault PreferLatestForSelected
                           {-(if solverSettingUpgradeDeps
                                then PreferAllLatest
                                else PreferLatestForSelected)-}

948 949
      . removeLowerBounds solverSettingAllowOlder
      . removeUpperBounds solverSettingAllowNewer
Duncan Coutts's avatar
Duncan Coutts committed
950

951
      . addDefaultSetupDependencies (defaultSetupDeps comp platform
Duncan Coutts's avatar
Duncan Coutts committed
952 953 954 955 956 957 958 959 960
                                   . PD.packageDescription
                                   . packageDescription)

      . addPreferences
          -- preferences from the config file or command line
          [ PackageVersionPreference name ver
          | Dependency name ver <- solverSettingPreferences ]

      . addConstraints
961 962 963 964 965 966 967 968 969 970 971

          -- If a package has a custom setup then we need to add a setup-depends
          -- on Cabal. For now it's easier to add this unconditionally.  Once
          -- qualified constraints land we can turn this into a custom setup
          -- only constraint.
          --
          -- TODO: use a qualified constraint
            [ LabeledPackageConstraint (PackageConstraintVersion cabalPkgname
                                       (orLaterVersion (mkVersion [1,20])))
                                       ConstraintNewBuildCustomSetupLowerBoundCabal
                                       ] . addConstraints
Duncan Coutts's avatar
Duncan Coutts committed
972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000
          -- version constraints from the config file or command line
            [ LabeledPackageConstraint (userToPackageConstraint pc) src
            | (pc, src) <- solverSettingConstraints ]

      . addPreferences
          -- enable stanza preference where the user did not specify
          [ PackageStanzasPreference pkgname stanzas
          | pkg <- localPackages
          , let pkgname = packageName pkg
                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable
                stanzas = [ stanza | stanza <- [minBound..maxBound]
                          , Map.lookup stanza stanzaM == Nothing ]
          , not (null stanzas)
          ]

      . addConstraints
          -- enable stanza constraints where the user asked to enable
          [ LabeledPackageConstraint
              (PackageConstraintStanzas pkgname stanzas)
              ConstraintSourceConfigFlagOrTarget
          | pkg <- localPackages
          , let pkgname = packageName pkg
                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable
                stanzas = [ stanza | stanza <- [minBound..maxBound]
                          , Map.lookup stanza stanzaM == Just True ]
          , not (null stanzas)
          ]

      . addConstraints
1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012
          --TODO: [nice to have] should have checked at some point that the
          -- package in question actually has these flags.
          [ LabeledPackageConstraint
              (PackageConstraintFlags pkgname flags)
              ConstraintSourceConfigFlagOrTarget
          | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ]

      . addConstraints
          --TODO: [nice to have] we have user-supplied flags for unspecified
          -- local packages (as well as specific per-package flags). For the
          -- former we just apply all these flags to all local targets which
          -- is silly. We should check if the flags are appropriate.
Duncan Coutts's avatar
Duncan Coutts committed
1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023
          [ LabeledPackageConstraint
              (PackageConstraintFlags pkgname flags)
              ConstraintSourceConfigFlagOrTarget
          | let flags = solverSettingFlagAssignment
          , not (null flags)
          , pkg <- localPackages
          , let pkgname = packageName pkg ]

      $ stdResolverParams

    stdResolverParams =
1024 1025 1026
      -- Note: we don't use the standardInstallPolicy here, since that uses
      -- its own addDefaultSetupDependencies that is not appropriate for us.
      basicInstallPolicy
Duncan Coutts's avatar
Duncan Coutts committed
1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061
        installedPkgIndex sourcePkgDb
        (map SpecificSourcePackage localPackages)


------------------------------------------------------------------------------
-- * Install plan post-processing
------------------------------------------------------------------------------

-- This phase goes from the InstallPlan we get from the solver and has to
-- make an elaborated install plan.
--
-- We go in two steps:
--
--  1. elaborate all the source packages that the solver has chosen.
--  2. swap source packages for pre-existing installed packages wherever
--     possible.
--
-- We do it in this order, elaborating and then replacing, because the easiest
-- way to calculate the installed package ids used for the replacement step is
-- from the elaborated configuration for each package.




------------------------------------------------------------------------------
-- * Install plan elaboration
------------------------------------------------------------------------------

-- | Produce an elaborated install plan using the policy for local builds with
-- a nix-style shared store.
--
-- In theory should be able to make an elaborated install plan with a policy
-- matching that of the classic @cabal install --user@ or @--global@
--
elaborateInstallPlan
1062
  :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb
Duncan Coutts's avatar
Duncan Coutts committed
1063 1064 1065 1066 1067 1068 1069 1070 1071
  -> DistDirLayout
  -> CabalDirLayout
  -> SolverInstallPlan
  -> [SourcePackage loc]
  -> Map PackageId PackageSourceHash
  -> InstallDirs.InstallDirTemplates
  -> ProjectConfigShared
  -> PackageConfig
  -> Map PackageName PackageConfig
1072 1073
  -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)
elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
Duncan Coutts's avatar
Duncan Coutts committed
1074 1075
                     DistDirLayout{..}
                     cabalDirLayout@CabalDirLayout{cabalStorePackageDB}
1076
                     solverPlan localPackages
Duncan Coutts's avatar
Duncan Coutts committed
1077 1078 1079 1080
                     sourcePackageHashes
                     defaultInstallDirs
                     _sharedPackageConfig
                     localPackagesConfig
1081 1082 1083
                     perPackageConfig = do
    x <- elaboratedInstallPlan
    return (x, elaboratedSharedConfig)
Duncan Coutts's avatar
Duncan Coutts committed
1084 1085 1086
  where
    elaboratedSharedConfig =
      ElaboratedSharedConfig {
1087 1088 1089
        pkgConfigPlatform      = platform,
        pkgConfigCompiler      = compiler,
        pkgConfigCompilerProgs = compilerprogdb
Duncan Coutts's avatar
Duncan Coutts committed
1090 1091
      }

1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102
    preexistingInstantiatedPkgs =
        Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan))
      where
        f (SolverInstallPlan.PreExisting inst)
            | not (IPI.indefinite ipkg)
            = Just (IPI.installedUnitId ipkg,
                     (FullUnitId (IPI.installedComponentId ipkg)
                                 (Map.fromList (IPI.instantiatedWith ipkg))))
         where ipkg = instSolverPkgIPI inst
        f _ = Nothing

Duncan Coutts's avatar
Duncan Coutts committed
1103
    elaboratedInstallPlan =
1104
      flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->
Duncan Coutts's avatar
Duncan Coutts committed
1105
        case planpkg of
1106
          SolverInstallPlan.PreExisting pkg ->
1107
            return [InstallPlan.PreExisting (instSolverPkgIPI pkg)]
Duncan Coutts's avatar
Duncan Coutts committed
1108

1109
          SolverInstallPlan.Configured  pkg ->
1110
            map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg
1111

1112 1113
    -- NB: We don't INSTANTIATE packages at this point.  That's
    -- a post-pass.  This makes it simpler to compute dependencies.
1114
    elaborateSolverToComponents
1115 1116
        :: (SolverId -> [ElaboratedPlanPackage])
        -> SolverPackage UnresolvedPkgLoc
1117
        -> LogProgress [ElaboratedConfiguredPackage]
1118
    elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0)
1119
        | Right g <- toComponentsGraph (elabEnabledSpec elab0) pd = do
1120 1121
            infoProgress $ hang (text "Component graph for" <+> disp pkgid <<>> colon)
                            4 (dispComponentsGraph g)
1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137
            (_, comps) <- mapAccumM buildComponent
                            ((Map.empty, Map.empty), Map.empty, Map.empty)
                            (map fst g)
            let is_public_lib ElaboratedConfiguredPackage{..} =
                    case elabPkgOrComp of
                        ElabComponent comp -> compSolverName comp == CD.ComponentLib
                        _ -> False
                modShape = case find is_public_lib comps of
                            Nothing -> emptyModuleShape
                            Just ElaboratedConfiguredPackage{..} -> elabModuleShape
            return $ if eligible
                then comps
                else [(elaborateSolverToPackage mapDep spkg) {
                        elabModuleShape = modShape
                     }]
        | otherwise = failProgress (text "component cycle in" <+> disp pkgid)
1138
      where
1139 1140 1141 1142 1143 1144 1145
        eligible
            -- At this point in time, only non-Custom setup scripts
            -- are supported.  Implementing per-component builds with
            -- Custom would require us to create a new 'ElabSetup'
            -- type, and teach all of the code paths how to handle it.
            -- Once you've implemented this, swap it for the code below.
            = fromMaybe PD.Custom (PD.buildType (elabPkgDescription elab0)) /= PD.Custom
1146 1147 1148 1149 1150
            -- cabal-format versions prior to 1.8 have different build-depends semantics
            -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8
            -- see, https://github.com/haskell/cabal/issues/4121
              && PD.specVersion pd >= mkVersion [1,8]

1151 1152 1153 1154
            {-
            -- Only non-Custom or sufficiently recent Custom
            -- scripts can be build per-component.
            = (fromMaybe PD.Custom (PD.buildType pd) /= PD.Custom)
1155
                || PD.specVersion pd >= mkVersion [1,25,0]
1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172
            -}

        elab0 = elaborateSolverToCommon mapDep spkg
        pkgid = elabPkgSourceId    elab0
        pd    = elabPkgDescription elab0

        buildComponent
            :: (ConfiguredComponentMap,
                LinkedComponentMap,
                Map ComponentId FilePath)
            -> Cabal.Component
            -> LogProgress
                ((ConfiguredComponentMap,
                  LinkedComponentMap,
                  Map ComponentId FilePath),
                ElaboratedConfiguredPackage)
        buildComponent (cc_map, lc_map, exe_map) comp = do
1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187
            -- Before we get too far, check if we depended on something
            -- unbuildable.  If we did, give a good error.  (If we don't
            -- check, the 'toConfiguredComponent' will assert fail, see #3978).
            case unbuildable_external_lib_deps of
                [] -> return ()
                deps -> failProgress $
                            text "The package" <+> disp pkgid <+>
                            text "depends on unbuildable libraries:" <+>
                            hsep (punctuate comma (map (disp.solverSrcId) deps))
            case unbuildable_external_exe_deps of
                [] -> return ()
                deps -> failProgress $
                            text "The package" <+> disp pkgid <+>
                            text "depends on unbuildable executables:" <+>
                            hsep (punctuate comma (map (disp.solverSrcId) deps))
1188
            infoProgress $ dispConfiguredComponent cc
1189 1190
            let -- Use of invariant: DefUnitId indicates that if
                -- there is no hash, it must have an empty
1191
                -- instantiation.
1192
                lookup_uid def_uid =
1193 1194 1195
                    case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of
                        Just full -> full
                        Nothing -> error ("lookup_uid: " ++ display def_uid)
1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208
            lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0)
                        (Map.union external_lc_map lc_map) cc
            let lc_map' = extendLinkedComponentMap lc lc_map
            infoProgress $ dispLinkedComponent lc
            -- NB: For inplace NOT InstallPaths.bindir installDirs; for an
            -- inplace build those values are utter nonsense.  So we
            -- have to guess where the directory is going to be.
            -- Fortunately this is "stable" part of Cabal API.
            -- But the way we get the build directory is A HORRIBLE