CmdInstall.hs 29.7 KB
Newer Older
1
{-# LANGUAGE LambdaCase #-}
Francesco Gazzetta's avatar
Francesco Gazzetta committed
2
{-# LANGUAGE NamedFieldPuns #-}
3
{-# LANGUAGE RecordWildCards #-}
4
{-# LANGUAGE ScopedTypeVariables #-}
Francesco Gazzetta's avatar
Francesco Gazzetta committed
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
{-# LANGUAGE ViewPatterns #-}

-- | cabal-install CLI command: build
--
module Distribution.Client.CmdInstall (
    -- * The @build@ CLI and action
    installCommand,
    installAction,

    -- * Internals exposed for testing
    TargetProblem(..),
    selectPackageTargets,
    selectComponentTarget
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
Alexis Williams's avatar
Alexis Williams committed
25
import Distribution.Client.CmdSdist
Francesco Gazzetta's avatar
Francesco Gazzetta committed
26
27

import Distribution.Client.Setup
Alexis Williams's avatar
Alexis Williams committed
28
29
30
31
         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags
         , configureExOptions, installOptions, liftOptions )
import Distribution.Solver.Types.ConstraintSource
         ( ConstraintSource(..) )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
32
import Distribution.Client.Types
Alexis Williams's avatar
Alexis Williams committed
33
         ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage )
34
35
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
36
         ( Package(..), PackageName, mkPackageName )
37
38
import Distribution.Types.PackageId
         ( PackageIdentifier(..) )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
39
import Distribution.Client.ProjectConfig.Types
Alexis Williams's avatar
Alexis Williams committed
40
41
42
43
44
         ( ProjectConfig(..), ProjectConfigShared(..)
         , ProjectConfigBuildOnly(..), PackageConfig(..)
         , getMapLast, getMapMappend, projectConfigLogsDir
         , projectConfigStoreDir, projectConfigBuildOnly
         , projectConfigDistDir, projectConfigConfigFile )
45
46
47
48
import Distribution.Simple.Program.Db
         ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb
         , modifyProgramSearchPath )
import Distribution.Simple.Program.Find
Alexis Williams's avatar
Alexis Williams committed
49
         ( ProgramSearchPathEntry(..) )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
50
import Distribution.Client.Config
51
         ( getCabalDir )
52
import Distribution.Simple.PackageIndex
53
         ( InstalledPackageIndex, lookupPackageName, lookupUnitId )
54
import Distribution.Types.InstalledPackageInfo
Alexis Williams's avatar
Alexis Williams committed
55
         ( InstalledPackageInfo(..) )
56
57
import Distribution.Types.Version
         ( nullVersion )
Alexis Williams's avatar
Alexis Williams committed
58
59
60
61
import Distribution.Types.VersionRange
         ( thisVersion )
import Distribution.Solver.Types.PackageConstraint
         ( PackageProperty(..) )
62
import Distribution.Client.IndexUtils
63
         ( getSourcePackages, getInstalledPackages )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
64
import Distribution.Client.ProjectConfig
65
         ( readGlobalConfig, projectConfigWithBuilderRepoContext
66
67
68
         , resolveBuildTimeSettings
         , BadPackageLocations(..), BadPackageLocation(..)
         , ProjectConfigProvenance(..) )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
69
import Distribution.Client.DistDirLayout
Alexis Williams's avatar
Alexis Williams committed
70
71
         ( defaultDistDirLayout, DistDirLayout(..), mkCabalDirLayout
         , ProjectRoot(ProjectRootImplicit)
72
73
         , storePackageDirectory, cabalStoreDirLayout
         , CabalDirLayout(..), StoreDirLayout(..) )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
74
75
76
77
78
import Distribution.Client.RebuildMonad
         ( runRebuild )
import Distribution.Client.InstallSymlink
         ( symlinkBinary )
import Distribution.Simple.Setup
Alexis Williams's avatar
Alexis Williams committed
79
         ( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe, toFlag
80
         , trueArg, configureOptions, haddockOptions, flagToList )
Alexis Williams's avatar
Alexis Williams committed
81
82
import Distribution.Solver.Types.SourcePackage
         ( SourcePackage(..) )
83
84
import Distribution.ReadE
         ( succeedReadE )     
Francesco Gazzetta's avatar
Francesco Gazzetta committed
85
import Distribution.Simple.Command
Alexis Williams's avatar
Alexis Williams committed
86
         ( CommandUI(..), ShowOrParseArgs(..), OptionField(..)
87
         , option, usageAlternatives, reqArg )
88
89
import Distribution.Simple.Configure
         ( configCompilerEx )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
90
import Distribution.Simple.Compiler
91
92
93
94
         ( Compiler(..), CompilerId(..), CompilerFlavor(..) )
import Distribution.Simple.GHC
         ( ghcPlatformAndVersionString 
         , GhcImplInfo(..), getImplInfo
Alexis Williams's avatar
Alexis Williams committed
95
         , GhcEnvironmentFileEntry(..)
96
         , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
97
98
99
100
101
import Distribution.Types.UnitId
         ( UnitId )
import Distribution.Types.UnqualComponentName
         ( UnqualComponentName, unUnqualComponentName )
import Distribution.Verbosity
102
         ( Verbosity, normal, lessVerbose )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
103
import Distribution.Simple.Utils
104
         ( wrapText, die', notice, warn
105
106
         , withTempDirectory, createDirectoryIfMissingVerbose
         , ordNub )
107
108
import Distribution.Utils.Generic
         ( writeFileAtomic )
109
110
import Distribution.Text
         ( simpleParse )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
111

112
113
import Control.Exception
         ( catch, throwIO )
Alexis Williams's avatar
Alexis Williams committed
114
import Control.Monad
115
         ( mapM, mapM_ )
116
117
118
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Either
         ( partitionEithers )
119
120
import Data.Ord
         ( comparing, Down(..) )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
121
import qualified Data.Map as Map
122
import qualified Data.Set as Set
123
124
125
126
127
import Distribution.Utils.NubList
         ( fromNubList )
import System.Directory 
         ( getHomeDirectory, doesFileExist, createDirectoryIfMissing
         , getTemporaryDirectory, makeAbsolute )
128
129
import System.FilePath
         ( (</>), takeDirectory )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
130

Alexis Williams's avatar
Alexis Williams committed
131
132
data NewInstallFlags = NewInstallFlags
  { ninstInstallLibs :: Flag Bool
133
  , ninstEnvironmentPath :: Flag FilePath
Alexis Williams's avatar
Alexis Williams committed
134
135
136
137
138
  }

defaultNewInstallFlags :: NewInstallFlags
defaultNewInstallFlags = NewInstallFlags
  { ninstInstallLibs = toFlag False
139
  , ninstEnvironmentPath = mempty
Alexis Williams's avatar
Alexis Williams committed
140
  }
Francesco Gazzetta's avatar
Francesco Gazzetta committed
141

Alexis Williams's avatar
Alexis Williams committed
142
143
144
145
146
147
newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags]
newInstallOptions _ = 
  [ option [] ["lib"]
    "Install libraries rather than executables from the target package."
    ninstInstallLibs (\v flags -> flags { ninstInstallLibs = v })
    trueArg
148
149
150
151
  , option [] ["env-path"]
    "Set the environment file that may be modified."
    ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf })
    (reqArg "PATH" (succeedReadE Flag) flagToList)
Alexis Williams's avatar
Alexis Williams committed
152
153
154
155
156
  ]

installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
                            , HaddockFlags, NewInstallFlags
                            )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
