ProjectPlanning.hs 144 KB
Newer Older
1
{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-}
2 3 4
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
5
{-# LANGUAGE DeriveDataTypeable #-}
6
{-# LANGUAGE DeriveFunctor #-}
Duncan Coutts's avatar
Duncan Coutts committed
7 8 9 10 11 12 13 14 15 16 17 18 19 20

-- | 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
21
    rebuildProjectConfig,
Duncan Coutts's avatar
Duncan Coutts committed
22 23 24
    rebuildInstallPlan,

    -- * Build targets
25 26 27 28
    availableTargets,
    AvailableTarget(..),
    AvailableTargetStatus(..),
    TargetRequested(..),
Duncan Coutts's avatar
Duncan Coutts committed
29 30 31
    ComponentTarget(..),
    SubComponentTarget(..),
    showComponentTarget,
32
    nubComponentTargets,
Duncan Coutts's avatar
Duncan Coutts committed
33 34 35

    -- * Selecting a plan subset
    pruneInstallPlanToTargets,
36
    TargetAction(..),
37
    pruneInstallPlanToDependencies,
38
    CannotPruneDependencies(..),
Duncan Coutts's avatar
Duncan Coutts committed
39 40 41

    -- * Utils required for building
    pkgHasEphemeralBuildTargets,
42
    elabBuildTargetWholeComponents,
Duncan Coutts's avatar
Duncan Coutts committed
43 44 45 46

    -- * Setup.hs CLI flags for building
    setupHsScriptOptions,
    setupHsConfigureFlags,
47
    setupHsConfigureArgs,
Duncan Coutts's avatar
Duncan Coutts committed
48 49 50 51
    setupHsBuildFlags,
    setupHsBuildArgs,
    setupHsReplFlags,
    setupHsReplArgs,
Oleg Grenrus's avatar
Oleg Grenrus committed
52 53
    setupHsTestFlags,
    setupHsTestArgs,
Duncan Coutts's avatar
Duncan Coutts committed
54 55 56 57 58 59 60 61 62 63
    setupHsCopyFlags,
    setupHsRegisterFlags,
    setupHsHaddockFlags,

    packageHashInputs,

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

64 65 66
import Prelude ()
import Distribution.Client.Compat.Prelude

67
import           Distribution.Client.ProjectPlanning.Types as Ty
Duncan Coutts's avatar
Duncan Coutts committed
68 69 70
import           Distribution.Client.PackageHash
import           Distribution.Client.RebuildMonad
import           Distribution.Client.ProjectConfig
71
import           Distribution.Client.ProjectPlanOutput
Duncan Coutts's avatar
Duncan Coutts committed
72

73
import           Distribution.Client.Types
Duncan Coutts's avatar
Duncan Coutts committed
74
import qualified Distribution.Client.InstallPlan as InstallPlan
75
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
Duncan Coutts's avatar
Duncan Coutts committed
76 77 78 79 80 81 82 83
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
84
import qualified Hackage.Security.Client as Sec
Duncan Coutts's avatar
Duncan Coutts committed
85
import           Distribution.Client.Setup hiding (packageName, cabalVersion)
86
import           Distribution.Utils.NubList
87 88
import           Distribution.Utils.LogProgress
import           Distribution.Utils.MapAccum
Duncan Coutts's avatar
Duncan Coutts committed
89

90 91
import qualified Distribution.Solver.Types.ComponentDeps as CD
import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)
92
import           Distribution.Solver.Types.ConstraintSource
93
import           Distribution.Solver.Types.LabeledPackageConstraint
94 95
import           Distribution.Solver.Types.OptionalStanza
import           Distribution.Solver.Types.PkgConfigDb
96
import           Distribution.Solver.Types.ResolverPackage
97 98
import           Distribution.Solver.Types.SolverId
import           Distribution.Solver.Types.SolverPackage
99
import           Distribution.Solver.Types.InstSolverPackage
100
import           Distribution.Solver.Types.SourcePackage
101
import           Distribution.Solver.Types.Settings
102

103
import           Distribution.ModuleName
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
104 105
import           Distribution.Package hiding
  (InstalledPackageId, installedPackageId)
106
import           Distribution.Types.ComponentName
107
import           Distribution.Types.Dependency
108
import           Distribution.Types.ExeDependency
109 110
import           Distribution.Types.PkgconfigDependency
import           Distribution.Types.UnqualComponentName
Duncan Coutts's avatar
Duncan Coutts committed
111 112 113 114
import           Distribution.System
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Configuration as PD
115
import           Distribution.Simple.BuildToolDepends
Duncan Coutts's avatar
Duncan Coutts committed
116 117 118 119 120 121 122 123
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
124 125
import           Distribution.Simple.Setup
  (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault)
Duncan Coutts's avatar
Duncan Coutts committed
126 127
import qualified Distribution.Simple.Configure as Cabal
import qualified Distribution.Simple.LocalBuildInfo as Cabal
128 129 130
import           Distribution.Simple.LocalBuildInfo
                   ( Component(..), pkgComponents, componentBuildInfo
                   , componentName )
Duncan Coutts's avatar
Duncan Coutts committed
131 132
import qualified Distribution.Simple.Register as Cabal
import qualified Distribution.Simple.InstallDirs as InstallDirs
133
import qualified Distribution.InstalledPackageInfo as IPI
Duncan Coutts's avatar
Duncan Coutts committed
134

135 136
import           Distribution.Backpack.ConfiguredComponent
import           Distribution.Backpack.LinkedComponent
137
import           Distribution.Backpack.ComponentsGraph
138 139 140
import           Distribution.Backpack.ModuleShape
import           Distribution.Backpack.FullUnitId
import           Distribution.Backpack
141
import           Distribution.Types.ComponentInclude
142

Duncan Coutts's avatar
Duncan Coutts committed
143 144 145 146 147
import           Distribution.Simple.Utils hiding (matchFileGlob)
import           Distribution.Version
import           Distribution.Verbosity
import           Distribution.Text

148
import qualified Distribution.Compat.Graph as Graph
149
import           Distribution.Compat.Graph(IsNode(..))
150

151
import           Text.PrettyPrint hiding ((<>))
152
import qualified Text.PrettyPrint as Disp
Duncan Coutts's avatar
Duncan Coutts committed
153 154 155 156
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           Control.Monad
157
import qualified Data.Traversable as T
Duncan Coutts's avatar
Duncan Coutts committed
158 159
import           Control.Monad.State as State
import           Control.Exception
160
import           Data.List (groupBy)
161
import           Data.Either
Duncan Coutts's avatar
Duncan Coutts committed
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 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205
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).
--

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

