CmdInstall.hs 30.3 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
Alexis Williams's avatar
Alexis Williams committed
127
         , getTemporaryDirectory, makeAbsolute, getCurrentDirectory )
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
  , ninstEnvironmentCwd :: Flag Bool
Alexis Williams's avatar
Alexis Williams committed
135
136
137
138
139
  }

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

Alexis Williams's avatar
Alexis Williams committed
144
145
146
147
148
149
newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags]
newInstallOptions _ = 
  [ option [] ["lib"]
    "Install libraries rather than executables from the target package."
    ninstInstallLibs (\v flags -> flags { ninstInstallLibs = v })
    trueArg
150
151
152
153
  , 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
154
155
156
157
  , option [] ["env-cwd"]
    "Modify the current directory's environment instead of the global one."
    ninstEnvironmentCwd (\pf flags -> flags { ninstEnvironmentCwd = pf })
    trueArg
Alexis Williams's avatar
Alexis Williams committed
158
159
160
161
162
  ]

installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
                            , HaddockFlags, NewInstallFlags
                            )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
163
164
165
installCommand = CommandUI
  { commandName         = "new-install"
  , commandSynopsis     = "Install packages."
166
167
  , commandUsage        = usageAlternatives
                          "new-install" [ "[TARGETS] [FLAGS]" ]
Francesco Gazzetta's avatar
Francesco Gazzetta committed
168
  , commandDescription  = Just $ \_ -> wrapText $
169
170
171
172
173
174
175
176
177
    "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
178
  , commandNotes        = Just $ \pname ->
179
      "Examples:\n"
Francesco Gazzetta's avatar
Francesco Gazzetta committed
180
181
182
      ++ "  " ++ pname ++ " new-install\n"
      ++ "    Install the package in the current directory\n"
      ++ "  " ++ pname ++ " new-install pkgname\n"
183
184
      ++ "    Install the package named pkgname"
      ++ " (fetching it from hackage if necessary)\n"
Francesco Gazzetta's avatar
Francesco Gazzetta committed
185
186
187
188
      ++ "  " ++ pname ++ " new-install ./pkgfoo\n"
      ++ "    Install the package in the ./pkgfoo directory\n"

      ++ cmdCommonHelpTextNewBuildBeta
Alexis Williams's avatar
Alexis Williams committed
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
  , 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
207
  }
Alexis Williams's avatar
Alexis Williams committed
208
209
210
211
212
213
  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
214
215
216


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

247
248
249
250
251
252
253
254
  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)