157
158
159
installCommand = CommandUI
  { commandName         = "new-install"
  , commandSynopsis     = "Install packages."
160
161
  , commandUsage        = usageAlternatives
                          "new-install" [ "[TARGETS] [FLAGS]" ]
Francesco Gazzetta's avatar
Francesco Gazzetta committed
162
  , commandDescription  = Just $ \_ -> wrapText $
163
164
165
166
167
168
169
170
171
    "Installs one or more packages. This is done by installing them "
    ++ "in the store and symlinking the executables in the directory "
    ++ "specified by the --symlink-bindir flag (`~/.cabal/bin/` by default). "
    ++ "If you want the installed executables to be available globally, "
    ++ "make sure that the PATH environment variable contains that directory. "
    ++ "\n\n"
    ++ "If TARGET is a library, it will be added to the global environment. "
    ++ "When doing this, cabal will try to build a plan that includes all "
    ++ "the previously installed libraries. This is currently not implemented."
Francesco Gazzetta's avatar
Francesco Gazzetta committed
172
  , commandNotes        = Just $ \pname ->
173
      "Examples:\n"
Francesco Gazzetta's avatar
Francesco Gazzetta committed
174
175
176
      ++ "  " ++ pname ++ " new-install\n"
      ++ "    Install the package in the current directory\n"
      ++ "  " ++ pname ++ " new-install pkgname\n"
177
178
      ++ "    Install the package named pkgname"
      ++ " (fetching it from hackage if necessary)\n"
Francesco Gazzetta's avatar
Francesco Gazzetta committed
179
180
181
182
      ++ "  " ++ pname ++ " new-install ./pkgfoo\n"
      ++ "    Install the package in the ./pkgfoo directory\n"

      ++ cmdCommonHelpTextNewBuildBeta
Alexis Williams's avatar
Alexis Williams committed
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
  , commandOptions      = \showOrParseArgs ->
        liftOptions get1 set1
        -- Note: [Hidden Flags]
        -- hide "constraint", "dependency", and
        -- "exact-configuration" from the configure options.
        (filter ((`notElem` ["constraint", "dependency"
                            , "exact-configuration"])
                 . optionName) $ configureOptions showOrParseArgs)
     ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
     ++ liftOptions get3 set3
        -- hide "target-package-db" flag from the
        -- install options.
        (filter ((`notElem` ["target-package-db"])
                 . optionName) $
                               installOptions showOrParseArgs)
     ++ liftOptions get4 set4 (haddockOptions showOrParseArgs)
     ++ liftOptions get5 set5 (newInstallOptions showOrParseArgs)
  , commandDefaultFlags = (mempty, mempty, mempty, mempty, defaultNewInstallFlags)
Francesco Gazzetta's avatar
Francesco Gazzetta committed
201
  }