208 209 210 211 212
-- type ElaboratedInstallPlan = ...
-- type ElaboratedPlanPackage = ...
-- data ElaboratedSharedConfig = ...
-- data ElaboratedConfiguredPackage = ...
-- data BuildStyle =
Duncan Coutts's avatar
Duncan Coutts committed
213 214


215
-- | Check that an 'ElaboratedConfiguredPackage' actually makes
216
-- sense under some 'ElaboratedSharedConfig'.
217 218 219 220 221 222 223 224 225 226
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
227

228 229 230 231
    -- 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
232
  . assert (elabBuildStyle == BuildInplaceOnly ||
233
     elabComponentId == hashedInstalledPackageId
234 235 236 237 238
                            (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
239

240 241 242
    -- 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!)
243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260
  . 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
261 262 263 264
        -- 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
265 266 267 268 269 270 271 272 273 274 275 276 277 278
        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)
279

280 281 282 283
    -- 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
284 285 286 287 288

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

289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344
-- | Return the up-to-date project config and information about the local
-- packages within the project.
--
rebuildProjectConfig :: Verbosity
                     -> InstallFlags --TODO: eliminate
                     -> FilePath
                     -> DistDirLayout
                     -> ProjectConfig
                     -> IO (ProjectConfig, [UnresolvedSourcePackage])
