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