Configure.hs 10.5 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,
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
16
    chooseCabalVersion,
17 18 19
  ) where

import Distribution.Client.Dependency
20
import Distribution.Client.Dependency.Types (AllowNewer(..), isAllowNewer)
21 22 23
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
24
         ( getSourcePackages, getInstalledPackages )
25
import Distribution.Client.Setup
26
         ( ConfigExFlags(..), configureCommand, filterConfigureFlags )
27
import Distribution.Client.Types as Source
28 29
import Distribution.Client.SetupWrapper
         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
30 31
import Distribution.Client.Targets
         ( userToPackageConstraint )
32
import qualified Distribution.Client.ComponentDeps as CD
33 34

import Distribution.Simple.Compiler
35
         ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )
36
import Distribution.Simple.Program (ProgramConfiguration )
37
import Distribution.Simple.Setup
38
         ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )
39
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
40 41
import Distribution.Simple.Utils
         ( defaultPackageDesc )
42
import qualified Distribution.InstalledPackageInfo as Installed
43
import Distribution.Package
44
         ( Package(..), packageName, Dependency(..), thisPackageVersion )
45 46 47 48 49
import Distribution.PackageDescription.Parse
         ( readPackageDescription )
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription )
import Distribution.Version
50
         ( anyVersion, thisVersion )
51
import Distribution.Simple.Utils as Utils
52
         ( notice, info, debug, die )
53
import Distribution.System
54
         ( Platform )
55 56
import Distribution.Verbosity as Verbosity
         ( Verbosity )
57
import Distribution.Version
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
58
         ( Version(..), VersionRange, orLaterVersion )
59

60
#if !MIN_VERSION_base(4,8,0)
61
import Data.Monoid (Monoid(..))
62
#endif
63

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
64 65 66 67 68 69
-- | 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
70 71
    -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed
    -- for '--allow-newer' to work.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
72 73 74 75 76 77 78
    allowNewer = fromFlagOrDefault False $
                 fmap isAllowNewer (configAllowNewer configExFlags)

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

79 80
-- | Configure the package found in the local directory
configure :: Verbosity
81
          -> PackageDBStack
82 83
          -> [Repo]
          -> Compiler
84
          -> Platform
85
          -> ProgramConfiguration
86
          -> ConfigFlags
87
          -> ConfigExFlags
88 89
          -> [String]
          -> IO ()
90
configure verbosity packageDBs repos comp platform conf
91 92
  configFlags configExFlags extraArgs = do

93 94
  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
  sourcePkgDb       <- getSourcePackages    verbosity repos
95

96
  progress <- planLocalPackage verbosity comp platform configFlags configExFlags
97
                               installedPkgIndex sourcePkgDb
98 99

  notice verbosity "Resolving dependencies..."
100 101
  maybePlan <- foldProgress logMsg (return . Left) (return . Right)
                            progress
102
  case maybePlan of
103 104 105 106
    Left message -> do
      info verbosity message
      setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing
        configureCommand (const configFlags) extraArgs
107 108

    Right installPlan -> case InstallPlan.ready installPlan of
109
      [pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->
110 111 112
        configurePackage verbosity
          (InstallPlan.planPlatform installPlan)
          (InstallPlan.planCompiler installPlan)
113
          (setupScriptOptions installedPkgIndex)
114 115 116 117 118 119 120
          configFlags pkg extraArgs

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

  where
    setupScriptOptions index = SetupScriptOptions {
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
121
      useCabalVersion  = chooseCabalVersion configExFlags
122
                         (flagToMaybe (configCabalVersion configExFlags)),
123
      useCompiler      = Just comp,
124
      usePlatform      = Just platform,
Duncan Coutts's avatar
Duncan Coutts committed
125 126
      usePackageDB     = packageDBs',
      usePackageIndex  = index',
127
      useProgramConfig = conf,
128
      useDistPref      = fromFlagOrDefault
129
                           (useDistPref defaultSetupScriptOptions)
130
                           (configDistPref configFlags),
131
      useLoggingHandle = Nothing,
132
      useWorkingDir    = Nothing,
133
      useWin32CleanHack        = False,
refold's avatar
refold committed
134
      forceExternalSetupMethod = False,
refold's avatar
refold committed
135
      setupCacheLock   = Nothing
136
    }
Duncan Coutts's avatar
Duncan Coutts committed
137 138 139 140 141 142 143 144 145 146
      where
        -- Hack: 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', index') =
          case packageDBs of
            (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs
                -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)
            -- but if the user is using an odd db stack, don't touch it
            dbs -> (dbs, Just index)