rebuildProjectConfig verbosity
                     installFlags
                     projectRootDir
                     DistDirLayout {
                       distDirectory,
                       distProjectCacheFile,
                       distProjectCacheDirectory
                     }
                     cliConfig = do

    (projectConfig, localPackages) <-
      runRebuild projectRootDir $
      rerunIfChanged verbosity fileMonitorProjectConfig () $ do

        projectConfig <- phaseReadProjectConfig
        localPackages <- phaseReadLocalPackages projectConfig
        return (projectConfig, localPackages)

    return (projectConfig <> cliConfig, localPackages)

  where
    fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config")

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

      readProjectConfig verbosity installFlags projectRootDir
      --TODO: [code cleanup] eliminate use of legacy config type InstallFlags
      -- use either ProjectConfig, DistDirLayout or separate

    -- 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


-- | Return an up-to-date elaborated install plan.
345 346 347 348 349 350 351 352 353 354 355 356
--
-- 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
357 358 359
rebuildInstallPlan :: Verbosity
                   -> FilePath -> DistDirLayout -> CabalDirLayout
                   -> ProjectConfig
360
                   -> [UnresolvedSourcePackage]
361 362
                   -> IO ( ElaboratedInstallPlan  -- with store packages
                         , ElaboratedInstallPlan  -- with source packages
363
                         , ElaboratedSharedConfig )
364
                      -- ^ @(improvedPlan, elaboratedPlan, _, _)@
Duncan Coutts's avatar
Duncan Coutts committed
365 366 367
rebuildInstallPlan verbosity
                   projectRootDir
                   distDirLayout@DistDirLayout {
368
                     distProjectCacheFile
Duncan Coutts's avatar
Duncan Coutts committed
369 370 371 372
                   }
                   cabalDirLayout@CabalDirLayout {
                     cabalStoreDirectory,
                     cabalStorePackageDB
373
                   } = \projectConfig localPackages ->
374
    runRebuild projectRootDir $ do
Duncan Coutts's avatar
Duncan Coutts committed
375
    progsearchpath <- liftIO $ getSystemSearchPath
376
    let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty }
Duncan Coutts's avatar
Duncan Coutts committed
377 378

    -- The overall improved plan is cached
379
    rerunIfChanged verbosity fileMonitorImprovedPlan
380 381 382
                   -- react to changes in the project config,
                   -- the package .cabal files and the path
                   (projectConfigMonitored, localPackages, progsearchpath) $ do
Duncan Coutts's avatar
Duncan Coutts committed
383 384

      -- And so is the elaborated plan that the improved plan based on
385
      (elaboratedPlan, elaboratedShared) <-
386
        rerunIfChanged verbosity fileMonitorElaboratedPlan
387 388
                       (projectConfigMonitored, localPackages,
                        progsearchpath) $ do
Duncan Coutts's avatar
Duncan Coutts committed
389 390

          compilerEtc   <- phaseConfigureCompiler projectConfig
391
          _             <- phaseConfigurePrograms projectConfig compilerEtc
392
          (solverPlan, pkgConfigDB)
393
                        <- phaseRunSolver         projectConfig
394 395
                                                  compilerEtc
                                                  localPackages
Duncan Coutts's avatar
Duncan Coutts committed
396
          (elaboratedPlan,
397
           elaboratedShared) <- phaseElaboratePlan projectConfig
398 399 400
                                                   compilerEtc pkgConfigDB
                                                   solverPlan
                                                   localPackages
401

402
          phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
403
          return (elaboratedPlan, elaboratedShared)
Duncan Coutts's avatar
Duncan Coutts committed
404 405 406 407 408

      -- 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
409

410
      return (improvedPlan, elaboratedPlan, elaboratedShared)
Duncan Coutts's avatar
Duncan Coutts committed
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429

  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


    -- 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)