Alexis Williams's avatar
Alexis Williams committed
202
203
204
205
206
207
  where
    get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e)
    get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e)
    get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e)
    get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e)
    get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e)
Francesco Gazzetta's avatar
Francesco Gazzetta committed
208
209
210


-- | The @install@ command actually serves four different needs. It installs:
Alexis Williams's avatar
Alexis Williams committed
211
-- * exes:
Francesco Gazzetta's avatar
Francesco Gazzetta committed
212
213
214
215
216
217
218
--   For example a program from hackage. The behavior is similar to the old
--   install command, except that now conflicts between separate runs of the
--   command are impossible thanks to the store.
--   Exes are installed in the store like a normal dependency, then they are
--   symlinked uin the directory specified by --symlink-bindir.
--   To do this we need a dummy projectBaseContext containing the targets as
--   estra packages and using a temporary dist directory.
Alexis Williams's avatar
Alexis Williams committed
219
220
221
222
-- * libraries
--   Libraries install through a similar process, but using GHC environment
--   files instead of symlinks. This means that 'new-install'ing libraries
--   only works on GHC >= 8.0.
Francesco Gazzetta's avatar
Francesco Gazzetta committed
223
224
225
226
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
Alexis Williams's avatar
Alexis Williams committed
227
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, NewInstallFlags)
Francesco Gazzetta's avatar
Francesco Gazzetta committed
228
            -> [String] -> GlobalFlags -> IO ()
Alexis Williams's avatar
Alexis Williams committed
229
installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstallFlags)
Francesco Gazzetta's avatar
Francesco Gazzetta committed
230
            targetStrings globalFlags = do
