Configure.hs 8.97 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 30 31 32 33 34 35 36 37 38 39 40 41 42
-----------------------------------------------------------------------------
-- |
-- 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
         ( getAvailablePackages )
import Distribution.Client.Setup
         ( InstallFlags(..), configureCommand, filterConfigureFlags )
import Distribution.Client.Types as Available
         ( AvailablePackage(..), AvailablePackageSource(..), Repo(..)
         , AvailablePackageDb(..), ConfiguredPackage(..) )
import Distribution.Client.SetupWrapper
         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )

import Distribution.Simple.Compiler
         ( CompilerId(..), Compiler(compilerId), PackageDB(..) )
import Distribution.Simple.Program (ProgramConfiguration )
import Distribution.Simple.Configure (getInstalledPackages)
43 44
import Distribution.Simple.Setup
         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Simple.Utils
         ( defaultPackageDesc )
import Distribution.Package
         ( PackageName, packageName, packageVersion
         , Package(..), Dependency(..), thisPackageVersion )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
         ( PackageDescription )
import Distribution.PackageDescription.Parse
         ( readPackageDescription )
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription )
import Distribution.InstalledPackageInfo
         ( InstalledPackageInfo )
import Distribution.Version
         ( VersionRange(AnyVersion, ThisVersion) )
import Distribution.Simple.Utils as Utils
         ( notice, info, die )
import Distribution.System
         ( Platform(Platform), buildPlatform )
import Distribution.Verbosity as Verbosity
         ( Verbosity )

-- | Configure the package found in the local directory
configure :: Verbosity
          -> PackageDB
          -> [Repo]
          -> Compiler
          -> ProgramConfiguration
76
          -> ConfigFlags
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
          -> InstallFlags
          -> [String]
          -> IO ()
configure verbosity packageDB repos comp conf configFlags installFlags extraArgs = do
  installed <- getInstalledPackages verbosity comp packageDB conf
  available <- getAvailablePackages verbosity repos

  progress <- planLocalPackage verbosity comp configFlags installFlags
                               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 {
      useCabalVersion  = maybe AnyVersion ThisVersion
110
                         (flagToMaybe (installCabalVersion installFlags)),
111 112 113 114 115 116 117 118 119 120 121
      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.
      -- TODO: if we specify a specific db then we do not look in the user
      --       package db but we probably should ie [global, user, specific]
      usePackageDB     = if packageDB == GlobalPackageDB then UserPackageDB
                                                         else packageDB,
      usePackageIndex  = if packageDB == GlobalPackageDB then Nothing
                                                         else index,
      useProgramConfig = conf,
122
      useDistPref      = fromFlagOrDefault
123
                           (useDistPref defaultSetupScriptOptions)
124
                           (configDistPref configFlags),
125 126 127 128 129 130 131 132
      useLoggingHandle = Nothing,
      useWorkingDir    = Nothing
    }

-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler
133
                 -> ConfigFlags -> InstallFlags
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
                 -> Maybe (PackageIndex InstalledPackageInfo)
                 -> AvailablePackageDb
                 -> IO (Progress String String InstallPlan)
planLocalPackage verbosity comp configFlags installFlags installed
  (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)
                       (ThisVersion (packageVersion pkg))
                    ,PackageFlagsConstraint   (packageName pkg)
155
                       (configConfigurationsFlags configFlags)]
156
                 ++ [ PackageVersionConstraint name ver
157
                    | Dependency name ver <- configConstraints configFlags ]
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186
      preferences = mergePackagePrefs PreferLatestForSelected
                                      availablePrefs installFlags

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


mergePackagePrefs :: PackagesPreferenceDefault
                  -> Map.Map PackageName VersionRange
                  -> InstallFlags
                  -> PackagesPreference
mergePackagePrefs defaultPref availablePrefs installFlags =
  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
       | Dependency name ver <- installPreferences installFlags ]

-- | 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
187
                 -> ConfigFlags
188 189 190 191 192 193 194 195 196 197 198
                 -> ConfiguredPackage
                 -> [String]
                 -> IO ()
configurePackage verbosity (Platform arch os) comp scriptOptions configFlags
  (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =

  setupWrapper verbosity
    scriptOptions (Just pkg) configureCommand configureFlags extraArgs

  where
    configureFlags   = filterConfigureFlags configFlags {
199 200 201
      configConfigurationsFlags = flags,
      configConstraints         = map thisPackageVersion deps,
      configVerbosity           = toFlag verbosity
202 203 204 205 206 207 208
    }

    pkg = case finalizePackageDescription flags
           (Nothing :: Maybe (PackageIndex PackageDescription))
           os arch comp [] gpkg of
      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
      Right (desc, _) -> desc