430 431 432 433 434 435 436 437 438 439 440 441
    phaseConfigureCompiler ProjectConfig {
                             projectConfigShared = ProjectConfigShared {
                               projectConfigHcFlavor,
                               projectConfigHcPath,
                               projectConfigHcPkg
                             },
                             projectConfigLocalPackages = PackageConfig {
                               packageConfigProgramPaths,
                               packageConfigProgramArgs,
                               packageConfigProgramPathExtra
                             }
                           } = do
Duncan Coutts's avatar
Duncan Coutts committed
442
        progsearchpath <- liftIO $ getSystemSearchPath
443
        rerunIfChanged verbosity fileMonitorCompiler
444 445 446 447
                       (hcFlavor, hcPath, hcPkg, progsearchpath,
                        packageConfigProgramPaths,
                        packageConfigProgramArgs,
                        packageConfigProgramPathExtra) $ do
Duncan Coutts's avatar
Duncan Coutts committed
448 449

          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."
450
          result@(_, _, progdb') <- liftIO $
Duncan Coutts's avatar
Duncan Coutts committed
451 452
            Cabal.configCompilerEx
              hcFlavor hcPath hcPkg
453
              progdb verbosity
Duncan Coutts's avatar
Duncan Coutts committed
454

455 456 457 458 459 460 461
        -- 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
462 463 464 465 466 467

          return result
      where
        hcFlavor = flagToMaybe projectConfigHcFlavor
        hcPath   = flagToMaybe projectConfigHcPath
        hcPkg    = flagToMaybe projectConfigHcPkg
468 469 470 471 472 473 474
        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
475 476


477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507
    -- 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
508 509 510 511 512 513
    -- Run the solver to get the initial install plan.
    -- This is expensive so we cache it independently.
    --
    phaseRunSolver :: ProjectConfig
                   -> (Compiler, Platform, ProgramDb)
                   -> [UnresolvedSourcePackage]
514
                   -> Rebuild (SolverInstallPlan, PkgConfigDb)
Duncan Coutts's avatar
Duncan Coutts committed
515 516 517 518 519 520
    phaseRunSolver projectConfig@ProjectConfig {
                     projectConfigShared,
                     projectConfigBuildOnly
                   }
                   (compiler, platform, progdb)
                   localPackages =
521
        rerunIfChanged verbosity fileMonitorSolverPlan
522
                       (solverSettings,
Duncan Coutts's avatar
Duncan Coutts committed
523
                        localPackages, localPackagesEnabledStanzas,
524
                        compiler, platform, programDbSignature progdb) $ do
Duncan Coutts's avatar
Duncan Coutts committed
525 526 527 528

          installedPkgIndex <- getInstalledPackages verbosity
                                                    compiler progdb platform
                                                    corePackageDbs
529 530 531
          sourcePkgDb       <- getSourcePackages verbosity withRepoCtx
                                 (solverSettingIndexState solverSettings)
          pkgConfigDB       <- getPkgConfigDb verbosity progdb
Duncan Coutts's avatar
Duncan Coutts committed
532

533 534 535 536 537
          --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
538 539 540 541 542 543
          liftIO $ do
            solver <- chooseSolver verbosity
                                   (solverSettingSolver solverSettings)
                                   (compilerInfo compiler)

            notice verbosity "Resolving dependencies..."
544
            plan <- foldProgress logMsg (die' verbosity) return $
545
              planPackages verbosity compiler platform solver solverSettings
Duncan Coutts's avatar
Duncan Coutts committed
546 547
                           installedPkgIndex sourcePkgDb pkgConfigDB
                           localPackages localPackagesEnabledStanzas
548
            return (plan, pkgConfigDB)
Duncan Coutts's avatar
Duncan Coutts committed
549 550 551 552 553
      where
        corePackageDbs = [GlobalPackageDB]
        withRepoCtx    = projectConfigWithSolverRepoContext verbosity
                           projectConfigShared
                           projectConfigBuildOnly
554
        solverSettings = resolveSolverSettings projectConfig
Duncan Coutts's avatar
Duncan Coutts committed
555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580
        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)
581
                       -> PkgConfigDb
582
                       -> SolverInstallPlan
Duncan Coutts's avatar
Duncan Coutts committed
583 584 585 586 587 588 589 590 591
                       -> [SourcePackage loc]
                       -> Rebuild ( ElaboratedInstallPlan
                                  , ElaboratedSharedConfig )
    phaseElaboratePlan ProjectConfig {
                         projectConfigShared,
                         projectConfigLocalPackages,
                         projectConfigSpecificPackage,
                         projectConfigBuildOnly
                       }
592
                       (compiler, platform, progdb) pkgConfigDB
593
                       solverPlan localPackages = do
Duncan Coutts's avatar
Duncan Coutts committed
594 595 596 597

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

        sourcePackageHashes <-
598
          rerunIfChanged verbosity fileMonitorSourceHashes
599
                         (packageLocationsSignature solverPlan) $
Duncan Coutts's avatar
Duncan Coutts committed
600 601 602
            getPackageSourceHashes verbosity withRepoCtx solverPlan

        defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler
603 604
        (elaboratedPlan, elaboratedShared)
          <- liftIO . runLogProgress verbosity $
605
              elaborateInstallPlan
606
                verbosity
607
                platform compiler progdb pkgConfigDB
608 609 610 611 612 613 614 615 616
                distDirLayout
                cabalDirLayout
                solverPlan
                localPackages
                sourcePackageHashes
                defaultInstallDirs
                projectConfigShared
                projectConfigLocalPackages
                (getMapMappend projectConfigSpecificPackage)
617 618 619
        let instantiatedPlan = instantiateInstallPlan elaboratedPlan
        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)
        return (instantiatedPlan, elaboratedShared)
