1{-# LANGUAGE CPP #-}
2-----------------------------------------------------------------------------
3-- |
4-- Module      :  Distribution.Client.Configure
5-- Copyright   :  (c) David Himmelstrup 2005,
6--                    Duncan Coutts 2005
7-- License     :  BSD-like
8--
9-- Maintainer  :  cabal-devel@haskell.org
10-- Portability :  portable
11--
12-- High level interface to configuring a package.
13-----------------------------------------------------------------------------
14module Distribution.Client.Configure (
15    configure,
16    configureSetupScript,
17    chooseCabalVersion,
18    checkConfigExFlags,
19    -- * Saved configure flags
20    readConfigFlagsFrom, readConfigFlags,
21    cabalConfigFlagsFile,
22    writeConfigFlagsTo, writeConfigFlags,
23  ) where
24
25import Prelude ()
26import Distribution.Client.Compat.Prelude
27import Distribution.Utils.Generic (safeHead)
28
29import Distribution.Client.Dependency
30import qualified Distribution.Client.InstallPlan as InstallPlan
31import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
32import Distribution.Client.IndexUtils as IndexUtils
33         ( getSourcePackages, getInstalledPackages )
34import Distribution.Client.Setup
35         ( ConfigExFlags(..), RepoContext(..)
36         , configureCommand, configureExCommand, filterConfigureFlags )
37import Distribution.Client.Types as Source
38import Distribution.Client.SetupWrapper
39         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
40import Distribution.Client.Targets
41         ( userToPackageConstraint, userConstraintPackageName )
42import Distribution.Client.JobControl (Lock)
43
44import qualified Distribution.Solver.Types.ComponentDeps as CD
45import           Distribution.Solver.Types.Settings
46import           Distribution.Solver.Types.ConstraintSource
47import           Distribution.Solver.Types.LabeledPackageConstraint
48import           Distribution.Solver.Types.OptionalStanza
49import           Distribution.Solver.Types.PackageIndex
50                   ( PackageIndex, elemByPackageName )
51import           Distribution.Solver.Types.PkgConfigDb
52                   (PkgConfigDb, readPkgConfigDb)
53import           Distribution.Solver.Types.SourcePackage
54
55import Distribution.Simple.Compiler
56         ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )
57import Distribution.Simple.Program (ProgramDb)
58import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags )
59import Distribution.Simple.Setup
60         ( ConfigFlags(..)
61         , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )
62import Distribution.Simple.PackageIndex
63         ( InstalledPackageIndex, lookupPackageName )
64import Distribution.Package
65         ( Package(..), packageName, PackageId )
66import Distribution.Types.Dependency
67         ( thisPackageVersion )
68import Distribution.Types.GivenComponent
69         ( GivenComponent(..) )
70import Distribution.Types.PackageVersionConstraint
71         ( PackageVersionConstraint(..) )
72import qualified Distribution.PackageDescription as PkgDesc
73import Distribution.PackageDescription.Parsec
74         ( readGenericPackageDescription )
75import Distribution.PackageDescription.Configuration
76         ( finalizePD )
77import Distribution.Version
78         ( Version, mkVersion, anyVersion, thisVersion
79         , VersionRange, orLaterVersion )
80import Distribution.Simple.Utils as Utils
81         ( warn, notice, debug, die'
82         , defaultPackageDesc )
83import Distribution.System
84         ( Platform )
85import Distribution.Deprecated.Text ( display )
86import Distribution.Verbosity as Verbosity
87         ( Verbosity )
88
89import Data.Foldable
90         ( forM_ )
91import System.FilePath ( (</>) )
92
93-- | Choose the Cabal version such that the setup scripts compiled against this
94-- version will support the given command-line flags.
95chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange
96chooseCabalVersion configExFlags maybeVersion =
97  maybe defaultVersionRange thisVersion maybeVersion
98  where
99    -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed
100    -- for '--allow-newer' to work.
101    allowNewer = isRelaxDeps
102                 (maybe mempty unAllowNewer $ configAllowNewer configExFlags)
103    allowOlder = isRelaxDeps
104                 (maybe mempty unAllowOlder $ configAllowOlder configExFlags)
105
106    defaultVersionRange = if allowOlder || allowNewer
107                          then orLaterVersion (mkVersion [1,19,2])
108                          else anyVersion
109
110-- | Configure the package found in the local directory
111configure :: Verbosity
112          -> PackageDBStack
113          -> RepoContext
114          -> Compiler
115          -> Platform
116          -> ProgramDb
117          -> ConfigFlags
118          -> ConfigExFlags
119          -> [String]
120          -> IO ()
121configure verbosity packageDBs repoCtxt comp platform progdb
122  configFlags configExFlags extraArgs = do
123
124  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
125  sourcePkgDb       <- getSourcePackages    verbosity repoCtxt
126  pkgConfigDb       <- readPkgConfigDb      verbosity progdb
127
128  checkConfigExFlags verbosity installedPkgIndex
129                     (packageIndex sourcePkgDb) configExFlags
130
131  progress <- planLocalPackage verbosity comp platform configFlags configExFlags
132                               installedPkgIndex sourcePkgDb pkgConfigDb
133
134  notice verbosity "Resolving dependencies..."
135  maybePlan <- foldProgress logMsg (return . Left) (return . Right)
136                            progress
137  case maybePlan of
138    Left message -> do
139      warn verbosity $
140           "solver failed to find a solution:\n"
141        ++ message
142        ++ "\nTrying configure anyway."
143      setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)
144        Nothing configureCommand (const configFlags) (const extraArgs)
145
146    Right installPlan0 ->
147     let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0
148     in case fst (InstallPlan.ready installPlan) of
149      [pkg@(ReadyPackage
150              (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _)
151                                 _ _ _))] -> do
152        configurePackage verbosity
153          platform (compilerInfo comp)
154          (setupScriptOptions installedPkgIndex (Just pkg))
155          configFlags pkg extraArgs
156
157      _ -> die' verbosity $ "internal error: configure install plan should have exactly "
158              ++ "one local ready package."
159
160  where
161    setupScriptOptions :: InstalledPackageIndex
162                       -> Maybe ReadyPackage
163                       -> SetupScriptOptions
164    setupScriptOptions =
165      configureSetupScript
166        packageDBs
167        comp
168        platform
169        progdb
170        (fromFlagOrDefault
171           (useDistPref defaultSetupScriptOptions)
172           (configDistPref configFlags))
173        (chooseCabalVersion
174           configExFlags
175           (flagToMaybe (configCabalVersion configExFlags)))
176        Nothing
177        False
178
179    logMsg message rest = debug verbosity message >> rest
180
181configureSetupScript :: PackageDBStack
182                     -> Compiler
183                     -> Platform
184                     -> ProgramDb
185                     -> FilePath
186                     -> VersionRange
187                     -> Maybe Lock
188                     -> Bool
189                     -> InstalledPackageIndex
190                     -> Maybe ReadyPackage
191                     -> SetupScriptOptions
192configureSetupScript packageDBs
193                     comp
194                     platform
195                     progdb
196                     distPref
197                     cabalVersion
198                     lock
199                     forceExternal
200                     index
201                     mpkg
202  = SetupScriptOptions {
203      useCabalVersion          = cabalVersion
204    , useCabalSpecVersion      = Nothing
205    , useCompiler              = Just comp
206    , usePlatform              = Just platform
207    , usePackageDB             = packageDBs'
208    , usePackageIndex          = index'
209    , useProgramDb             = progdb
210    , useDistPref              = distPref
211    , useLoggingHandle         = Nothing
212    , useWorkingDir            = Nothing
213    , useExtraPathEnv          = []
214    , useExtraEnvOverrides     = []
215    , setupCacheLock           = lock
216    , useWin32CleanHack        = False
217    , forceExternalSetupMethod = forceExternal
218      -- If we have explicit setup dependencies, list them; otherwise, we give
219      -- the empty list of dependencies; ideally, we would fix the version of
220      -- Cabal here, so that we no longer need the special case for that in
221      -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet
222      -- know the version of Cabal at this point, but only find this there.
223      -- Therefore, for now, we just leave this blank.
224    , useDependencies          = fromMaybe [] explicitSetupDeps
225    , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps
226    , useVersionMacros         = not defaultSetupDeps && isJust explicitSetupDeps
227    , isInteractive            = False
228    }
229  where
230    -- When we are compiling a legacy setup script without an explicit
231    -- setup stanza, we typically want to allow the UserPackageDB for
232    -- finding the Cabal lib when compiling any Setup.hs even if we're doing
233    -- a global install. However we also allow looking in a specific package
234    -- db.
235    packageDBs' :: PackageDBStack
236    index'      :: Maybe InstalledPackageIndex
237    (packageDBs', index') =
238      case packageDBs of
239        (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs
240                              , Nothing <- explicitSetupDeps
241            -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)
242        -- but if the user is using an odd db stack, don't touch it
243        _otherwise -> (packageDBs, Just index)
244
245    maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo
246    maybeSetupBuildInfo = do
247      ReadyPackage cpkg <- mpkg
248      let gpkg = packageDescription (confPkgSource cpkg)
249      PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)
250
251    -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If
252    -- so, 'setup-depends' must not be exclusive. See #3199.
253    defaultSetupDeps :: Bool
254    defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends
255                       maybeSetupBuildInfo
256
257    explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]
258    explicitSetupDeps = do
259      -- Check if there is an explicit setup stanza.
260      _buildInfo <- maybeSetupBuildInfo
261      -- Return the setup dependencies computed by the solver
262      ReadyPackage cpkg <- mpkg
263      return [ ( cid, srcid )
264             | ConfiguredId srcid
265               (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid
266                 <- CD.setupDeps (confPkgDeps cpkg)
267             ]
268
269-- | Warn if any constraints or preferences name packages that are not in the
270-- source package index or installed package index.
271checkConfigExFlags :: Package pkg
272                   => Verbosity
273                   -> InstalledPackageIndex
274                   -> PackageIndex pkg
275                   -> ConfigExFlags
276                   -> IO ()
277checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do
278  forM_ (safeHead unknownConstraints) $ \h ->
279    warn verbosity $ "Constraint refers to an unknown package: "
280          ++ showConstraint h
281  forM_ (safeHead unknownPreferences) $ \h ->
282    warn verbosity $ "Preference refers to an unknown package: "
283          ++ display h
284  where
285    unknownConstraints = filter (unknown . userConstraintPackageName . fst) $
286                         configExConstraints flags
287    unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $
288                         configPreferences flags
289    unknown pkg = null (lookupPackageName installedPkgIndex pkg)
290               && not (elemByPackageName sourcePkgIndex pkg)
291    showConstraint (uc, src) =
292        display uc ++ " (" ++ showConstraintSource src ++ ")"
293
294-- | Make an 'InstallPlan' for the unpacked package in the current directory,
295-- and all its dependencies.
296--
297planLocalPackage :: Verbosity -> Compiler
298                 -> Platform
299                 -> ConfigFlags -> ConfigExFlags
300                 -> InstalledPackageIndex
301                 -> SourcePackageDb
302                 -> PkgConfigDb
303                 -> IO (Progress String String SolverInstallPlan)
304planLocalPackage verbosity comp platform configFlags configExFlags
305  installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do
306  pkg <- readGenericPackageDescription verbosity =<<
307            case flagToMaybe (configCabalFilePath configFlags) of
308                Nothing -> defaultPackageDesc verbosity
309                Just fp -> return fp
310  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)
311            (compilerInfo comp)
312
313  let -- We create a local package and ask to resolve a dependency on it
314      localPkg = SourcePackage {
315        packageInfoId             = packageId pkg,
316        packageDescription        = pkg,
317        packageSource             = LocalUnpackedPackage ".",
318        packageDescrOverride      = Nothing
319      }
320
321      testsEnabled = fromFlagOrDefault False $ configTests configFlags
322      benchmarksEnabled =
323        fromFlagOrDefault False $ configBenchmarks configFlags
324
325      resolverParams =
326          removeLowerBounds
327          (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags)
328        . removeUpperBounds
329          (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags)
330
331        . addPreferences
332            -- preferences from the config file or command line
333            [ PackageVersionPreference name ver
334            | PackageVersionConstraint name ver <- configPreferences configExFlags ]
335
336        . addConstraints
337            -- version constraints from the config file or command line
338            -- TODO: should warn or error on constraints that are not on direct
339            -- deps or flag constraints not on the package in question.
340            [ LabeledPackageConstraint (userToPackageConstraint uc) src
341            | (uc, src) <- configExConstraints configExFlags ]
342
343        . addConstraints
344            -- package flags from the config file or command line
345            [ let pc = PackageConstraint
346                       (scopeToplevel $ packageName pkg)
347                       (PackagePropertyFlags $ configConfigurationsFlags configFlags)
348              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
349            ]
350
351        . addConstraints
352            -- '--enable-tests' and '--enable-benchmarks' constraints from
353            -- the config file or command line
354            [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) .
355                       PackagePropertyStanzas $
356                       [ TestStanzas  | testsEnabled ] ++
357                       [ BenchStanzas | benchmarksEnabled ]
358              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
359            ]
360
361            -- Don't solve for executables, since we use an empty source
362            -- package database and executables never show up in the
363            -- installed package index
364        . setSolveExecutables (SolveExecutables False)
365
366        . setSolverVerbosity verbosity
367
368        $ standardInstallPolicy
369            installedPkgIndex
370            -- NB: We pass in an *empty* source package database,
371            -- because cabal configure assumes that all dependencies
372            -- have already been installed
373            (SourcePackageDb mempty packagePrefs)
374            [SpecificSourcePackage localPkg]
375
376  return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams)
377
378
379-- | Call an installer for an 'SourcePackage' but override the configure
380-- flags with the ones given by the 'ReadyPackage'. In particular the
381-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly
382-- versioned package dependencies. So we ignore any previous partial flag
383-- assignment or dependency constraints and use the new ones.
384--
385-- NB: when updating this function, don't forget to also update
386-- 'installReadyPackage' in D.C.Install.
387configurePackage :: Verbosity
388                 -> Platform -> CompilerInfo
389                 -> SetupScriptOptions
390                 -> ConfigFlags
391                 -> ReadyPackage
392                 -> [String]
393                 -> IO ()
394configurePackage verbosity platform comp scriptOptions configFlags
395                 (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps))
396                 extraArgs =
397
398  setupWrapper verbosity
399    scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs)
400
401  where
402    gpkg = packageDescription spkg
403    configureFlags   = filterConfigureFlags configFlags {
404      configIPID = if isJust (flagToMaybe (configIPID configFlags))
405                    -- Make sure cabal configure --ipid works.
406                    then configIPID configFlags
407                    else toFlag (display ipid),
408      configConfigurationsFlags = flags,
409      -- We generate the legacy constraints as well as the new style precise
410      -- deps.  In the end only one set gets passed to Setup.hs configure,
411      -- depending on the Cabal version we are talking to.
412      configConstraints  = [ thisPackageVersion srcid
413                           | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid
414                               <- CD.nonSetupDeps deps ],
415      configDependencies = [ GivenComponent (packageName srcid) cname uid
416                           | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid
417                               <- CD.nonSetupDeps deps ],
418      -- Use '--exact-configuration' if supported.
419      configExactConfiguration = toFlag True,
420      configVerbosity          = toFlag verbosity,
421      -- NB: if the user explicitly specified
422      -- --enable-tests/--enable-benchmarks, always respect it.
423      -- (But if they didn't, let solver decide.)
424      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas)
425                                    `mappend` configBenchmarks configFlags,
426      configTests              = toFlag (TestStanzas `elem` stanzas)
427                                    `mappend` configTests configFlags
428    }
429
430    pkg = case finalizePD flags (enableStanzas stanzas)
431           (const True)
432           platform comp [] gpkg of
433      Left _ -> error "finalizePD ReadyPackage failed"
434      Right (desc, _) -> desc
435
436-- -----------------------------------------------------------------------------
437-- * Saved configure environments and flags
438-- -----------------------------------------------------------------------------
439
440-- | Read saved configure flags and restore the saved environment from the
441-- specified files.
442readConfigFlagsFrom :: FilePath  -- ^ path to saved flags file
443                    -> IO (ConfigFlags, ConfigExFlags)
444readConfigFlagsFrom flags = do
445  readCommandFlags flags configureExCommand
446
447-- | The path (relative to @--build-dir@) where the arguments to @configure@
448-- should be saved.
449cabalConfigFlagsFile :: FilePath -> FilePath
450cabalConfigFlagsFile dist = dist </> "cabal-config-flags"
451
452-- | Read saved configure flags and restore the saved environment from the
453-- usual location.
454readConfigFlags :: FilePath  -- ^ @--build-dir@
455                -> IO (ConfigFlags, ConfigExFlags)
456readConfigFlags dist =
457  readConfigFlagsFrom (cabalConfigFlagsFile dist)
458
459-- | Save the configure flags and environment to the specified files.
460writeConfigFlagsTo :: FilePath  -- ^ path to saved flags file
461                   -> Verbosity -> (ConfigFlags, ConfigExFlags)
462                   -> IO ()
463writeConfigFlagsTo file verb flags = do
464  writeCommandFlags verb file configureExCommand flags
465
466-- | Save the build flags to the usual location.
467writeConfigFlags :: Verbosity
468                 -> FilePath  -- ^ @--build-dir@
469                 -> (ConfigFlags, ConfigExFlags) -> IO ()
470writeConfigFlags verb dist =
471  writeConfigFlagsTo (cabalConfigFlagsFile dist) verb
472