CmdInstall.hs 31.1 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
import Distribution.Utils.NubList
         ( fromNubList )
import System.Directory 
         ( getHomeDirectory, doesFileExist, createDirectoryIfMissing
127
         , getTemporaryDirectory, makeAbsolute, doesDirectoryExist )
128
import System.FilePath
129
         ( (</>), takeDirectory, takeBaseName )
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
  , option [] ["package-env", "env"]
149
150
    "Set the environment file that may be modified."
    ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf })
151
    (reqArg "ENV" (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
  , 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)
Alexis Williams's avatar
Alexis Williams committed
198
199
200
201
202
203
       ++ liftOptions get4 set4
          -- hide "target-package-db" flag from the
          -- install options.
          (filter ((`notElem` ["v", "verbose"])
                  . optionName) $
                                haddockOptions showOrParseArgs)
Alexis Williams's avatar
Alexis Williams committed
204
205
     ++ liftOptions get5 set5 (newInstallOptions showOrParseArgs)
  , commandDefaultFlags = (mempty, mempty, mempty, mempty, defaultNewInstallFlags)
Francesco Gazzetta's avatar
Francesco Gazzetta committed
206
  }
Alexis Williams's avatar
Alexis Williams committed
207
208
209
210
211
212
  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
213
214
215


-- | The @install@ command actually serves four different needs. It installs:
Alexis Williams's avatar
Alexis Williams committed
216
-- * exes:
Francesco Gazzetta's avatar
Francesco Gazzetta committed
217
218
219
220
221
222
223
--   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
224
225
226
227
-- * 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
228
229
230
231
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
Alexis Williams's avatar
Alexis Williams committed
232
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, NewInstallFlags)
Francesco Gazzetta's avatar
Francesco Gazzetta committed
233
            -> [String] -> GlobalFlags -> IO ()
Alexis Williams's avatar
Alexis Williams committed
234
installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstallFlags)
Francesco Gazzetta's avatar
Francesco Gazzetta committed
235
            targetStrings globalFlags = do
236
237
238
239
240
241
242
243
244
245
  -- 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"

246
247
248
249
250
251
252
253
  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)
254
255
256
257
258
259
260
      
      let 
        (targetStrings', packageIds) = partitionEithers . flip fmap targetStrings $ 
          \str -> case simpleParse str of
            Just (pkgId :: PackageId) 
              | pkgVersion pkgId /= nullVersion -> Right pkgId
            _ -> Left str
Alexis Williams's avatar
Alexis Williams committed
261
262
263
264
265
266
267
        packageSpecifiers = flip fmap packageIds $ \case
          PackageIdentifier{..}
            | pkgVersion == nullVersion -> NamedPackage pkgName []
            | otherwise -> 
              NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)]
        packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds
      
268
      if null targetStrings'
Alexis Williams's avatar
Alexis Williams committed
269
        then return (packageSpecifiers, packageTargets, projectConfig localBaseCtx)