Duncan Coutts's avatar
Duncan Coutts committed
620
      where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
621
        withRepoCtx = projectConfigWithSolverRepoContext verbosity
Duncan Coutts's avatar
Duncan Coutts committed
622 623 624
                        projectConfigShared
                        projectConfigBuildOnly

625 626
    -- Update the files we maintain that reflect our current build environment.
    -- In particular we maintain a JSON representation of the elaborated
627 628
    -- install plan (but not the improved plan since that reflects the state
    -- of the build rather than just the input environment).
629 630 631 632
    --
    phaseMaintainPlanOutputs :: ElaboratedInstallPlan
                             -> ElaboratedSharedConfig
                             -> Rebuild ()
633 634 635 636 637 638
    phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do
        debug verbosity "Updating plan.json"
        writePlanExternalRepresentation
          distDirLayout
          elaboratedPlan
          elaboratedShared
639 640


Duncan Coutts's avatar
Duncan Coutts committed
641 642 643 644 645 646 647 648 649 650 651 652 653 654 655
    -- 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..."
656
        createDirectoryMonitored True storeDirectory
657 658 659 660
        liftIO $ createPackageDBIfMissing verbosity
                                          compiler progdb
                                          storePackageDb
        storePkgIdSet <- getInstalledStorePackages storeDirectory
661
        let improvedPlan = improveInstallPlanWithInstalledPackages
662
                             storePkgIdSet
Duncan Coutts's avatar
Duncan Coutts committed
663
                             elaboratedPlan
664
        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan)
665 666 667 668
        -- 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
669 670 671 672 673
        return improvedPlan
      where
        storeDirectory  = cabalStoreDirectory (compilerId compiler)
        storePackageDb  = cabalStorePackageDB (compilerId compiler)
        ElaboratedSharedConfig {
674 675
          pkgConfigCompiler      = compiler,
          pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
676 677 678 679 680 681 682 683 684 685 686 687 688 689
        } = 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.