255
256
257
258
259
260
261
262
      
      let 
        (targetStrings', packageIds) = partitionEithers . flip fmap targetStrings $ 
          \str -> case simpleParse str of
            Just (pkgId :: PackageId) 
              | pkgVersion pkgId /= nullVersion -> Right pkgId
            _ -> Left str

263
      targetSelectors <- either (reportTargetSelectorProblems verbosity) return
264
                     =<< readTargetSelectors (localPackages localBaseCtx) targetStrings'
265
    
266
      (specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan -> do
267
268
269
        -- Split into known targets and hackage packages.
        (targets, hackageNames) <- case
          resolveTargets
Alexis Williams's avatar
Alexis Williams committed
270
271
272
273
            selectPackageTargets
            selectComponentTarget
            TargetProblemCommon
            elaboratedPlan
274
275
276
277
278
279
280
281
282
283
284
285
286
            (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'
287
    
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
            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
310
    
311
312
313
314
315
          sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = SpecificSourcePackage spkg'
            where
              sdistPath = distSdistFile localDistDirLayout packageInfoId TargzFormat
              spkg' = spkg { packageSource = LocalTarballPackage sdistPath }
          sdistize named = named
316
    
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
          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
332
333
334
335
336
337
338
339
        createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)

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

340
341
342
        if null targets
          then return (hackagePkgs, hackageTargets)
          else return (local ++ hackagePkgs, targets' ++ hackageTargets)
343

344
345
346
347
348
349
350
351
352
      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)
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

Alexis Williams's avatar
Alexis Williams committed
414
415
  cwd <- getCurrentDirectory

416
  let 
Alexis Williams's avatar
Alexis Williams committed
417
    defaultEnv =
418
419
      home </> ".ghc" </> ghcPlatformAndVersionString platform compilerVersion
           </> "environments" </> "default"
Alexis Williams's avatar
Alexis Williams committed
420
421
422
423
424
425
    cwdEnv =
      cwd </> ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion
    
    envFile = if fromFlagOrDefault False (ninstEnvironmentCwd newInstallFlags)
      then cwdEnv
      else fromFlagOrDefault defaultEnv (ninstEnvironmentPath newInstallFlags)
426
    GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler
427
428
429
430
431
    -- Why? We know what the first part will be, we only care about the packages.
    filterEnvEntries = filter $ \case
      GhcEnvFilePackageId _ -> True
      _ -> False

432
  envFileExists <- doesFileExist envFile
433
  envEntries <- filterEnvEntries <$> if
Alexis Williams's avatar
Alexis Williams committed
434
    (compilerFlavor == GHC || compilerFlavor == GHCJS)
435
      && supportsPkgEnvFiles && envFileExists
436
    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->
437
438
      warn verbosity ("The environment file " ++ envFile ++
        " is unparsable. Libraries cannot be installed.") >> return []
Alexis Williams's avatar
Alexis Williams committed
439
    else return []
440

441
442
443
444
445
446
447
  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
448
  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb'
449

450
  let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries
Alexis Williams's avatar
Alexis Williams committed
451

452
453
454
  -- 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
455
456
457
458
459
460
461
462
  globalTmp <- getTemporaryDirectory
  withTempDirectory
    verbosity
    globalTmp
    "cabal-install."
    $ \tmpDir -> do
    baseCtx <- establishDummyProjectBaseContext
                 verbosity
463
                 config
Francesco Gazzetta's avatar
Francesco Gazzetta committed
464
                 tmpDir
465
                 (envSpecs ++ specs)
466
    
Francesco Gazzetta's avatar
Francesco Gazzetta committed
467
    buildCtx <-
Alexis Williams's avatar
Alexis Williams committed
468
      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Francesco Gazzetta's avatar
Francesco Gazzetta committed
469
470
471
472
473
474
475
476

            -- Interpret the targets on the command line as build targets
            targets <- either (reportTargetProblems verbosity) return
                     $ resolveTargets
                         selectPackageTargets
                         selectComponentTarget
                         TargetProblemCommon
                         elaboratedPlan
477
                         Nothing
478
                         selectors
Francesco Gazzetta's avatar
Francesco Gazzetta committed
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496

            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
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
    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
517
    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
518

Alexis Williams's avatar
Alexis Williams committed
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
    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
545
  where
546
547
    configFlags' = disableTestsBenchsByDefault configFlags
    verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
Francesco Gazzetta's avatar
Francesco Gazzetta committed
548
    cliConfig = commandLineFlagsToProjectConfig
549
                  globalFlags configFlags' configExFlags
Francesco Gazzetta's avatar
Francesco Gazzetta committed
550
551
                  installFlags haddockFlags

552
553
554
555
556
557
558
559
560
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"
  ]

561
environmentFileToSpecifiers :: InstalledPackageIndex -> [GhcEnvironmentFileEntry] 
562
                            -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
563
564
environmentFileToSpecifiers ipi = foldMap $ \case
    (GhcEnvFilePackageId unitId) 
565
566
567
568
569
570
571
572
        | 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
573

574
575
576
577
578
579
-- | 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
580
-- | Symlink every exe from a package from the store to a given location
581
582
symlinkBuiltPackage :: Verbosity
                    -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
Francesco Gazzetta's avatar
Francesco Gazzetta committed
583
584
585
                                            -- store directory
                    -> FilePath -- ^ Where to put the symlink
                    -> ( UnitId
586
                        , [(ComponentTarget, [TargetSelector])] )
Francesco Gazzetta's avatar
Francesco Gazzetta committed
587
                     -> IO ()
588
589
symlinkBuiltPackage verbosity mkSourceBinDir destDir (pkg, components) =
  traverse_ (symlinkBuiltExe verbosity (mkSourceBinDir pkg) destDir) exes
Francesco Gazzetta's avatar
Francesco Gazzetta committed
590
591
592
593
594
595
  where
    exes = catMaybes $ (exeMaybe . fst) <$> components
    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
    exeMaybe _ = Nothing

-- | Symlink a specific exe.
596
597
598
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
599
600
601
602
603
604
  symlinkBinary
    destDir
    sourceDir
    exe
    $ unUnqualComponentName exe

605
606
607
608
609
610
611
612
613
614
615
616
617
618
-- | 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
619
620
-- | 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)
621
622
623
624
625
626
627
628
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
629
630
establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do

631
    cabalDir <- getCabalDir
Francesco Gazzetta's avatar
Francesco Gazzetta committed
632
633
634

    -- Create the dist directories
    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
635
636
    createDirectoryIfMissingVerbose verbosity True $
      distProjectCacheDirectory distDirLayout
Francesco Gazzetta's avatar
Francesco Gazzetta committed
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
662
663
664
665
666
667
668
669
670
671
672
673
674
675

    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.
--
676
677
678
-- 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
679
--
680
selectPackageTargets :: TargetSelector
Francesco Gazzetta's avatar
Francesco Gazzetta committed
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
                     -> [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.
--
713
selectComponentTarget :: SubComponentTarget
Francesco Gazzetta's avatar
Francesco Gazzetta committed
714
                      -> AvailableTarget k -> Either TargetProblem k
715
selectComponentTarget subtarget =
Francesco Gazzetta's avatar
Francesco Gazzetta committed
716
    either (Left . TargetProblemCommon) Right
717
  . selectComponentTargetBasic subtarget
Francesco Gazzetta's avatar
Francesco Gazzetta committed
718
719
720
721
722
723
724
725
726


-- | 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
727
   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
Francesco Gazzetta's avatar
Francesco Gazzetta committed
728
729

     -- | There are no targets at all
730
   | TargetProblemNoTargets   TargetSelector
Francesco Gazzetta's avatar
Francesco Gazzetta committed
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
  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