Configure.hs 15.2 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2 3 4 5 6 7 8 9 10 11 12 13 14 15
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Configure
-- Copyright   :  (c) David Himmelstrup 2005,
--                    Duncan Coutts 2005
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- High level interface to configuring a package.
-----------------------------------------------------------------------------
module Distribution.Client.Configure (
    configure,
16
    configureSetupScript,
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
17
    chooseCabalVersion,
18
    checkConfigExFlags
19 20 21
  ) where

import Distribution.Client.Dependency
22
import Distribution.Client.Dependency.Types
23
         ( AllowNewer(..), isAllowNewer, ConstraintSource(..)
24
         , LabeledPackageConstraint(..), showConstraintSource )
25 26 27
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
28
         ( getSourcePackages, getInstalledPackages )
29
import Distribution.Client.PackageIndex ( PackageIndex, elemByPackageName )
30
import Distribution.Client.Setup
Edsko de Vries's avatar
Edsko de Vries committed
31 32
         ( ConfigExFlags(..), configureCommand, filterConfigureFlags
         , RepoContext(..) )
33
import Distribution.Client.Types as Source
34 35
import Distribution.Client.SetupWrapper
         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
36
import Distribution.Client.Targets
37
         ( userToPackageConstraint, userConstraintPackageName )
38
import qualified Distribution.Client.ComponentDeps as CD
39 40
import Distribution.Package (PackageId)
import Distribution.Client.JobControl (Lock)
41 42

import Distribution.Simple.Compiler
43
         ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )
44
import Distribution.Simple.Program (ProgramConfiguration )
45
import Distribution.Simple.Setup
46
         ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )
47 48
import Distribution.Simple.PackageIndex
         ( InstalledPackageIndex, lookupPackageName )
49 50
import Distribution.Simple.Utils
         ( defaultPackageDesc )
51
import qualified Distribution.InstalledPackageInfo as Installed
52
import Distribution.Package
53
         ( Package(..), UnitId, packageName
54 55 56
         , Dependency(..), thisPackageVersion
         )
import qualified Distribution.PackageDescription as PkgDesc
57 58 59 60 61
import Distribution.PackageDescription.Parse
         ( readPackageDescription )
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription )
import Distribution.Version
62
         ( anyVersion, thisVersion )
63
import Distribution.Simple.Utils as Utils
64
         ( warn, notice, info, debug, die )
65
import Distribution.System
66
         ( Platform )
67
import Distribution.Text ( display )
68 69
import Distribution.Verbosity as Verbosity
         ( Verbosity )
70
import Distribution.Version
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
71
         ( Version(..), VersionRange, orLaterVersion )
72

73
import Control.Monad (unless)
74
#if !MIN_VERSION_base(4,8,0)
75
import Data.Monoid (Monoid(..))
76
#endif
77
import Data.Maybe (isJust, fromMaybe)
78

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
79 80 81 82 83 84
-- | Choose the Cabal version such that the setup scripts compiled against this
-- version will support the given command-line flags.
chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange
chooseCabalVersion configExFlags maybeVersion =
  maybe defaultVersionRange thisVersion maybeVersion
  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
85 86
    -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed
    -- for '--allow-newer' to work.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
87 88 89 90 91 92 93
    allowNewer = fromFlagOrDefault False $
                 fmap isAllowNewer (configAllowNewer configExFlags)

    defaultVersionRange = if allowNewer
                          then orLaterVersion (Version [1,19,2] [])
                          else anyVersion

94 95
-- | Configure the package found in the local directory
configure :: Verbosity
96
          -> PackageDBStack
Edsko de Vries's avatar
Edsko de Vries committed
97
          -> RepoContext
98
          -> Compiler
99
          -> Platform
100
          -> ProgramConfiguration
101
          -> ConfigFlags
102
          -> ConfigExFlags
103 104
          -> [String]
          -> IO ()
Edsko de Vries's avatar
Edsko de Vries committed
105
configure verbosity packageDBs repoCtxt comp platform conf
106 107
  configFlags configExFlags extraArgs = do

108
  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
Edsko de Vries's avatar
Edsko de Vries committed
109
  sourcePkgDb       <- getSourcePackages    verbosity repoCtxt
110 111
  checkConfigExFlags verbosity installedPkgIndex
                     (packageIndex sourcePkgDb) configExFlags
112

113
  progress <- planLocalPackage verbosity comp platform configFlags configExFlags
114
                               installedPkgIndex sourcePkgDb
115 116

  notice verbosity "Resolving dependencies..."
117 118
  maybePlan <- foldProgress logMsg (return . Left) (return . Right)
                            progress
119
  case maybePlan of
120
    Left message -> do
121 122 123 124
      info verbosity $
           "Warning: solver failed to find a solution:\n"
        ++ message
        ++ "Trying configure anyway."
125 126
      setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)
        Nothing configureCommand (const configFlags) extraArgs
127 128

    Right installPlan -> case InstallPlan.ready installPlan of
129 130 131 132
      [pkg@(ReadyPackage
             (ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _)
                                 _ _ _)
             _)] -> do
133
        configurePackage verbosity
134
          platform (compilerInfo comp)
135
          (setupScriptOptions installedPkgIndex (Just pkg))
136 137 138 139 140 141
          configFlags pkg extraArgs

      _ -> die $ "internal error: configure install plan should have exactly "
              ++ "one local ready package."

  where
142
    setupScriptOptions :: InstalledPackageIndex
143
                       -> Maybe ReadyPackage
144
                       -> SetupScriptOptions
145 146 147 148 149 150 151 152 153 154 155 156 157 158
    setupScriptOptions =
      configureSetupScript
        packageDBs
        comp
        platform
        conf
        (fromFlagOrDefault
           (useDistPref defaultSetupScriptOptions)
           (configDistPref configFlags))
        (chooseCabalVersion
           configExFlags
           (flagToMaybe (configCabalVersion configExFlags)))
        Nothing
        False
159

160 161
    logMsg message rest = debug verbosity message >> rest

162 163 164 165 166 167 168 169 170
configureSetupScript :: PackageDBStack
                     -> Compiler
                     -> Platform
                     -> ProgramConfiguration
                     -> FilePath
                     -> VersionRange
                     -> Maybe Lock
                     -> Bool
                     -> InstalledPackageIndex
171
                     -> Maybe ReadyPackage
172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
                     -> SetupScriptOptions
configureSetupScript packageDBs
                     comp
                     platform
                     conf
                     distPref
                     cabalVersion
                     lock
                     forceExternal
                     index
                     mpkg
  = SetupScriptOptions {
      useCabalVersion   = cabalVersion
    , useCompiler       = Just comp
    , usePlatform       = Just platform
    , usePackageDB      = packageDBs'
    , usePackageIndex   = index'
    , useProgramConfig  = conf
    , useDistPref       = distPref
    , useLoggingHandle  = Nothing
    , useWorkingDir     = Nothing
    , setupCacheLock    = lock
    , useWin32CleanHack = False
    , forceExternalSetupMethod = forceExternal
      -- If we have explicit setup dependencies, list them; otherwise, we give
      -- the empty list of dependencies; ideally, we would fix the version of
      -- Cabal here, so that we no longer need the special case for that in
      -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet
      -- know the version of Cabal at this point, but only find this there.
      -- Therefore, for now, we just leave this blank.
    , useDependencies          = fromMaybe [] explicitSetupDeps
    , useDependenciesExclusive = isJust explicitSetupDeps
204
    , useVersionMacros         = isJust explicitSetupDeps
205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221
    }
  where
    -- When we are compiling a legacy setup script without an explicit
    -- setup stanza, we typically want to allow the UserPackageDB for
    -- finding the Cabal lib when compiling any Setup.hs even if we're doing
    -- a global install. However we also allow looking in a specific package
    -- db.
    packageDBs' :: PackageDBStack
    index'      :: Maybe InstalledPackageIndex
    (packageDBs', index') =
      case packageDBs of
        (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs
                              , Nothing <- explicitSetupDeps
            -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)
        -- but if the user is using an odd db stack, don't touch it
        _otherwise -> (packageDBs, Just index)

222
    explicitSetupDeps :: Maybe [(UnitId, PackageId)]
223
    explicitSetupDeps = do
224 225
      ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _) _ _ _) deps
                 <- mpkg
226 227 228
      -- Check if there is an explicit setup stanza
      _buildInfo <- PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)
      -- Return the setup dependencies computed by the solver
229
      return [ ( Installed.installedUnitId deppkg
230 231 232 233 234
               , Installed.sourcePackageId    deppkg
               )
             | deppkg <- CD.setupDeps deps
             ]

235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259
-- | Warn if any constraints or preferences name packages that are not in the
-- source package index or installed package index.
checkConfigExFlags :: Package pkg
                   => Verbosity
                   -> InstalledPackageIndex
                   -> PackageIndex pkg
                   -> ConfigExFlags
                   -> IO ()
checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do
  unless (null unknownConstraints) $ warn verbosity $
             "Constraint refers to an unknown package: "
          ++ showConstraint (head unknownConstraints)
  unless (null unknownPreferences) $ warn verbosity $
             "Preference refers to an unknown package: "
          ++ display (head unknownPreferences)
  where
    unknownConstraints = filter (unknown . userConstraintPackageName . fst) $
                         configExConstraints flags
    unknownPreferences = filter (unknown . \(Dependency name _) -> name) $
                         configPreferences flags
    unknown pkg = null (lookupPackageName installedPkgIndex pkg)
               && not (elemByPackageName sourcePkgIndex pkg)
    showConstraint (uc, src) =
        display uc ++ " (" ++ showConstraintSource src ++ ")"