--
690 691
programDbSignature :: ProgramDb -> [ConfiguredProgram]
programDbSignature progdb =
Duncan Coutts's avatar
Duncan Coutts committed
692 693 694 695 696 697 698
    [ prog { programMonitorFiles = []
           , programOverrideEnv  = filter ((/="PATH") . fst)
                                          (programOverrideEnv prog) }
    | prog <- configuredPrograms progdb ]

getInstalledPackages :: Verbosity
                     -> Compiler -> ProgramDb -> Platform
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
699
                     -> PackageDBStack
Duncan Coutts's avatar
Duncan Coutts committed
700 701
                     -> Rebuild InstalledPackageIndex
getInstalledPackages verbosity compiler progdb platform packagedbs = do
702
    monitorFiles . map monitorFileOrDirectory
Duncan Coutts's avatar
Duncan Coutts committed
703 704 705 706 707 708 709
      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles
                    verbosity compiler
                    packagedbs progdb platform)
    liftIO $ IndexUtils.getInstalledPackages
               verbosity compiler
               packagedbs progdb

710 711
{-
--TODO: [nice to have] use this but for sanity / consistency checking
Duncan Coutts's avatar
Duncan Coutts committed
712 713 714 715 716
getPackageDBContents :: Verbosity
                     -> Compiler -> ProgramDb -> Platform
                     -> PackageDB
                     -> Rebuild InstalledPackageIndex
getPackageDBContents verbosity compiler progdb platform packagedb = do
717
    monitorFiles . map monitorFileOrDirectory
Duncan Coutts's avatar
Duncan Coutts committed
718 719 720 721
      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles
                    verbosity compiler
                    [packagedb] progdb platform)
    liftIO $ do
722
      createPackageDBIfMissing verbosity compiler progdb packagedb
Duncan Coutts's avatar
Duncan Coutts committed
723 724
      Cabal.getPackageDBContents verbosity compiler
                                 packagedb progdb
725
-}
Duncan Coutts's avatar
Duncan Coutts committed
726

727 728 729 730 731 732
-- | Return the 'UnitId's of all packages\/components already installed in the
-- store.
--
getInstalledStorePackages :: FilePath -- ^ store directory
                          -> Rebuild (Set UnitId)
getInstalledStorePackages storeDirectory = do
733
    paths <- getDirectoryContentsMonitored storeDirectory
734
    return $ Set.fromList [ newSimpleUnitId (mkComponentId path)
735
                          | path <- paths, valid path ]
736
  where
737
    valid ('.':_)      = False
738
    valid "package.db" = False
739
    valid _            = True
740

Duncan Coutts's avatar
Duncan Coutts committed
741
getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
742
                  -> Maybe IndexUtils.IndexState -> Rebuild SourcePackageDb
743
getSourcePackages verbosity withRepoCtx idxState = do
Duncan Coutts's avatar
Duncan Coutts committed
744
    (sourcePkgDb, repos) <-
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
745
      liftIO $
Duncan Coutts's avatar
Duncan Coutts committed
746
        withRepoCtx $ \repoctx -> do
747 748
          sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity
                                                                  repoctx idxState
Duncan Coutts's avatar
Duncan Coutts committed
749 750
          return (sourcePkgDb, repoContextRepos repoctx)

751 752 753
    mapM_ needIfExists
        . IndexUtils.getSourcePackagesMonitorFiles
        $ repos
Duncan Coutts's avatar
Duncan Coutts committed
754 755
    return sourcePkgDb

756 757 758 759

-- | 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
760
createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb
761 762 763 764 765
                         -> PackageDB -> IO ()
createPackageDBIfMissing verbosity compiler progdb
                         (SpecificPackageDB dbPath) = do
    exists <- liftIO $ Cabal.doesPackageDBExist dbPath
    unless exists $ do
766
      createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
767 768
      Cabal.createPackageDB verbosity compiler progdb False dbPath
createPackageDBIfMissing _ _ _ _ = return ()
Duncan Coutts's avatar
Duncan Coutts committed
769 770


771 772 773 774 775
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.
776
    mapM_ monitorDirectoryStatus dirs
