Configure.hs 8.44 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 35 36 37
import Distribution.Client.Types as Available
import Distribution.Client.SetupWrapper
         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )

import Distribution.Simple.Compiler
38 39
         ( CompilerId(..), Compiler(compilerId)
         , PackageDB(..), PackageDBStack )
40
import Distribution.Simple.Program (ProgramConfiguration )
41 42
import Distribution.Simple.Setup
         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
43 44
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
45 46 47 48 49 50 51 52 53 54
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
55
         ( VersionRange, anyVersion, thisVersion )
56 57 58
import Distribution.Simple.Utils as Utils
         ( notice, info, die )
import Distribution.System
59
         ( Platform, buildPlatform )
60 61 62 63 64
import Distribution.Verbosity as Verbosity
         ( Verbosity )

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

76
  installed <- getInstalledPackages verbosity comp packageDBs conf
77 78
  available <- getAvailablePackages verbosity repos

79
  progress <- planLocalPackage verbosity comp configFlags configExFlags
80 81 82 83 84 85 86 87 88 89 90 91
                               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
92
      [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] ->
93 94 95 96 97 98 99 100 101 102 103
        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
104
      useCabalVersion  = maybe anyVersion thisVersion
105
                         (flagToMaybe (configCabalVersion configExFlags)),
106 107 108 109
      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.
110 111 112 113
      usePackageDB     = if UserPackageDB `elem` packageDBs
                           then packageDBs
                           else packageDBs ++ [UserPackageDB],
      usePackageIndex  = if UserPackageDB `elem` packageDBs
114
                           then Just index
115
                           else Nothing,
116
      useProgramConfig = conf,
117
      useDistPref      = fromFlagOrDefault
118
                           (useDistPref defaultSetupScriptOptions)
119
                           (configDistPref configFlags),
120 121 122 123 124 125 126 127
      useLoggingHandle = Nothing,
      useWorkingDir    = Nothing
    }

-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler
128
                 -> ConfigFlags -> ConfigExFlags
129
                 -> PackageIndex InstalledPackage
130 131
                 -> AvailablePackageDb
                 -> IO (Progress String String InstallPlan)
132
planLocalPackage verbosity comp configFlags configExFlags installed
133 134 135 136 137 138 139
  (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
140
      installed' = PackageIndex.deletePackageId (packageId localPkg) installed
141 142 143
      localPkg = AvailablePackage {
        packageInfoId                = packageId pkg,
        Available.packageDescription = pkg,
144
        packageSource                = LocalUnpackedPackage "."
145 146 147
      }
      targets     = [packageName pkg]
      constraints = [PackageVersionConstraint (packageName pkg)
Duncan Coutts's avatar
Duncan Coutts committed
148
                       (thisVersion (packageVersion pkg))
149
                    ,PackageFlagsConstraint   (packageName pkg)
150
                       (configConfigurationsFlags configFlags)]
151
                 ++ [ PackageVersionConstraint name ver
152
                    | Dependency name ver <- configConstraints configFlags ]
153
      preferences = mergePackagePrefs PreferLatestForSelected
154
                                      availablePrefs configExFlags
155 156 157 158 159 160 161

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


mergePackagePrefs :: PackagesPreferenceDefault
                  -> Map.Map PackageName VersionRange
162
                  -> ConfigExFlags
163
                  -> PackagesPreference
164
mergePackagePrefs defaultPref availablePrefs configExFlags =
165 166 167 168 169 170
  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
171
       | Dependency name ver <- configPreferences configExFlags ]
172 173 174 175 176 177 178 179 180 181

-- | 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
182
                 -> ConfigFlags
183 184 185
                 -> ConfiguredPackage
                 -> [String]
                 -> IO ()
186
configurePackage verbosity platform comp scriptOptions configFlags
187 188 189 190 191 192 193
  (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =

  setupWrapper verbosity
    scriptOptions (Just pkg) configureCommand configureFlags extraArgs

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

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