231
232
233
234
235
236
237
238
239
240
  -- We never try to build tests/benchmarks for remote packages.
  -- So we set them as disabled by default and error if they are explicitly
  -- enabled.
  when (configTests configFlags' == Flag True) $
    die' verbosity $ "--enable-tests was specified, but tests can't "
                  ++ "be enabled in a remote package"
  when (configBenchmarks configFlags' == Flag True) $
    die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "
                  ++ "be enabled in a remote package"

241
242
243
244
245
246
247
248
  let
    withProject = do
      let verbosity' = lessVerbose verbosity

      -- First, we need to learn about what's available to be installed.
      localBaseCtx <- establishProjectBaseContext verbosity' cliConfig
      let localDistDirLayout = distDirLayout localBaseCtx
      pkgDb <- projectConfigWithBuilderRepoContext verbosity' (buildSettings localBaseCtx) (getSourcePackages verbosity)
249
250
251
252
253
254
255
256
      
      let 
        (targetStrings', packageIds) = partitionEithers . flip fmap targetStrings $ 
          \str -> case simpleParse str of
            Just (pkgId :: PackageId) 
              | pkgVersion pkgId /= nullVersion -> Right pkgId
            _ -> Left str

257
      targetSelectors <- either (reportTargetSelectorProblems verbosity) return
258
                     =<< readTargetSelectors (localPackages localBaseCtx) targetStrings'
259
    
260
      (specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan -> do
261
262
263
        -- Split into known targets and hackage packages.
        (targets, hackageNames) <- case
          resolveTargets
Alexis Williams's avatar
Alexis Williams committed
264
265
266
267
            selectPackageTargets
            selectComponentTarget
            TargetProblemCommon
            elaboratedPlan
268
269
270
271
272
273
274
275
276
277
278
279
280
            (Just pkgDb)
            targetSelectors of
          Right targets -> do
            -- Everything is a local dependency.
            return (targets, [])
          Left errs -> do
            -- Not everything is local.
            let 
              (errs', hackageNames) = partitionEithers . flip fmap errs $ \case
                TargetProblemCommon (TargetAvailableInIndex name) -> Right name
                err -> Left err
            
            when (not . null $ errs') $ reportTargetProblems verbosity errs'
281
    
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
            let 
              targetSelectors' = flip filter targetSelectors $ \case
                TargetComponentUnknown name _ _
                  | name `elem` hackageNames -> False
                TargetPackageNamed name _
                  | name `elem` hackageNames -> False
                _ -> True
            
            -- This can't fail, because all of the errors are removed (or we've given up).
            targets <- either (reportTargetProblems verbosity) return $ resolveTargets
                selectPackageTargets
                selectComponentTarget
                TargetProblemCommon
                elaboratedPlan
                Nothing
                targetSelectors'
        
            return (targets, hackageNames)
        
        let
          planMap = InstallPlan.toMap elaboratedPlan
          targetIds = Map.keys targets
304
    
305
306
307
308
309
          sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = SpecificSourcePackage spkg'
            where
              sdistPath = distSdistFile localDistDirLayout packageInfoId TargzFormat
              spkg' = spkg { packageSource = LocalTarballPackage sdistPath }
          sdistize named = named
310
    
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
          local = sdistize <$> localPackages localBaseCtx
        
          gatherTargets :: UnitId -> TargetSelector
          gatherTargets targetId = TargetPackageNamed pkgName Nothing
            where          
              Just targetUnit = Map.lookup targetId planMap
              PackageIdentifier{..} = packageId targetUnit
    
          targets' = fmap gatherTargets targetIds 
          
          hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
          hackagePkgs = flip NamedPackage [] <$> hackageNames
          hackageTargets :: [TargetSelector]
          hackageTargets = flip TargetPackageNamed Nothing <$> hackageNames
    
Alexis Williams's avatar
Alexis Williams committed
326
327
328
329
330
331
332
333
        createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)

        mapM_ 
          (\(SpecificSourcePackage pkg) -> packageToSdist verbosity 
            (distProjectRootDirectory localDistDirLayout) (Archive TargzFormat)
            (distSdistFile localDistDirLayout (packageId pkg) TargzFormat) pkg
          ) (localPackages localBaseCtx)

334
335
336
        if null targets
          then return (hackagePkgs, hackageTargets)
          else return (local ++ hackagePkgs, targets' ++ hackageTargets)
337

338
339
340
341
342
343
344
345
346
      let
        packageSpecifiers = flip fmap packageIds $ \case
          PackageIdentifier{..}
            | pkgVersion == nullVersion -> NamedPackage pkgName []
            | otherwise -> 
              NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)]
        packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds

      return (specs ++ packageSpecifiers, selectors ++ packageTargets, projectConfig localBaseCtx)
347

348
    withoutProject = do
349
350
351
352
353
      let
        parsePkg pkgName
          | Just (pkg :: PackageId) <- simpleParse pkgName = return pkg
          | otherwise = die' verbosity ("Invalid package ID: " ++ pkgName)
      packageIds <- mapM parsePkg targetStrings
354
      let 
355
356
357
358
359
360
        packageSpecifiers = flip fmap packageIds $ \case
          PackageIdentifier{..}
            | pkgVersion == nullVersion -> NamedPackage pkgName []
            | otherwise -> 
              NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)]
        packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds
361
362
363
        globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
      globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag

364
      return (packageSpecifiers, packageTargets, globalConfig <> cliConfig)
365
366

  (specs, selectors, config) <- catch withProject
367
368
369
370
371
372
373
374
    $ \case
      (BadPackageLocations prov locs) 
        | prov == Set.singleton Implicit
        , let 
          isGlobErr (BadLocGlobEmptyMatch _) = True
          isGlobErr _ = False
        , any isGlobErr locs ->
          withoutProject
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
      err -> throwIO err

  home <- getHomeDirectory
  let
    ProjectConfig {
      projectConfigShared = ProjectConfigShared {
        projectConfigHcFlavor,
        projectConfigHcPath,
        projectConfigHcPkg
      },
      projectConfigLocalPackages = PackageConfig {
        packageConfigProgramPaths,
        packageConfigProgramArgs,
        packageConfigProgramPathExtra
      }
    } = config

    hcFlavor = flagToMaybe projectConfigHcFlavor
    hcPath   = flagToMaybe projectConfigHcPath
    hcPkg    = flagToMaybe projectConfigHcPkg

    progDb =
        userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
      . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))
      . modifyProgramSearchPath
          (++ [ ProgramSearchPathDir dir
              | dir <- fromNubList packageConfigProgramPathExtra ])
      $ defaultProgramDb