270
271
272
273
274
275
276
277
        else do
          targetSelectors <- either (reportTargetSelectorProblems verbosity) return
                        =<< readTargetSelectors (localPackages localBaseCtx) targetStrings'
        
          (specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan -> do
            -- Split into known targets and hackage packages.
            (targets, hackageNames) <- case
              resolveTargets
278
279
280
281
                selectPackageTargets
                selectComponentTarget
                TargetProblemCommon
                elaboratedPlan
282
283
284
285
286
287
288
289
290
291
292
293
294
                (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'
295
        
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
                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
318
        
319
320
321
322
323
              sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = SpecificSourcePackage spkg'
                where
                  sdistPath = distSdistFile localDistDirLayout packageInfoId TargzFormat
                  spkg' = spkg { packageSource = LocalTarballPackage sdistPath }
              sdistize named = named
324
        
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
              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
        
            createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)
Alexis Williams's avatar
Alexis Williams committed
341

342
343
344
345
346
            mapM_ 
              (\(SpecificSourcePackage pkg) -> packageToSdist verbosity 
                (distProjectRootDirectory localDistDirLayout) (Archive TargzFormat)
                (distSdistFile localDistDirLayout (packageId pkg) TargzFormat) pkg
              ) (localPackages localBaseCtx)
Alexis Williams's avatar
Alexis Williams committed
347

348
349
350
            if null targets
              then return (hackagePkgs, hackageTargets)
              else return (local ++ hackagePkgs, targets' ++ hackageTargets)
351

352
          return (specs ++ packageSpecifiers, selectors ++ packageTargets, projectConfig localBaseCtx)
353

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

370
      return (packageSpecifiers, packageTargets, globalConfig <> cliConfig)
371
372

  (specs, selectors, config) <- catch withProject
373
374
375
376
377
378
379
380
    $ \case
      (BadPackageLocations prov locs) 
        | prov == Set.singleton Implicit
        , let 
          isGlobErr (BadLocGlobEmptyMatch _) = True
          isGlobErr _ = False
        , any isGlobErr locs ->
          withoutProject
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
      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
409
    
410
  (compiler@Compiler { compilerId = 
Alexis Williams's avatar
Alexis Williams committed
411
    compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb') <-
412
      configCompilerEx hcFlavor hcPath hcPkg progDb verbosity
413
414

  let 
415
    globalEnv name =
416
      home </> ".ghc" </> ghcPlatformAndVersionString platform compilerVersion
417
418
419
420
           </> "environments" </> name
    localEnv dir =
      dir </> ".ghc.environment." ++ ghcPlatformAndVersionString platform compilerVersion

421
    GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler
422
423
424
425
    -- Why? We know what the first part will be, we only care about the packages.
    filterEnvEntries = filter $ \case
      GhcEnvFilePackageId _ -> True
      _ -> False
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
  
  envFile <- case flagToMaybe (ninstEnvironmentPath newInstallFlags) of
    Just spec
      -- Is spec a bare word without any "pathy" content, then it refers to
      -- a named global environment.
      | takeBaseName spec == spec -> return (globalEnv spec)
      | otherwise -> do
        spec' <- makeAbsolute spec
        isDir <- doesDirectoryExist spec'
        if isDir
          -- If spec is a directory, then make an ambient environment inside
          -- that directory.
          then return (localEnv spec')
          -- Otherwise, treat it like a literal file path.
          else return spec'
    Nothing -> return (globalEnv "default")
442

443
  envFileExists <- doesFileExist envFile
444
  envEntries <- filterEnvEntries <$> if
Alexis Williams's avatar
Alexis Williams committed
445
    (compilerFlavor == GHC || compilerFlavor == GHCJS)
446
      && supportsPkgEnvFiles && envFileExists
447
    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->
448
449
      warn verbosity ("The environment file " ++ envFile ++
        " is unparsable. Libraries cannot be installed.") >> return []
Alexis Williams's avatar
Alexis Williams committed
450
    else return []
451

452
453
454
455
456
457
458
  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
459
  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb'
460

461
  let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries
Alexis Williams's avatar
Alexis Williams committed
462

463
464
465
  -- 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
466
467
468
469
470
471
472
473
  globalTmp <- getTemporaryDirectory
  withTempDirectory
    verbosity
    globalTmp
    "cabal-install."
    $ \tmpDir -> do
    baseCtx <- establishDummyProjectBaseContext
                 verbosity
474
                 config
Francesco Gazzetta's avatar
Francesco Gazzetta committed
475
                 tmpDir
476
                 (envSpecs ++ specs)
477
    
Francesco Gazzetta's avatar
Francesco Gazzetta committed
478
    buildCtx <-
Alexis Williams's avatar
Alexis Williams committed
479
      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Francesco Gazzetta's avatar
Francesco Gazzetta committed
480
481
482
483
484
485
486
487

            -- Interpret the targets on the command line as build targets
            targets <- either (reportTargetProblems verbosity) return
                     $ resolveTargets
                         selectPackageTargets
                         selectComponentTarget
                         TargetProblemCommon
                         elaboratedPlan
488
                         Nothing
489
                         selectors
Francesco Gazzetta's avatar
Francesco Gazzetta committed
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507

            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
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
    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
528
    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
529

Alexis Williams's avatar
Alexis Williams committed
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
    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
556
  where
557
558
    configFlags' = disableTestsBenchsByDefault configFlags
    verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
Francesco Gazzetta's avatar
Francesco Gazzetta committed
559
    cliConfig = commandLineFlagsToProjectConfig
560
                  globalFlags configFlags' configExFlags
Francesco Gazzetta's avatar
Francesco Gazzetta committed
561
562
                  installFlags haddockFlags

563
564
565
566
567
568
569
570
571
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"
  ]

572
environmentFileToSpecifiers :: InstalledPackageIndex -> [GhcEnvironmentFileEntry] 
573
                            -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
574
575
environmentFileToSpecifiers ipi = foldMap $ \case
    (GhcEnvFilePackageId unitId) 
576
577
578
579
580
581
582
583
        | 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
584

585
586
587
588
589
590
-- | 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
591
-- | Symlink every exe from a package from the store to a given location
592
593
symlinkBuiltPackage :: Verbosity
                    -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
Francesco Gazzetta's avatar
Francesco Gazzetta committed
594
595
596
                                            -- store directory
                    -> FilePath -- ^ Where to put the symlink
                    -> ( UnitId
597
                        , [(ComponentTarget, [TargetSelector])] )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
598
                     -> IO ()
599
600
symlinkBuiltPackage verbosity mkSourceBinDir destDir (pkg, components) =
  traverse_ (symlinkBuiltExe verbosity (mkSourceBinDir pkg) destDir) exes
Francesco Gazzetta's avatar
Francesco Gazzetta committed
601
602
603
604
605
606
  where
    exes = catMaybes $ (exeMaybe . fst) <$> components
    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
    exeMaybe _ = Nothing

-- | Symlink a specific exe.
607
608
609
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
610
611
612
613
614
615
  symlinkBinary
    destDir
    sourceDir
    exe
    $ unUnqualComponentName exe

616
617
618
619
620
621
622
623
624
625
626
627
628
629
-- | 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
630
631
-- | 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)
632
633
634
635
636
637
638
639
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
640
641
establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do

642
    cabalDir <- getCabalDir
Francesco Gazzetta's avatar
Francesco Gazzetta committed
643
644
645

    -- Create the dist directories
    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
646
647
    createDirectoryIfMissingVerbose verbosity True $
      distProjectCacheDirectory distDirLayout
Francesco Gazzetta's avatar
Francesco Gazzetta committed
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686

    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.
--
687
688
689
-- 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
690
--
691
selectPackageTargets :: TargetSelector
Francesco Gazzetta's avatar
Francesco Gazzetta committed
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
                     -> [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.
--
724
selectComponentTarget :: SubComponentTarget
Francesco Gazzetta's avatar
Francesco Gazzetta committed
725
                      -> AvailableTarget k -> Either TargetProblem k
726
selectComponentTarget subtarget =
Francesco Gazzetta's avatar
Francesco Gazzetta committed
727
    either (Left . TargetProblemCommon) Right
728
  . selectComponentTargetBasic subtarget
Francesco Gazzetta's avatar
Francesco Gazzetta committed
729
730
731
732
733
734
735
736
737


-- | 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
738
   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
Francesco Gazzetta's avatar
Francesco Gazzetta committed
739
740

     -- | There are no targets at all
741
   | TargetProblemNoTargets   TargetSelector
Francesco Gazzetta's avatar
Francesco Gazzetta committed
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
  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