Configure.hs 8.59 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
-----------------------------------------------------------------------------
-- |
-- 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,
  ) where

import Data.Monoid
         ( Monoid(mempty) )
import qualified Data.Map as Map

import Distribution.Client.Dependency
         ( resolveDependenciesWithProgress
         , PackageConstraint(..)
         , PackagesPreference(..), PackagesPreferenceDefault(..)
         , PackagePreference(..)
         , Progress(..), foldProgress, )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
30
         ( getAvailablePackages, getInstalledPackages )
31
import Distribution.Client.Setup
32
         ( ConfigExFlags(..), configureCommand, filterConfigureFlags )
33 34
import Distribution.Client.Types as Available
         ( AvailablePackage(..), AvailablePackageSource(..), Repo(..)
35
         , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage )
36 37 38 39
import Distribution.Client.SetupWrapper
         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )

import Distribution.Simple.Compiler
40 41
         ( CompilerId(..), Compiler(compilerId)
         , PackageDB(..), PackageDBStack )
42
import Distribution.Simple.Program (ProgramConfiguration )
43 44
import Distribution.Simple.Setup
         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
45 46
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
47 48 49 50 51 52 53 54 55 56
import Distribution.Simple.Utils
         ( defaultPackageDesc )
import Distribution.Package
         ( PackageName, packageName, packageVersion
         , Package(..), Dependency(..), thisPackageVersion )
import Distribution.PackageDescription.Parse
         ( readPackageDescription )
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription )
import Distribution.Version
Duncan Coutts's avatar
Duncan Coutts committed
57
         ( VersionRange, anyVersion, thisVersion )
58 59 60
import Distribution.Simple.Utils as Utils
         ( notice, info, die )
import Distribution.System
61
         ( Platform, buildPlatform )
62 63 64 65 66
import Distribution.Verbosity as Verbosity
         ( Verbosity )

-- | Configure the package found in the local directory
configure :: Verbosity
67
          -> PackageDBStack
68 69 70
          -> [Repo]
          -> Compiler
          -> ProgramConfiguration
71
          -> ConfigFlags
72
          -> ConfigExFlags
73 74
          -> [String]
          -> IO ()
75
configure verbosity packageDBs repos comp conf
76 77
  configFlags configExFlags extraArgs = do

78
  installed <- getInstalledPackages verbosity comp packageDBs conf
79 80
  available <- getAvailablePackages verbosity repos

81
  progress <- planLocalPackage verbosity comp configFlags configExFlags
82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
                               installed available

  notice verbosity "Resolving dependencies..."
  maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)
                            (return . Left) (return . Right) progress
  case maybePlan of
    Left message -> do
      info verbosity message
      setupWrapper verbosity (setupScriptOptions installed) Nothing
        configureCommand (const configFlags) extraArgs

    Right installPlan -> case InstallPlan.ready installPlan of
      [pkg@(ConfiguredPackage (AvailablePackage _ _ LocalUnpackedPackage) _ _)] ->
        configurePackage verbosity
          (InstallPlan.planPlatform installPlan)
          (InstallPlan.planCompiler installPlan)
          (setupScriptOptions installed)
          configFlags pkg extraArgs

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

  where
    setupScriptOptions index = SetupScriptOptions {
Duncan Coutts's avatar
Duncan Coutts committed
106
      useCabalVersion  = maybe anyVersion thisVersion
107
                         (flagToMaybe (configCabalVersion configExFlags)),
108 109 110 111
      useCompiler      = Just comp,
      -- 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.
112 113 114 115 116 117
      usePackageDB     = if UserPackageDB `elem` packageDBs
                           then packageDBs
                           else packageDBs ++ [UserPackageDB],
      usePackageIndex  = if UserPackageDB `elem` packageDBs
                           then index
                           else Nothing,
118
      useProgramConfig = conf,
119
      useDistPref      = fromFlagOrDefault
120
                           (useDistPref defaultSetupScriptOptions)
121
                           (configDistPref configFlags),
122 123 124 125 126 127 128 129
      useLoggingHandle = Nothing,
      useWorkingDir    = Nothing
    }

-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler
130
                 -> ConfigFlags -> ConfigExFlags
131
                 -> Maybe (PackageIndex InstalledPackage)
132 133
                 -> AvailablePackageDb
                 -> IO (Progress String String InstallPlan)
134
planLocalPackage verbosity comp configFlags configExFlags installed
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
  (AvailablePackageDb _ availablePrefs) = do
  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
  let -- The trick is, we add the local package to the available index and
      -- remove it from the installed index. Then we ask to resolve a
      -- dependency on exactly that package. So the resolver ends up having
      -- to pick the local package.
      available' = PackageIndex.insert localPkg mempty
      installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed
      localPkg = AvailablePackage {
        packageInfoId                = packageId pkg,
        Available.packageDescription = pkg,
        packageSource                = LocalUnpackedPackage
      }
      targets     = [packageName pkg]
      constraints = [PackageVersionConstraint (packageName pkg)
Duncan Coutts's avatar
Duncan Coutts committed
150
                       (thisVersion (packageVersion pkg))
151
                    ,PackageFlagsConstraint   (packageName pkg)
152
                       (configConfigurationsFlags configFlags)]
153
                 ++ [ PackageVersionConstraint name ver
154
                    | Dependency name ver <- configConstraints configFlags ]
155
      preferences = mergePackagePrefs PreferLatestForSelected
156
                                      availablePrefs configExFlags
157 158 159 160 161 162 163

  return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
             installed' available' preferences constraints targets


mergePackagePrefs :: PackagesPreferenceDefault
                  -> Map.Map PackageName VersionRange
164
                  -> ConfigExFlags
165
                  -> PackagesPreference
166
mergePackagePrefs defaultPref availablePrefs configExFlags =
167 168 169 170 171 172
  PackagesPreference defaultPref $
       -- The preferences that come from the hackage index
       [ PackageVersionPreference name ver
       | (name, ver) <- Map.toList availablePrefs ]
       -- additional preferences from the config file or command line
    ++ [ PackageVersionPreference name ver
173
       | Dependency name ver <- configPreferences configExFlags ]
174 175 176 177 178 179 180 181 182 183

-- | Call an installer for an 'AvailablePackage' but override the configure
-- flags with the ones given by the 'ConfiguredPackage'. In particular the
-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly
-- versioned package dependencies. So we ignore any previous partial flag
-- assignment or dependency constraints and use the new ones.
--
configurePackage :: Verbosity
                 -> Platform -> CompilerId
                 -> SetupScriptOptions
184
                 -> ConfigFlags
185 186 187
                 -> ConfiguredPackage
                 -> [String]
                 -> IO ()
188
configurePackage verbosity platform comp scriptOptions configFlags
189 190 191 192 193 194 195
  (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =

  setupWrapper verbosity
    scriptOptions (Just pkg) configureCommand configureFlags extraArgs

  where
    configureFlags   = filterConfigureFlags configFlags {
196 197 198
      configConfigurationsFlags = flags,
      configConstraints         = map thisPackageVersion deps,
      configVerbosity           = toFlag verbosity
199 200 201
    }

    pkg = case finalizePackageDescription flags
202 203
           (const True)
           platform comp [] gpkg of
204 205
      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
      Right (desc, _) -> desc