Alexis Williams's avatar
Alexis Williams committed
403
    
404
  (compiler@Compiler { compilerId = 
Alexis Williams's avatar
Alexis Williams committed
405
    compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb') <-
406
      configCompilerEx hcFlavor hcPath hcPkg progDb verbosity
407
408

  let 
409
    envFile = flip fromFlagOrDefault (ninstEnvironmentPath newInstallFlags) $
410
411
      home </> ".ghc" </> ghcPlatformAndVersionString platform compilerVersion
           </> "environments" </> "default"
412
    GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler
413
414
415
416
417
    -- Why? We know what the first part will be, we only care about the packages.
    filterEnvEntries = filter $ \case
      GhcEnvFilePackageId _ -> True
      _ -> False

418
  envFileExists <- doesFileExist envFile
419
  envEntries <- filterEnvEntries <$> if
Alexis Williams's avatar
Alexis Williams committed
420
    (compilerFlavor == GHC || compilerFlavor == GHCJS)
421
      && supportsPkgEnvFiles && envFileExists
422
    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->
423
424
      warn verbosity ("The environment file " ++ envFile ++
        " is unparsable. Libraries cannot be installed.") >> return []
Alexis Williams's avatar
Alexis Williams committed
425
    else return []
426

427
428
429
430
431
432
433
  cabalDir <- getCabalDir
  let
    mstoreDir   = flagToMaybe (globalStoreDir globalFlags)
    mlogsDir    = flagToMaybe (globalLogsDir globalFlags)
    cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir
    packageDbs  = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId

Alexis Williams's avatar
Alexis Williams committed
434
  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb'
435

436
  let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries
Alexis Williams's avatar
Alexis Williams committed
437

438
439
440
  -- Second, we need to use a fake project to let Cabal build the
  -- installables correctly. For that, we need a place to put a
  -- temporary dist directory.
Francesco Gazzetta's avatar
Francesco Gazzetta committed
441
442
443
444
445
446
447
448
  globalTmp <- getTemporaryDirectory
  withTempDirectory
    verbosity
    globalTmp
    "cabal-install."
    $ \tmpDir -> do
    baseCtx <- establishDummyProjectBaseContext
                 verbosity
449
                 config
Francesco Gazzetta's avatar
Francesco Gazzetta committed
450
                 tmpDir
451
                 (envSpecs ++ specs)
452
    
Francesco Gazzetta's avatar
Francesco Gazzetta committed
453
    buildCtx <-
Alexis Williams's avatar
Alexis Williams committed
454
      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Francesco Gazzetta's avatar
Francesco Gazzetta committed
455
456
457
458
459
460
461
462

            -- Interpret the targets on the command line as build targets
            targets <- either (reportTargetProblems verbosity) return
                     $ resolveTargets
                         selectPackageTargets
                         selectComponentTarget
                         TargetProblemCommon
                         elaboratedPlan
463
                         Nothing
464
                         selectors
Francesco Gazzetta's avatar
Francesco Gazzetta committed
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482

            let elaboratedPlan' = pruneInstallPlanToTargets
                                    TargetActionBuild
                                    targets
                                    elaboratedPlan
            elaboratedPlan'' <-
              if buildSettingOnlyDeps (buildSettings baseCtx)
                then either (reportCannotPruneDependencies verbosity) return $
                     pruneInstallPlanToDependencies (Map.keysSet targets)
                                                    elaboratedPlan'
                else return elaboratedPlan'

            return (elaboratedPlan'', targets)

    printPlan verbosity baseCtx buildCtx

    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx

Alexis Williams's avatar
Alexis Williams committed
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
    let 
      mkPkgBinDir = (</> "bin") .
                    storePackageDirectory
                       (cabalStoreDirLayout $ cabalDirLayout baseCtx)
                       compilerId
      installLibs = fromFlagOrDefault False (ninstInstallLibs newInstallFlags)

    when (not installLibs) $ do
      -- If there are exes, symlink them
      let symlinkBindirUnknown =
            "symlink-bindir is not defined. Set it in your cabal config file "
            ++ "or use --symlink-bindir=<path>"
      symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown)
                    $ fmap makeAbsolute
                    $ projectConfigSymlinkBinDir
                    $ projectConfigBuildOnly
                    $ projectConfig $ baseCtx
      createDirectoryIfMissingVerbose verbosity False symlinkBindir
      traverse_ (symlinkBuiltPackage verbosity mkPkgBinDir symlinkBindir)
            $ Map.toList $ targetsMap buildCtx
Francesco Gazzetta's avatar
Francesco Gazzetta committed
503
    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
504

Alexis Williams's avatar
Alexis Williams committed
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
    when installLibs $
      if supportsPkgEnvFiles
        then do
          -- Why do we get it again? If we updated a globalPackage then we need
          -- the new version.
          installedIndex' <- getInstalledPackages verbosity compiler packageDbs progDb'
          let
            getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst)) 
                      . lookupPackageName installedIndex'
            globalLatest = concat (getLatest <$> globalPackages)

            baseEntries =
              GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs
            globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest
            pkgEntries = ordNub $
                  globalEntries
              ++ envEntries'
              ++ entriesForLibraryComponents (targetsMap buildCtx)
            contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)
          createDirectoryIfMissing True (takeDirectory envFile)
          writeFileAtomic envFile (BS.pack contents')
        else
          warn verbosity $
              "The current compiler doesn't support safely installing libraries, "
            ++ "so only executables will be available. (Library installation is "
            ++ "supported on GHC 8.0+ only)"
Francesco Gazzetta's avatar
Francesco Gazzetta committed
531
  where
532
533
    configFlags' = disableTestsBenchsByDefault configFlags
    verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
Francesco Gazzetta's avatar
Francesco Gazzetta committed
534
    cliConfig = commandLineFlagsToProjectConfig
535
                  globalFlags configFlags' configExFlags
Francesco Gazzetta's avatar
Francesco Gazzetta committed
536
537
                  installFlags haddockFlags

538
539
540
541
542
543
544
545
546
globalPackages :: [PackageName]
globalPackages = mkPackageName <$>
  [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath"
  , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary"
  , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq"
  , "ghc-boot-th", "pretty", "template-haskell", "directory", "text"
  , "bin-package-db"
  ]

547
environmentFileToSpecifiers :: InstalledPackageIndex -> [GhcEnvironmentFileEntry] 
548
                            -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
549
550
environmentFileToSpecifiers ipi = foldMap $ \case
    (GhcEnvFilePackageId unitId) 
551
552
553
554
555
556
557
558
        | Just InstalledPackageInfo{ sourcePackageId = PackageIdentifier{..}, installedUnitId }
          <- lookupUnitId ipi unitId
        , let pkgSpec = NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)]
        -> if pkgName `elem` globalPackages
          then ([pkgSpec], [])
          else ([pkgSpec], [GhcEnvFilePackageId installedUnitId])
    _ -> ([], [])