777 778 779
    liftIO $ readPkgConfigDb verbosity progdb


780 781 782 783 784
-- | Select the config values to monitor for changes package source hashes.
packageLocationsSignature :: SolverInstallPlan
                          -> [(PackageId, PackageLocation (Maybe FilePath))]
packageLocationsSignature solverPlan =
    [ (packageId pkg, packageSource pkg)
785 786
    | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})
        <- SolverInstallPlan.toList solverPlan
787 788 789
    ]


Duncan Coutts's avatar
Duncan Coutts committed
790 791 792 793 794 795 796 797 798
-- | 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)
799
getPackageSourceHashes verbosity withRepoCtx solverPlan = do
Duncan Coutts's avatar
Duncan Coutts committed
800

801
    -- Determine if and where to get the package's source hash from.
Duncan Coutts's avatar
Duncan Coutts committed
802
    --
803 804 805
    let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))]
        allPkgLocations =
          [ (packageId pkg, packageSource pkg)
806 807
          | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})
              <- SolverInstallPlan.toList solverPlan ]
808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837

        -- 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
838
    --
839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867
    (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
868
                sequence
869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897
                  [ 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
898
    --
899 900 901 902 903 904
    let allTarballFilePkgs :: [(PackageId, FilePath)]
        allTarballFilePkgs = localTarballPkgs
                          ++ repoTarballPkgsDownloaded
                          ++ repoTarballPkgsNewlyDownloaded
    hashesFromTarballFiles <- liftIO $
      fmap Map.fromList $
Duncan Coutts's avatar
Duncan Coutts committed
905 906 907
      sequence
        [ do srchash <- readFileHashValue tarball
             return (pkgid, srchash)
908 909 910 911 912 913 914 915
        | (pkgid, tarball) <- allTarballFilePkgs
        ]
    monitorFiles [ monitorFile tarball
                 | (_pkgid, tarball) <- allTarballFilePkgs ]

    -- Return the combination
    return $! hashesFromRepoMetadata
           <> hashesFromTarballFiles
Duncan Coutts's avatar
Duncan Coutts committed
916 917 918 919 920 921


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

922 923
planPackages :: Verbosity
             -> Compiler
Duncan Coutts's avatar
Duncan Coutts committed
924 925 926 927 928 929 930
             -> Platform
             -> Solver -> SolverSettings
             -> InstalledPackageIndex
             -> SourcePackageDb
             -> PkgConfigDb
             -> [UnresolvedSourcePackage]
             -> Map PackageName (Map OptionalStanza Bool)
931
             -> Progress String String SolverInstallPlan
932
planPackages verbosity comp platform solver SolverSettings{..}
Duncan Coutts's avatar
Duncan Coutts committed
933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953
             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

954 955
      . setCountConflicts solverSettingCountConflicts

Duncan Coutts's avatar
Duncan Coutts committed
956 957 958 959 960 961 962 963
        --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

964
      . setAllowBootLibInstalls solverSettingAllowBootLibInstalls
965

966 967
      . setSolverVerbosity verbosity

Duncan Coutts's avatar
Duncan Coutts committed
968 969 970 971 972 973 974 975
        --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)-}

976 977
      . removeLowerBounds solverSettingAllowOlder
      . removeUpperBounds solverSettingAllowNewer
Duncan Coutts's avatar
Duncan Coutts committed
978

979
      . addDefaultSetupDependencies (defaultSetupDeps comp platform
Duncan Coutts's avatar
Duncan Coutts committed
980 981 982
                                   . PD.packageDescription
                                   . packageDescription)