147

148 149
    logMsg message rest = debug verbosity message >> rest

150 151 152 153
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler
154
                 -> Platform
155
                 -> ConfigFlags -> ConfigExFlags
156
                 -> InstalledPackageIndex
157
                 -> SourcePackageDb
158
                 -> IO (Progress String String InstallPlan)
159
planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex
160
  (SourcePackageDb _ packagePrefs) = do
161
  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
162
  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerInfo comp)
163 164

  let -- We create a local package and ask to resolve a dependency on it
165 166 167
      localPkg = SourcePackage {
        packageInfoId             = packageId pkg,
        Source.packageDescription = pkg,
168 169
        packageSource             = LocalUnpackedPackage ".",
        packageDescrOverride      = Nothing
170
      }
171

172 173 174 175
      testsEnabled = fromFlagOrDefault False $ configTests configFlags
      benchmarksEnabled =
        fromFlagOrDefault False $ configBenchmarks configFlags

176
      resolverParams =
177 178
          removeUpperBounds (fromFlagOrDefault AllowNewerNone $
                             configAllowNewer configExFlags)
179

180
        . addPreferences
181 182 183 184 185 186
            -- 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
187 188
            -- TODO: should warn or error on constraints that are not on direct
            -- deps or flag constraints not on the package in question.
189
            (map userToPackageConstraint (configExConstraints configExFlags))
190 191 192

        . addConstraints
            -- package flags from the config file or command line
193
            [ PackageConstraintFlags (packageName pkg)
194 195
                                     (configConfigurationsFlags configFlags) ]

196 197 198
        . addConstraints
            -- '--enable-tests' and '--enable-benchmarks' constraints from
            -- command line
EyalLotem's avatar
EyalLotem committed
199 200 201
            [ PackageConstraintStanzas (packageName pkg) $
                [ TestStanzas  | testsEnabled ] ++
                [ BenchStanzas | benchmarksEnabled ]
202 203
            ]

204
        $ standardInstallPolicy
205 206
            installedPkgIndex
            (SourcePackageDb mempty packagePrefs)
207
            [SpecificSourcePackage localPkg]
208

209
  return (resolveDependencies platform (compilerInfo comp) solver resolverParams)
210

211

212
-- | Call an installer for an 'SourcePackage' but override the configure
213 214
-- flags with the ones given by the 'ReadyPackage'. In particular the
-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly
215 216 217
-- versioned package dependencies. So we ignore any previous partial flag
-- assignment or dependency constraints and use the new ones.
--
218 219
-- NB: when updating this function, don't forget to also update
-- 'installReadyPackage' in D.C.Install.
220
configurePackage :: Verbosity
221
                 -> Platform -> CompilerInfo
222
                 -> SetupScriptOptions
223
                 -> ConfigFlags
224
                 -> ReadyPackage
225 226
                 -> [String]
                 -> IO ()
227
configurePackage verbosity platform comp scriptOptions configFlags
228
  (ReadyPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =
229 230 231 232 233 234

  setupWrapper verbosity
    scriptOptions (Just pkg) configureCommand configureFlags extraArgs

  where
    configureFlags   = filterConfigureFlags configFlags {
235
      configConfigurationsFlags = flags,
236 237 238 239
      -- 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)
240
                           | deppkg <- CD.nonSetupDeps deps ],
241 242
      configDependencies = [ (packageName (Installed.sourcePackageId deppkg),
                              Installed.installedPackageId deppkg)
243
                           | deppkg <- CD.nonSetupDeps deps ],
244 245
      -- Use '--exact-configuration' if supported.
      configExactConfiguration = toFlag True,
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
246 247 248
      configVerbosity          = toFlag verbosity,
      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas),
      configTests              = toFlag (TestStanzas `elem` stanzas)
249 250 251
    }

    pkg = case finalizePackageDescription flags
252
           (const True)
253
           platform comp [] (enableStanzas stanzas gpkg) of
254
      Left _ -> error "finalizePackageDescription ReadyPackage failed"
255
      Right (desc, _) -> desc