Francesco Gazzetta's avatar
Francesco Gazzetta committed
559

560
561
562
563
564
565
-- | Disables tests and benchmarks if they weren't explicitly enabled.
disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault configFlags =
  configFlags { configTests = Flag False <> configTests configFlags
              , configBenchmarks = Flag False <> configBenchmarks configFlags }

Francesco Gazzetta's avatar
Francesco Gazzetta committed
566
-- | Symlink every exe from a package from the store to a given location
567
568
symlinkBuiltPackage :: Verbosity
                    -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
Francesco Gazzetta's avatar
Francesco Gazzetta committed
569
570
571
                                            -- store directory
                    -> FilePath -- ^ Where to put the symlink
                    -> ( UnitId
572
                        , [(ComponentTarget, [TargetSelector])] )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
573
                     -> IO ()
574
575
symlinkBuiltPackage verbosity mkSourceBinDir destDir (pkg, components) =
  traverse_ (symlinkBuiltExe verbosity (mkSourceBinDir pkg) destDir) exes
Francesco Gazzetta's avatar
Francesco Gazzetta committed
576
577
578
579
580
581
  where
    exes = catMaybes $ (exeMaybe . fst) <$> components
    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
    exeMaybe _ = Nothing

-- | Symlink a specific exe.
582
583
584
symlinkBuiltExe :: Verbosity -> FilePath -> FilePath -> UnqualComponentName -> IO Bool
symlinkBuiltExe verbosity sourceDir destDir exe = do
  notice verbosity $ "Symlinking " ++ unUnqualComponentName exe