260 261 262 263
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler
264
                 -> Platform
265
                 -> ConfigFlags -> ConfigExFlags
266
                 -> InstalledPackageIndex
267
                 -> SourcePackageDb
268
                 -> IO (Progress String String InstallPlan)
269 270
planLocalPackage verbosity comp platform configFlags configExFlags
  installedPkgIndex
271
  (SourcePackageDb _ packagePrefs) = do
272
  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
273 274
  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)
            (compilerInfo comp)
275 276

  let -- We create a local package and ask to resolve a dependency on it
277 278 279
      localPkg = SourcePackage {
        packageInfoId             = packageId pkg,
        Source.packageDescription = pkg,
280 281
        packageSource             = LocalUnpackedPackage ".",
        packageDescrOverride      = Nothing
282
      }
283

284 285 286 287
      testsEnabled = fromFlagOrDefault False $ configTests configFlags
      benchmarksEnabled =
        fromFlagOrDefault False $ configBenchmarks configFlags

288
      resolverParams =
289 290
          removeUpperBounds (fromFlagOrDefault AllowNewerNone $
                             configAllowNewer configExFlags)
291

292
        . addPreferences
293 294 295 296 297 298
            -- preferences from the config file or command line
            [ PackageVersionPreference name ver
            | Dependency name ver <- configPreferences configExFlags ]

        . addConstraints
            -- version constraints from the config file or command line
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
299 300
            -- TODO: should warn or error on constraints that are not on direct
            -- deps or flag constraints not on the package in question.
301
            [ LabeledPackageConstraint (userToPackageConstraint uc) src
302
            | (uc, src) <- configExConstraints configExFlags ]
303 304 305

        . addConstraints
            -- package flags from the config file or command line
306 307
            [ let pc = PackageConstraintFlags (packageName pkg)
                       (configConfigurationsFlags configFlags)
308 309
              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
            ]
310

311 312
        . addConstraints
            -- '--enable-tests' and '--enable-benchmarks' constraints from
313
            -- the config file or command line
314 315 316
            [ let pc = PackageConstraintStanzas (packageName pkg) $
                       [ TestStanzas  | testsEnabled ] ++
                       [ BenchStanzas | benchmarksEnabled ]
317
              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
318 319
            ]

320
        $ standardInstallPolicy
321 322
            installedPkgIndex
            (SourcePackageDb mempty packagePrefs)
323
            [SpecificSourcePackage localPkg]
324

325
  return (resolveDependencies platform (compilerInfo comp) solver resolverParams)
326

327

328
-- | Call an installer for an 'SourcePackage' but override the configure
329 330
-- flags with the ones given by the 'ReadyPackage'. In particular the
-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly
331 332 333
-- versioned package dependencies. So we ignore any previous partial flag
-- assignment or dependency constraints and use the new ones.
--
334 335
-- NB: when updating this function, don't forget to also update
-- 'installReadyPackage' in D.C.Install.
336
configurePackage :: Verbosity
337
                 -> Platform -> CompilerInfo
338
                 -> SetupScriptOptions
339
                 -> ConfigFlags
340
                 -> ReadyPackage
341 342
                 -> [String]
                 -> IO ()
343
configurePackage verbosity platform comp scriptOptions configFlags
344 345 346 347
                 (ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _)
                                                  flags stanzas _)
                               deps)
                 extraArgs =
348 349 350 351 352 353

  setupWrapper verbosity
    scriptOptions (Just pkg) configureCommand configureFlags extraArgs

  where
    configureFlags   = filterConfigureFlags configFlags {
354
      configConfigurationsFlags = flags,
355 356 357 358
      -- We generate the legacy constraints as well as the new style precise
      -- deps.  In the end only one set gets passed to Setup.hs configure,
      -- depending on the Cabal version we are talking to.
      configConstraints  = [ thisPackageVersion (packageId deppkg)
359
                           | deppkg <- CD.nonSetupDeps deps ],
360
      configDependencies = [ (packageName (Installed.sourcePackageId deppkg),
361
                              Installed.installedUnitId deppkg)
362
                           | deppkg <- CD.nonSetupDeps deps ],
363 364
      -- Use '--exact-configuration' if supported.
      configExactConfiguration = toFlag True,
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
365 366 367
      configVerbosity          = toFlag verbosity,
      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas),
      configTests              = toFlag (TestStanzas `elem` stanzas)
368 369 370
    }

    pkg = case finalizePackageDescription flags
371
           (const True)
372
           platform comp [] (enableStanzas stanzas gpkg) of
373
      Left _ -> error "finalizePackageDescription ReadyPackage failed"
374
      Right (desc, _) -> desc