983 984 985 986 987 988 989 990 991 992 993 994 995
      . addSetupCabalMinVersionConstraint (mkVersion [1,20])
          -- While we can talk to older Cabal versions (we need to be able to
          -- do so for custom Setup scripts that require older Cabal lib
          -- versions), we have problems talking to some older versions that
          -- don't support certain features.
          --
          -- For example, Cabal-1.16 and older do not know about build targets.
          -- Even worse, 1.18 and older only supported the --constraint flag
          -- with source package ids, not --dependency with installed package
          -- ids. That is bad because we cannot reliably select the right
          -- dependencies in the presence of multiple instances (i.e. the
          -- store). See issue #3932. So we require Cabal 1.20 as a minimum.

Duncan Coutts's avatar
Duncan Coutts committed
996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019
      . addPreferences
          -- preferences from the config file or command line
          [ PackageVersionPreference name ver
          | Dependency name ver <- solverSettingPreferences ]

      . addConstraints
          -- 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
1020
              (PackageConstraint (scopeToplevel pkgname)
1021
                                 (PackagePropertyStanzas stanzas))
Duncan Coutts's avatar
Duncan Coutts committed
1022 1023 1024 1025 1026 1027 1028 1029 1030 1031
              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
1032 1033 1034
          --TODO: [nice to have] should have checked at some point that the
          -- package in question actually has these flags.
          [ LabeledPackageConstraint
1035
              (PackageConstraint (scopeToplevel pkgname)
1036
                                 (PackagePropertyFlags flags))
1037 1038 1039 1040 1041 1042 1043 1044
              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
1045
          [ LabeledPackageConstraint
1046
              (PackageConstraint (scopeToplevel pkgname)
1047
                                 (PackagePropertyFlags flags))
Duncan Coutts's avatar
Duncan Coutts committed
1048 1049 1050 1051 1052 1053 1054 1055 1056
              ConstraintSourceConfigFlagOrTarget
          | let flags = solverSettingFlagAssignment
          , not (null flags)
          , pkg <- localPackages
          , let pkgname = packageName pkg ]

      $ stdResolverParams

    stdResolverParams =
1057 1058 1059
      -- 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
1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094
        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
1095
  :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb
Duncan Coutts's avatar
Duncan Coutts committed
1096 1097 1098 1099 1100 1101 1102 1103 1104
  -> DistDirLayout
  -> CabalDirLayout
  -> SolverInstallPlan
  -> [SourcePackage loc]
  -> Map PackageId PackageSourceHash
  -> InstallDirs.InstallDirTemplates
  -> ProjectConfigShared
  -> PackageConfig
  -> Map PackageName PackageConfig
1105 1106
  -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)
elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
Duncan Coutts's avatar
Duncan Coutts committed
1107 1108
                     DistDirLayout{..}
                     cabalDirLayout@CabalDirLayout{cabalStorePackageDB}
1109
                     solverPlan localPackages
Duncan Coutts's avatar
Duncan Coutts committed
1110 1111 1112 1113
                     sourcePackageHashes
                     defaultInstallDirs
                     _sharedPackageConfig
                     localPackagesConfig
1114 1115 1116
                     perPackageConfig = do
    x <- elaboratedInstallPlan
    return (x, elaboratedSharedConfig)
Duncan Coutts's avatar
Duncan Coutts committed
1117 1118 1119
  where
    elaboratedSharedConfig =
      ElaboratedSharedConfig {
1120 1121 1122
        pkgConfigPlatform      = platform,
        pkgConfigCompiler      = compiler,
        pkgConfigCompilerProgs = compilerprogdb
Duncan Coutts's avatar
Duncan Coutts committed
1123 1124
      }

1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135
    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
1136
    elaboratedInstallPlan =
1137
      flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->
Duncan Coutts's avatar
Duncan Coutts committed
1138
        case planpkg of
1139
          SolverInstallPlan.PreExisting pkg ->
1140
            return [InstallPlan.PreExisting (instSolverPkgIPI pkg)]
Duncan Coutts's avatar
Duncan Coutts committed
1141

1142
          SolverInstallPlan.Configured  pkg ->
1143 1144 1145 1146 1147
            let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace"
                            | otherwise                  = Disp.empty
            in addProgressCtx (text "In the" <+> inplace_doc