Francesco Gazzetta's avatar
Francesco Gazzetta committed
585
586
587
588
589
590
  symlinkBinary
    destDir
    sourceDir
    exe
    $ unUnqualComponentName exe

591
592
593
594
595
596
597
598
599
600
601
602
603
604
-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []
  where
    hasLib :: (ComponentTarget, [TargetSelector]) -> Bool
    hasLib (ComponentTarget CLibName _,        _) = True
    hasLib (ComponentTarget (CSubLibName _) _, _) = True
    hasLib _                                      = False
    
    go :: UnitId -> [(ComponentTarget, [TargetSelector])] -> [GhcEnvironmentFileEntry]
    go unitId targets
      | any hasLib targets = [GhcEnvFilePackageId unitId]
      | otherwise          = []

Francesco Gazzetta's avatar
Francesco Gazzetta committed
605
606
-- | Create a dummy project context, without a .cabal or a .cabal.project file
-- (a place where to put a temporary dist directory is still needed)
607
608
609
610
611
612
613
614
establishDummyProjectBaseContext
  :: Verbosity
  -> ProjectConfig
  -> FilePath
     -- ^ Where to put the dist directory
  -> [PackageSpecifier UnresolvedSourcePackage]
     -- ^ The packages to be included in the project
  -> IO ProjectBaseContext
Francesco Gazzetta's avatar
Francesco Gazzetta committed
615
616
establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do

617
    cabalDir <- getCabalDir
