From f359cbea3551329f4d8fb28e725b4776a02ddbc6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 14 Oct 2015 16:23:11 +0000 Subject: [PATCH] Add allow-newer config option (closes #922) --- ChangeLog.md | 7 +++++ doc/yaml_configuration.md | 13 +++++++++ src/Stack/Build/ConstructPlan.hs | 48 ++++++++++++++++++++++++-------- src/Stack/Config.hs | 1 + src/Stack/Types/Config.hs | 9 ++++++ 5 files changed, 66 insertions(+), 12 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 0772ceb89b..dadfbee089 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ ## Unreleased changes +Major changes: + +Other enhancements: + +* Added an `allow-newer` config option [#922](https://github.com/commercialhaskell/stack/issues/922) [#770](https://github.com/commercialhaskell/stack/issues/770) + +Bug fixes: ## v0.1.6.0 diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 25229fb7c0..dffa8bbe9b 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -346,3 +346,16 @@ apply-ghc-options: locals # all local packages, the default ``` Note that `everything` is a slightly dangerous value, as it can break invariants about your snapshot database. + +### allow-newer + +(Since 0.1.7) + +Ignore version bounds in .cabal files. Default is false. + +```yaml +allow-newer: true +``` + +Note that this also ignores lower bounds. The name "allow-newer" is chosen to +match the commonly used cabal option. diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 4da8ada03d..5fac9c63ce 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -- | Construct a @Plan@ for how to build module Stack.Build.ConstructPlan @@ -13,7 +14,7 @@ import Control.Exception.Lifted import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class -import Control.Monad.Logger (MonadLogger) +import Control.Monad.Logger (MonadLogger, logWarn) import Control.Monad.RWS.Strict import Control.Monad.Trans.Resource import qualified Data.ByteString.Char8 as S8 @@ -82,10 +83,12 @@ data W = W -- ^ why a local package is considered dirty , wDeps :: !(Set PackageName) -- ^ Packages which count as dependencies + , wWarnings :: !([Text] -> [Text]) + -- ^ Warnings } instance Monoid W where - mempty = W mempty mempty mempty mempty - mappend (W a b c d) (W w x y z) = W (mappend a w) (mappend b x) (mappend c y) (mappend d z) + mempty = W mempty mempty mempty mempty mempty + mappend (W a b c d e) (W w x y z z') = W (mappend a w) (mappend b x) (mappend c y) (mappend d z) (mappend e z') type M = RWST Ctx @@ -143,7 +146,9 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 locallyRegistered loadPa let inner = do mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 - ((), m, W efinals installExes dirtyReason deps) <- liftIO $ runRWST inner (ctx econfig latest) M.empty + ((), m, W efinals installExes dirtyReason deps warnings) <- + liftIO $ runRWST inner (ctx econfig latest) M.empty + mapM_ $logWarn (warnings []) let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m @@ -398,14 +403,33 @@ addPackageDeps treatAsDep package = do UnknownPackage name -> assert (name == depname) NotInBuildPlan _ -> Couldn'tResolveItsDependencies in return $ Left (depname, (range, mlatest, bd)) - Right adr | not $ adrVersion adr `withinRange` range -> - return $ Left (depname, (range, mlatest, DependencyMismatch $ adrVersion adr)) - Right (ADRToInstall task) -> return $ Right - (Set.singleton $ taskProvides task, Map.empty, taskLocation task) - Right (ADRFound loc _ (Executable _)) -> return $ Right - (Set.empty, Map.empty, loc) - Right (ADRFound loc _ (Library ident gid)) -> return $ Right - (Set.empty, Map.singleton ident gid, loc) + Right adr -> do + inRange <- if adrVersion adr `withinRange` range + then return True + else do + allowNewer <- asks $ configAllowNewer . getConfig + if allowNewer + then do + let msg = T.concat + [ "WARNING: Ignoring out of range dependency: " + , T.pack $ packageIdentifierString $ PackageIdentifier depname (adrVersion adr) + , ". " + , T.pack $ packageNameString $ packageName package + , " requires: " + , versionRangeText range + ] + tell mempty { wWarnings = (msg:) } + return True + else return False + if inRange + then case adr of + ADRToInstall task -> return $ Right + (Set.singleton $ taskProvides task, Map.empty, taskLocation task) + ADRFound loc _ (Executable _) -> return $ Right + (Set.empty, Map.empty, loc) + ADRFound loc _ (Library ident gid) -> return $ Right + (Set.empty, Map.singleton ident gid, loc) + else return $ Left (depname, (range, mlatest, DependencyMismatch $ adrVersion adr)) case partitionEithers deps of ([], pairs) -> return $ Right $ mconcat pairs (errs, _) -> return $ Left $ DependencyPlanFailures diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 0ddd3e45ab..f646efd5bf 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -191,6 +191,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi configExplicitSetupDeps = configMonoidExplicitSetupDeps configRebuildGhcOptions = fromMaybe False configMonoidRebuildGhcOptions configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions + configAllowNewer = fromMaybe False configMonoidAllowNewer return Config {..} diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index f3e87a8a9b..c3d16814e1 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -151,6 +151,9 @@ data Config = -- ^ Rebuild on GHC options changes ,configApplyGhcOptions :: !ApplyGhcOptions -- ^ Which packages to ghc-options on the command line apply to? + ,configAllowNewer :: !Bool + -- ^ Ignore version ranges in .cabal files. Funny naming chosen to + -- match cabal. } -- | Which packages to ghc-options on the command line apply to? @@ -605,6 +608,9 @@ data ConfigMonoid = ,configMonoidRebuildGhcOptions :: !(Maybe Bool) -- ^ See 'configMonoidRebuildGhcOptions' ,configMonoidApplyGhcOptions :: !(Maybe ApplyGhcOptions) + -- ^ See 'configApplyGhcOptions' + ,configMonoidAllowNewer :: !(Maybe Bool) + -- ^ See 'configMonoidAllowNewer' } deriving Show @@ -640,6 +646,7 @@ instance Monoid ConfigMonoid where , configMonoidExplicitSetupDeps = mempty , configMonoidRebuildGhcOptions = Nothing , configMonoidApplyGhcOptions = Nothing + , configMonoidAllowNewer = Nothing } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r @@ -673,6 +680,7 @@ instance Monoid ConfigMonoid where , configMonoidExplicitSetupDeps = configMonoidExplicitSetupDeps l <> configMonoidExplicitSetupDeps r , configMonoidRebuildGhcOptions = configMonoidRebuildGhcOptions l <|> configMonoidRebuildGhcOptions r , configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r + , configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r } instance FromJSON (ConfigMonoid, [JSONWarning]) where @@ -734,6 +742,7 @@ parseConfigMonoidJSON obj = do >>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList configMonoidRebuildGhcOptions <- obj ..:? "rebuild-ghc-options" configMonoidApplyGhcOptions <- obj ..:? "apply-ghc-options" + configMonoidAllowNewer <- obj ..:? "allow-newer" return ConfigMonoid {..} where