Configure.hs 7.4 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
-----------------------------------------------------------------------------
-- |
-- 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 Distribution.Client.Dependency
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
21
         ( getAvailablePackages, getInstalledPackages )
22
import Distribution.Client.Setup
23
         ( ConfigExFlags(..), configureCommand, filterConfigureFlags )
24 25 26 27 28
import Distribution.Client.Types as Available
import Distribution.Client.SetupWrapper
         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )

import Distribution.Simple.Compiler
29 30
         ( CompilerId(..), Compiler(compilerId)
         , PackageDB(..), PackageDBStack )
31
import Distribution.Simple.Program (ProgramConfiguration )
32 33
import Distribution.Simple.Setup
         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
34
import Distribution.Client.PackageIndex (PackageIndex)
35 36 37
import Distribution.Simple.Utils
         ( defaultPackageDesc )
import Distribution.Package
38
         ( Package(..), packageName, Dependency(..), thisPackageVersion )
39 40 41 42 43
import Distribution.PackageDescription.Parse
         ( readPackageDescription )
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription )
import Distribution.Version
44
         ( anyVersion, thisVersion )
45
import Distribution.Simple.Utils as Utils
46
         ( notice, info, debug, die )
47
import Distribution.System
48
         ( Platform, buildPlatform )
49 50 51
import Distribution.Verbosity as Verbosity
         ( Verbosity )

52 53
import Data.Monoid (Monoid(..))

54 55
-- | Configure the package found in the local directory
configure :: Verbosity
56
          -> PackageDBStack
57 58 59
          -> [Repo]
          -> Compiler
          -> ProgramConfiguration
60
          -> ConfigFlags
61
          -> ConfigExFlags
62 63
          -> [String]
          -> IO ()
64
configure verbosity packageDBs repos comp conf
65 66
  configFlags configExFlags extraArgs = do

67
  installed <- getInstalledPackages verbosity comp packageDBs conf
68 69
  available <- getAvailablePackages verbosity repos

70
  progress <- planLocalPackage verbosity comp configFlags configExFlags
71 72 73
                               installed available

  notice verbosity "Resolving dependencies..."
74 75
  maybePlan <- foldProgress logMsg (return . Left) (return . Right)
                            progress
76 77 78 79 80 81 82
  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
83
      [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] ->
84 85 86 87 88 89 90 91 92 93 94
        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
95
      useCabalVersion  = maybe anyVersion thisVersion
96
                         (flagToMaybe (configCabalVersion configExFlags)),
97 98 99 100
      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.
101 102 103 104
      usePackageDB     = if UserPackageDB `elem` packageDBs
                           then packageDBs
                           else packageDBs ++ [UserPackageDB],
      usePackageIndex  = if UserPackageDB `elem` packageDBs
105
                           then Just index
106
                           else Nothing,
107
      useProgramConfig = conf,
108
      useDistPref      = fromFlagOrDefault
109
                           (useDistPref defaultSetupScriptOptions)
110
                           (configDistPref configFlags),
111 112 113 114
      useLoggingHandle = Nothing,
      useWorkingDir    = Nothing
    }

115 116
    logMsg message rest = debug verbosity message >> rest

117 118 119 120
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler
121
                 -> ConfigFlags -> ConfigExFlags
122
                 -> PackageIndex InstalledPackage
123 124
                 -> AvailablePackageDb
                 -> IO (Progress String String InstallPlan)
125
planLocalPackage verbosity comp configFlags configExFlags installed
126
  (AvailablePackageDb _ availablePrefs) = do
127
  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
128 129

  let -- We create a local package and ask to resolve a dependency on it
130 131 132
      localPkg = AvailablePackage {
        packageInfoId                = packageId pkg,
        Available.packageDescription = pkg,
133
        packageSource                = LocalUnpackedPackage "."
134
      }
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152

      resolverParams =

          addPreferences
            -- 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
            [ PackageVersionConstraint name ver
            | Dependency name ver <- configConstraints configFlags ]

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

153 154 155 156
        $ standardInstallPolicy
            installed
            (AvailablePackageDb mempty availablePrefs)
            [SpecificSourcePackage localPkg]
157 158 159

  return (resolveDependencies buildPlatform (compilerId comp) resolverParams)

160 161 162 163 164 165 166 167 168 169

-- | 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
170
                 -> ConfigFlags
171 172 173
                 -> ConfiguredPackage
                 -> [String]
                 -> IO ()
174
configurePackage verbosity platform comp scriptOptions configFlags
175 176 177 178 179 180 181
  (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =

  setupWrapper verbosity
    scriptOptions (Just pkg) configureCommand configureFlags extraArgs

  where
    configureFlags   = filterConfigureFlags configFlags {
182 183 184
      configConfigurationsFlags = flags,
      configConstraints         = map thisPackageVersion deps,
      configVerbosity           = toFlag verbosity
185 186 187
    }

    pkg = case finalizePackageDescription flags
188 189
           (const True)
           platform comp [] gpkg of
190 191
      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
      Right (desc, _) -> desc