Francesco Gazzetta's avatar
Francesco Gazzetta committed
618
619
620

    -- Create the dist directories
    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
621
622
    createDirectoryIfMissingVerbose verbosity True $
      distProjectCacheDirectory distDirLayout
Francesco Gazzetta's avatar
Francesco Gazzetta committed
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661

    globalConfig <- runRebuild ""
                  $ readGlobalConfig verbosity
                  $ projectConfigConfigFile
                  $ projectConfigShared cliConfig
    let projectConfig = globalConfig <> cliConfig

    let ProjectConfigBuildOnly {
          projectConfigLogsDir,
          projectConfigStoreDir
        } = projectConfigBuildOnly projectConfig

        mlogsDir = flagToMaybe projectConfigLogsDir
        mstoreDir = flagToMaybe projectConfigStoreDir
        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir

        buildSettings = resolveBuildTimeSettings
                          verbosity cabalDirLayout
                          projectConfig

    return ProjectBaseContext {
      distDirLayout,
      cabalDirLayout,
      projectConfig,
      localPackages,
      buildSettings
    }
  where
    mdistDirectory = flagToMaybe
                   $ projectConfigDistDir
                   $ projectConfigShared cliConfig
    projectRoot = ProjectRootImplicit tmpDir
    distDirLayout = defaultDistDirLayout projectRoot
                                         mdistDirectory

-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
662
663
664
-- For the @build@ command select all components except non-buildable
-- and disabled tests\/benchmarks, fail if there are no such
-- components
Francesco Gazzetta's avatar
Francesco Gazzetta committed
665
--
666
selectPackageTargets :: TargetSelector
Francesco Gazzetta's avatar
Francesco Gazzetta committed
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
                     -> [AvailableTarget k] -> Either TargetProblem [k]
selectPackageTargets targetSelector targets

    -- If there are any buildable targets then we select those
  | not (null targetsBuildable)
  = Right targetsBuildable

    -- If there are targets but none are buildable then we report those
  | not (null targets)
  = Left (TargetProblemNoneEnabled targetSelector targets')

    -- If there are no targets at all then we report that
  | otherwise
  = Left (TargetProblemNoTargets targetSelector)
  where
    targets'         = forgetTargetsDetail targets
    targetsBuildable = selectBuildableTargetsWith
                         (buildable targetSelector)
                         targets

    -- When there's a target filter like "pkg:tests" then we do select tests,
    -- but if it's just a target like "pkg" then we don't build tests unless
    -- they are requested by default (i.e. by using --enable-tests)
    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False
    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False
    buildable _ _ = True

-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @build@ command we just need the basic checks on being buildable etc.
--
699
selectComponentTarget :: SubComponentTarget
Francesco Gazzetta's avatar
Francesco Gazzetta committed
700
                      -> AvailableTarget k -> Either TargetProblem k
701
selectComponentTarget subtarget =
Francesco Gazzetta's avatar
Francesco Gazzetta committed
702
    either (Left . TargetProblemCommon) Right
703
  . selectComponentTargetBasic subtarget
Francesco Gazzetta's avatar
Francesco Gazzetta committed
704
705
706
707
708
709
710
711
712


-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @build@ command.
--
data TargetProblem =
     TargetProblemCommon       TargetProblemCommon

     -- | The 'TargetSelector' matches targets but none are buildable
713
   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
Francesco Gazzetta's avatar
Francesco Gazzetta committed
714
715

     -- | There are no targets at all
716
   | TargetProblemNoTargets   TargetSelector
Francesco Gazzetta's avatar
Francesco Gazzetta committed
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
  deriving (Eq, Show)

reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
reportTargetProblems verbosity =
    die' verbosity . unlines . map renderTargetProblem

renderTargetProblem :: TargetProblem -> String
renderTargetProblem (TargetProblemCommon problem) =
    renderTargetProblemCommon "build" problem
renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
    renderTargetProblemNoneEnabled "build" targetSelector targets
renderTargetProblem(TargetProblemNoTargets targetSelector) =
    renderTargetProblemNoTargets "build" targetSelector

reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies verbosity =
    die' verbosity . renderCannotPruneDependencies