Commit ae59bb3d authored by ttuegel's avatar ttuegel

Add `reconfigure` command

Fixes #2214 by adding a `reconfigure` command and invoking it whenever
necessary. The last configure flags used are saved in a
version-independent format so it should never be necessary for the user
to reconfigure manually.
parent 864ddbbd
......@@ -94,6 +94,8 @@ import Distribution.Utils.NubList
import Distribution.Compat.Semigroup (Last' (..))
import Data.Function (on)
-- FIXME Not sure where this should live
defaultDistPref :: FilePath
defaultDistPref = "dist"
......@@ -347,6 +349,7 @@ relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs
--
-- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'
-- should be updated.
-- IMPORTANT: every time a new flag is added, it should be added to the Eq instance
data ConfigFlags = ConfigFlags {
-- This is the same hack as in 'buildArgs' and 'copyArgs'.
-- TODO: Stop using this eventually when 'UserHooks' gets changed
......@@ -433,6 +436,54 @@ instance Binary ConfigFlags
configPrograms :: ConfigFlags -> ProgramDb
configPrograms = maybe (error "FIXME: remove configPrograms") id . getLast' . configPrograms_
instance Eq ConfigFlags where
(==) a b =
-- configPrograms skipped: not user specified, has no Eq instance
equal configProgramPaths
&& equal configProgramArgs
&& equal configProgramPathExtra
&& equal configHcFlavor
&& equal configHcPath
&& equal configHcPkg
&& equal configVanillaLib
&& equal configProfLib
&& equal configSharedLib
&& equal configDynExe
&& equal configProfExe
&& equal configProf
&& equal configProfDetail
&& equal configProfLibDetail
&& equal configConfigureArgs
&& equal configOptimization
&& equal configProgPrefix
&& equal configProgSuffix
&& equal configInstallDirs
&& equal configScratchDir
&& equal configExtraLibDirs
&& equal configExtraIncludeDirs
&& equal configIPID
&& equal configDistPref
&& equal configVerbosity
&& equal configUserInstall
&& equal configPackageDBs
&& equal configGHCiLib
&& equal configSplitObjs
&& equal configStripExes
&& equal configStripLibs
&& equal configConstraints
&& equal configDependencies
&& equal configConfigurationsFlags
&& equal configTests
&& equal configBenchmarks
&& equal configCoverage
&& equal configLibCoverage
&& equal configExactConfiguration
&& equal configFlagError
&& equal configRelocatable
&& equal configDebugInfo
where
equal f = on (==) f a b
configAbsolutePaths :: ConfigFlags -> NoCallStackIO ConfigFlags
configAbsolutePaths f =
(\v -> f { configPackageDBs = v })
......
......@@ -15,7 +15,11 @@ module Distribution.Client.Configure (
configure,
configureSetupScript,
chooseCabalVersion,
checkConfigExFlags
checkConfigExFlags,
-- * Saved configure flags
readConfigFlagsFrom, readConfigFlags,
cabalConfigFlagsFile,
writeConfigFlagsTo, writeConfigFlags,
) where
import Distribution.Client.Dependency
......@@ -24,8 +28,8 @@ import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.Setup
( ConfigExFlags(..), configureCommand, filterConfigureFlags
, RepoContext(..) )
( ConfigExFlags(..), RepoContext(..)
, configureCommand, configureExCommand, filterConfigureFlags )
import Distribution.Client.Types as Source
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
......@@ -46,7 +50,8 @@ import Distribution.Solver.Types.SourcePackage
import Distribution.Simple.Compiler
( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )
import Distribution.Simple.Program (ProgramDb )
import Distribution.Simple.Program (ProgramDb)
import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags )
import Distribution.Simple.Setup
( ConfigFlags(..), AllowNewer(..), AllowOlder(..), RelaxDeps(..)
, fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )
......@@ -82,6 +87,7 @@ import Control.Monad (unless)
import Data.Monoid (Monoid(..))
#endif
import Data.Maybe (isJust, fromMaybe)
import System.FilePath ( (</>) )
-- | Choose the Cabal version such that the setup scripts compiled against this
-- version will support the given command-line flags.
......@@ -401,3 +407,40 @@ configurePackage verbosity platform comp scriptOptions configFlags
platform comp [] gpkg of
Left _ -> error "finalizePD ReadyPackage failed"
Right (desc, _) -> desc
-- -----------------------------------------------------------------------------
-- * Saved configure environments and flags
-- -----------------------------------------------------------------------------
-- | Read saved configure flags and restore the saved environment from the
-- specified files.
readConfigFlagsFrom :: FilePath -- ^ path to saved flags file
-> IO (ConfigFlags, ConfigExFlags)
readConfigFlagsFrom flags = do
readCommandFlags flags configureExCommand
-- | The path (relative to @--build-dir@) where the arguments to @configure@
-- should be saved.
cabalConfigFlagsFile :: FilePath -> FilePath
cabalConfigFlagsFile dist = dist </> "cabal-config-flags"
-- | Read saved configure flags and restore the saved environment from the
-- usual location.
readConfigFlags :: FilePath -- ^ @--build-dir@
-> IO (ConfigFlags, ConfigExFlags)
readConfigFlags dist =
readConfigFlagsFrom (cabalConfigFlagsFile dist)
-- | Save the configure flags and environment to the specified files.
writeConfigFlagsTo :: FilePath -- ^ path to saved flags file
-> Verbosity -> (ConfigFlags, ConfigExFlags)
-> IO ()
writeConfigFlagsTo file verb flags = do
writeCommandFlags verb file configureExCommand flags
-- | Save the build flags to the usual location.
writeConfigFlags :: Verbosity
-> FilePath -- ^ @--build-dir@
-> (ConfigFlags, ConfigExFlags) -> IO ()
writeConfigFlags verb dist =
writeConfigFlagsTo (cabalConfigFlagsFile dist) verb
module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where
import Control.Monad ( unless, when )
import Data.Monoid hiding ( (<>) )
import System.Directory ( doesFileExist )
import Distribution.Compat.Semigroup
import Distribution.Verbosity
import Distribution.Simple.Configure ( localBuildInfoFile )
import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag )
import Distribution.Simple.Utils
( existsAndIsMoreRecentThan, defaultPackageDesc, info )
import Distribution.Client.Config ( SavedConfig(..) )
import Distribution.Client.Configure ( readConfigFlags )
import Distribution.Client.Sandbox
( WereDepsReinstalled(..), findSavedDistPref, getSandboxConfigFilePath
, maybeReinstallAddSourceDeps, updateInstallDirs )
import Distribution.Client.Sandbox.PackageEnvironment
( userPackageEnvironmentFile )
import Distribution.Client.Sandbox.Types ( UseSandbox(..) )
import Distribution.Client.Setup
( ConfigFlags(..), ConfigExFlags, GlobalFlags(..)
, SkipAddSourceDepsCheck(..) )
-- | @Check@ represents a function to check some condition on type @a@. The
-- returned 'Any' is 'True' if any part of the condition failed.
newtype Check a = Check {
runCheck :: Any -- ^ Did any previous check fail?
-> a -- ^ value returned by previous checks
-> IO (Any, a) -- ^ Did this check fail? What value is returned?
}
instance Semigroup (Check a) where
(<>) c d = Check $ \any0 a0 -> do
(any1, a1) <- runCheck c any0 a0
(any2, a2) <- runCheck d (any0 <> any1) a1
return (any0 <> any1 <> any2, a2)
instance Monoid (Check a) where
mempty = Check $ \_ a -> return (mempty, a)
mappend = (<>)
-- | Re-configure the package in the current directory if needed. Deciding
-- when to reconfigure and with which options is convoluted:
--
-- If we are reconfiguring, we must always run @configure@ with the
-- verbosity option we are given; however, that a previous configuration
-- uses a different verbosity setting is not reason enough to reconfigure.
--
-- The package should be configured to use the same \"dist\" prefix as
-- given to the @build@ command, otherwise the build will probably
-- fail. Not only does this determine the \"dist\" prefix setting if we
-- need to reconfigure anyway, but an existing configuration should be
-- invalidated if its \"dist\" prefix differs.
--
-- If the package has never been configured (i.e., there is no
-- LocalBuildInfo), we must configure first, using the default options.
--
-- If the package has been configured, there will be a 'LocalBuildInfo'.
-- If there no package description file, we assume that the
-- 'PackageDescription' is up to date, though the configuration may need
-- to be updated for other reasons (see above). If there is a package
-- description file, and it has been modified since the 'LocalBuildInfo'
-- was generated, then we need to reconfigure.
--
-- The caller of this function may also have specific requirements
-- regarding the flags the last configuration used. For example,
-- 'testAction' requires that the package be configured with test suites
-- enabled. The caller may pass the required settings to this function
-- along with a function to check the validity of the saved 'ConfigFlags';
-- these required settings will be checked first upon determining that
-- a previous configuration exists.
reconfigure
:: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())
-- ^ configure action
-> Verbosity
-- ^ Verbosity setting
-> FilePath
-- ^ \"dist\" prefix
-> UseSandbox
-> SkipAddSourceDepsCheck
-- ^ Should we skip the timestamp check for modified
-- add-source dependencies?
-> Flag (Maybe Int)
-- ^ -j flag for reinstalling add-source deps.
-> Check (ConfigFlags, ConfigExFlags)
-- ^ Check that the required flags are set.
-- If they are not set, provide a message explaining the
-- reason for reconfiguration.
-> [String] -- ^ Extra arguments
-> GlobalFlags -- ^ Global flags
-> SavedConfig
-> IO SavedConfig
reconfigure
configureAction
verbosity
dist
useSandbox
skipAddSourceDepsCheck
numJobsFlag
check
extraArgs
globalFlags
config
= do
savedFlags@(_, _) <- readConfigFlags dist
let checks =
checkVerb
<> checkDist
<> checkOutdated
<> check
<> checkAddSourceDeps
(Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags
let (_, config') =
updateInstallDirs
(configUserInstall configFlags)
(useSandbox, config)
when force $ configureAction flags extraArgs globalFlags
return config'
where
-- Changing the verbosity does not require reconfiguration, but the new
-- verbosity should be used if reconfiguring.
checkVerb = Check $ \_ (configFlags, configExFlags) -> do
let configFlags' = configFlags { configVerbosity = toFlag verbosity}
return (mempty, (configFlags', configExFlags))
-- Reconfiguration is required if @--build-dir@ changes.
checkDist = Check $ \_ (configFlags, configExFlags) -> do
-- Always set the chosen @--build-dir@ before saving the flags,
-- or bad things could happen.
savedDist <- findSavedDistPref config (configDistPref configFlags)
let distChanged = dist /= savedDist
when distChanged $ info verbosity "build directory changed"
let configFlags' = configFlags { configDistPref = toFlag dist }
return (Any distChanged, (configFlags', configExFlags))
checkOutdated = Check $ \_ flags@(configFlags, _) -> do
let buildConfig = localBuildInfoFile dist
-- Has the package ever been configured? If not, reconfiguration is
-- required.
configured <- doesFileExist buildConfig
unless configured $ info verbosity "package has never been configured"
-- Is the configuration older than the sandbox configuration file?
-- If so, reconfiguration is required.
sandboxConfig <- getSandboxConfigFilePath globalFlags
sandboxConfigNewer <- existsAndIsMoreRecentThan sandboxConfig buildConfig
when sandboxConfigNewer $
info verbosity "sandbox was created after the package was configured"
-- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need
-- to force reconfigure. Note that it's possible to use @cabal.config@
-- even without sandboxes.
userPackageEnvironmentFileModified <-
existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig
when userPackageEnvironmentFileModified $
info verbosity ("user package environment file ('"
++ userPackageEnvironmentFile ++ "') was modified")
-- Is the configuration older than the package description?
descrFile <- maybe (defaultPackageDesc verbosity) return
(flagToMaybe (configCabalFilePath configFlags))
outdated <- existsAndIsMoreRecentThan descrFile buildConfig
when outdated $ info verbosity (descrFile ++ " was changed")
let failed =
Any outdated
<> Any userPackageEnvironmentFileModified
<> Any sandboxConfigNewer
<> Any (not configured)
return (failed, flags)
checkAddSourceDeps = Check $ \(Any force') flags@(configFlags, _) -> do
let (_, config') =
updateInstallDirs
(configUserInstall configFlags)
(useSandbox, config)
skipAddSourceDepsCheck'
| force' = SkipAddSourceDepsCheck
| otherwise = skipAddSourceDepsCheck
when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $
info verbosity "skipping add-source deps check"
-- Were any add-source dependencies reinstalled in the sandbox?
depsReinstalled <-
case skipAddSourceDepsCheck' of
DontSkipAddSourceDepsCheck ->
maybeReinstallAddSourceDeps
verbosity numJobsFlag configFlags globalFlags
(useSandbox, config')
SkipAddSourceDepsCheck -> do
return NoDepsReinstalled
case depsReinstalled of
NoDepsReinstalled -> return (mempty, flags)
ReinstalledSomeDeps -> do
info verbosity "some add-source dependencies were reinstalled"
return (Any True, flags)
{-# LANGUAGE DeriveDataTypeable #-}
module Distribution.Client.SavedFlags
( readCommandFlags, writeCommandFlags
, readSavedArgs, writeSavedArgs
) where
import Distribution.Simple.Command
import Distribution.Simple.UserHooks ( Args )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, unintersperse )
import Distribution.Verbosity
import Control.Exception ( Exception, throwIO )
import Control.Monad ( liftM )
import Data.List ( intercalate )
import Data.Maybe ( fromMaybe )
import Data.Typeable
import System.Directory ( doesFileExist )
import System.FilePath ( takeDirectory )
writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO ()
writeSavedArgs verbosity path args = do
createDirectoryIfMissingVerbose
(lessVerbose verbosity) True (takeDirectory path)
writeFile path (intercalate "\0" args)
-- | Write command-line flags to a file, separated by null characters. This
-- format is also suitable for the @xargs -0@ command. Using the null
-- character also avoids the problem of escaping newlines or spaces,
-- because unlike other whitespace characters, the null character is
-- not valid in command-line arguments.
writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO ()
writeCommandFlags verbosity path command flags =
writeSavedArgs verbosity path (commandShowOptions command flags)
readSavedArgs :: FilePath -> IO (Maybe [String])
readSavedArgs path = do
exists <- doesFileExist path
if exists
then liftM (Just . unintersperse '\0') (readFile path)
else return Nothing
-- | Read command-line arguments, separated by null characters, from a file.
-- Returns the default flags if the file does not exist.
readCommandFlags :: FilePath -> CommandUI flags -> IO flags
readCommandFlags path command = do
savedArgs <- liftM (fromMaybe []) (readSavedArgs path)
case (commandParseArgs command True savedArgs) of
CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)
CommandList _ -> throwIO (SavedArgsErrorList savedArgs)
CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs)
CommandReadyToGo (mkFlags, _) ->
return (mkFlags (commandDefaultFlags command))
-- -----------------------------------------------------------------------------
-- * Exceptions
-- -----------------------------------------------------------------------------
data SavedArgsError
= SavedArgsErrorHelp Args
| SavedArgsErrorList Args
| SavedArgsErrorOther Args [String]
deriving (Typeable)
instance Show SavedArgsError where
show (SavedArgsErrorHelp args) =
"unexpected flag '--help', saved command line was:\n"
++ intercalate " " args
show (SavedArgsErrorList args) =
"unexpected flag '--list-options', saved command line was:\n"
++ intercalate " " args
show (SavedArgsErrorOther args errs) =
"saved command line was:\n"
++ intercalate " " args ++ "\n"
++ "encountered errors:\n"
++ intercalate "\n" errs
instance Exception SavedArgsError
......@@ -20,9 +20,9 @@ module Distribution.Client.Setup
, configureCommand, ConfigFlags(..), filterConfigureFlags
, configPackageDB', configCompilerAux'
, configureExCommand, ConfigExFlags(..), defaultConfigExFlags
, configureExOptions
, buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
, replCommand, testCommand, benchmarkCommand
, configureExOptions, reconfigureCommand
, installCommand, InstallFlags(..), installOptions, defaultInstallFlags
, defaultSolver, defaultMaxBackjumps
, listCommand, ListFlags(..)
......@@ -499,6 +499,21 @@ instance Monoid ConfigExFlags where
instance Semigroup ConfigExFlags where
(<>) = gmappend
reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags)
reconfigureCommand
= configureExCommand
{ commandName = "reconfigure"
, commandSynopsis = "Reconfigure the package if necessary."
, commandDescription = Just $ \pname -> wrapText $
"Run `configure` with the most recently used flags and append FLAGS. "
++ "Accepts the same flags as `" ++ pname ++ " configure'. "
++ "If the package has never been configured, this has the same "
++ "effect as calling `configure`."
, commandNotes = Nothing
, commandUsage = usageAlternatives "reconfigure" [ "[FLAGS]" ]
, commandDefaultFlags = mempty
}
-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------
......
This diff is collapsed.
......@@ -278,13 +278,15 @@ executable cabal
Distribution.Client.ProjectPlanning
Distribution.Client.ProjectPlanning.Types
Distribution.Client.ProjectPlanOutput
Distribution.Client.Run
Distribution.Client.RebuildMonad
Distribution.Client.Reconfigure
Distribution.Client.Run
Distribution.Client.Sandbox
Distribution.Client.Sandbox.Index
Distribution.Client.Sandbox.PackageEnvironment
Distribution.Client.Sandbox.Timestamp
Distribution.Client.Sandbox.Types
Distribution.Client.SavedFlags
Distribution.Client.Security.HTTP
Distribution.Client.Setup
Distribution.Client.SetupWrapper
......
......@@ -22,6 +22,7 @@
verbose GHC output (#3540, #3671).
* Changed the default logfile template from
'.../$pkgid.log' to '.../$compiler/$libname.log' (#3807).
* Added a new command, 'cabal reconfigure' (#2214).
1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016
* If there are multiple remote repos, 'cabal update' now updates
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment