From 36765592c8ebbffe2e7907c33057456705483871 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 01:23:42 +0530 Subject: [PATCH 01/29] Track the best snapshot by the number of deperrors Changes in this commit: 1) When figuring out a build plan, track the dependency errors for each snapshot to figure out which snapshot is the best even if there are dependency errors. 2) Use the same strategy even when finding out the best set of flags. Find out the combination of flags producing least number of dependency errors. 3) Modularise the interfaces to make the code components more reusable if needed. This change is supposed to be used for later enhancements to use the dependency solver on the best matching snapshot in absence of an error free match. --- src/Stack/BuildPlan.hs | 262 +++++++++++++++++++++++++++++------------ 1 file changed, 185 insertions(+), 77 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 1b9e5ef1ef..ef93e7b5ef 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -49,7 +49,7 @@ import qualified Data.IntMap as IntMap import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set @@ -64,6 +64,7 @@ import Distribution.PackageDescription (GenericPackageDescription, flagDefault, flagManual, flagName, genPackageFlags, executables, exeName, library, libBuildInfo, buildable) +import Distribution.System (Platform) import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C import qualified Distribution.Version as C @@ -494,67 +495,106 @@ loadBuildPlan name = do handle404 (Status 404 _) _ _ = Just $ SomeException $ SnapshotNotFound name handle404 _ _ _ = Nothing --- | Find the set of @FlagName@s necessary to get the given --- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will --- only modify non-manual flags, and will prefer default values for flags. --- Returns @Nothing@ if no combination exists. -checkBuildPlan :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadCatch m) - => Map PackageName Version -- ^ locally available packages - -> MiniBuildPlan - -> GenericPackageDescription - -> m (Either DepErrors (Map PackageName (Map FlagName Bool))) -checkBuildPlan locals mbp gpd = do - platform <- asks (configPlatform . getConfig) - return $ loop platform flagOptions - where - packages = Map.union locals $ fmap mpiVersion $ mbpPackages mbp - loop _ [] = assert False $ Left Map.empty - loop platform (flags:rest) - | Map.null errs = Right $ - if Map.null flags - then Map.empty - else Map.singleton (packageName pkg) flags - | null rest = Left errs - | otherwise = loop platform rest - where - errs = checkDeps (packageName pkg) (packageDeps pkg) packages - pkg = resolvePackage pkgConfig gpd +gpdPackageName :: GenericPackageDescription -> PackageName +gpdPackageName = fromCabalPackageName + . C.pkgName + . C.package + . C.packageDescription + +gpdPackageDeps + :: GenericPackageDescription + -> CompilerVersion + -> Platform + -> Map FlagName Bool + -> Map PackageName VersionRange +gpdPackageDeps gpd cv platform flags = + Map.filterWithKey (const . (/= name)) (packageDependencies pkgDesc) + where + name = gpdPackageName gpd + pkgDesc = resolvePackageDescription pkgConfig gpd pkgConfig = PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True , packageConfigFlags = flags - , packageConfigCompilerVersion = compilerVersion + , packageConfigCompilerVersion = cv , packageConfigPlatform = platform } - compilerVersion = mbpCompilerVersion mbp - - flagName' = fromCabalFlagName . flagName - - -- Avoid exponential complexity in flag combinations making us sad pandas. - -- See: https://github.com/commercialhaskell/stack/issues/543 - maxFlagOptions = 128 +-- | Find the set of @FlagName@s necessary to get the given +-- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will +-- only modify non-manual flags, and will prefer default values for flags. +-- Returns the plan which produces least number of dep errors +selectPackageBuildPlan + :: Platform + -> CompilerVersion + -> Map PackageName Version + -> GenericPackageDescription + -> (Map PackageName (Map FlagName Bool), DepErrors) +selectPackageBuildPlan platform compiler pool gpd = + fromJust (go flagOptions Nothing) + where + go :: [Map FlagName Bool] -> Maybe (Map PackageName (Map FlagName Bool), DepErrors) -> Maybe (Map PackageName (Map FlagName Bool), DepErrors) + -- impossible + go [] Nothing = assert False Nothing + -- last + go [] (Just plan) = Just plan + -- got the best possible result + go _ (Just plan) | Map.null (snd plan) = Just plan + -- initial + go (flags:rest) Nothing = go rest $ Just (nextPlan flags) + -- keep looking for better results + go (flags:rest) (Just plan) = + go rest $ Just (betterPlan plan (nextPlan flags)) + + nextPlan flags = checkPackageBuildPlan platform compiler pool flags gpd + + betterPlan (f1, e1) (f2, e2) + | (Map.size e1) <= (Map.size e2) = (f1, e1) + | otherwise = (f2, e2) + + flagName' = fromCabalFlagName . flagName + + -- Avoid exponential complexity in flag combinations making us sad pandas. + -- See: https://github.com/commercialhaskell/stack/issues/543 + maxFlagOptions = 128 + + flagOptions :: [Map FlagName Bool] + flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd + getOptions f + | flagManual f = [(flagName' f, flagDefault f)] + | flagDefault f = + [ (flagName' f, True) + , (flagName' f, False) + ] + | otherwise = + [ (flagName' f, False) + , (flagName' f, True) + ] - flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd - getOptions f - | flagManual f = [(flagName' f, flagDefault f)] - | flagDefault f = - [ (flagName' f, True) - , (flagName' f, False) - ] - | otherwise = - [ (flagName' f, False) - , (flagName' f, True) - ] +-- | Check whether with the given set of flags a package's dependency +-- constraints can be satisfied against a given build plan or pool of packages. +checkPackageBuildPlan + :: Platform + -> CompilerVersion + -> Map PackageName Version + -> Map FlagName Bool + -> GenericPackageDescription + -> (Map PackageName (Map FlagName Bool), DepErrors) +checkPackageBuildPlan platform compiler pool flags gpd = + (Map.singleton pkg flags, errs) + where + pkg = gpdPackageName gpd + errs = checkPackageDeps pkg constraints pool + constraints = gpdPackageDeps gpd compiler platform flags -- | Checks if the given package dependencies can be satisfied by the given set -- of packages. Will fail if a package is either missing or has a version -- outside of the version range. -checkDeps :: PackageName -- ^ package using dependencies, for constructing DepErrors - -> Map PackageName VersionRange - -> Map PackageName Version +checkPackageDeps :: PackageName -- ^ package using dependencies, for constructing DepErrors + -> Map PackageName VersionRange -- ^ dependency constraints + -> Map PackageName Version -- ^ Available package pool or index -> DepErrors -checkDeps myName deps packages = +checkPackageDeps myName deps packages = Map.unionsWith mappend $ map go $ Map.toList deps where go :: (PackageName, VersionRange) -> DepErrors @@ -575,40 +615,108 @@ type DepErrors = Map PackageName DepError data DepError = DepError { deVersion :: !(Maybe Version) , deNeededBy :: !(Map PackageName VersionRange) - } + } deriving Show instance Monoid DepError where mempty = DepError Nothing Map.empty mappend (DepError a x) (DepError b y) = DepError (maybe a Just b) (Map.unionWith C.intersectVersionRanges x y) --- | Find a snapshot and set of flags that is compatible with the given --- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found. -findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m) - => [GenericPackageDescription] - -> [SnapName] - -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool))) -findBuildPlan gpds0 = - loop - where - loop [] = return Nothing - loop (name:names') = do - mbp <- loadMiniBuildPlan name - $logInfo $ "Checking against build plan " <> renderSnapName name - res <- mapM (checkBuildPlan localNames mbp) gpds0 - case partitionEithers res of - ([], flags) -> return $ Just (name, Map.unions flags) - (errs, _) -> do - $logInfo "" - $logInfo "* Build plan did not match your requirements:" - displayDepErrors $ Map.unionsWith mappend errs - $logInfo "" - loop names' - - localNames = Map.fromList $ map (fromCabalIdent . C.package . C.packageDescription) gpds0 - - fromCabalIdent (C.PackageIdentifier name version) = - (fromCabalPackageName name, fromCabalVersion version) +-- | Given a bundle of packages (a list of @GenericPackageDescriptions@'s) to +-- build and an available package pool (snapshot) check whether the bundle's +-- dependencies can be satisfied. If flags is passed as Nothing flag settings +-- will be chosen automatically. +checkBundleBuildPlan + :: Platform + -> CompilerVersion + -> Map PackageName Version + -> Maybe (Map PackageName (Map FlagName Bool)) + -> [GenericPackageDescription] + -> (Map PackageName (Map FlagName Bool), DepErrors) +checkBundleBuildPlan platform compiler pool flags gpds = + (Map.unionsWith dupError (map fst plans) + , Map.unionsWith mappend (map snd plans)) + + where + plans = map (pkgPlan flags) gpds + pkgPlan Nothing gpd = + selectPackageBuildPlan platform compiler pool' gpd + pkgPlan (Just f) gpd = + checkPackageBuildPlan platform compiler pool' (flags' f gpd) gpd + flags' f gpd = maybe Map.empty id (Map.lookup (gpdPackageName gpd) f) + pool' = Map.union buildPkgs pool + + buildPkgs = Map.fromList $ + map (fromCabalIdent . C.package . C.packageDescription) gpds + + fromCabalIdent (C.PackageIdentifier name version) = + (fromCabalPackageName name, fromCabalVersion version) + + dupError _ _ = error "Bug: Duplicate packages are not expected here" + +data BuildPlanCheck = + BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) + | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors + +-- | Check a set of 'GenericPackageDescription's and a set of flags against a +-- given snapshot. Returns how well the snapshot satisfies the dependencies of +-- the packages. +checkSnapBuildPlan + :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m + , HasHttpManager env, HasConfig env, HasGHCVariant env + , MonadBaseControl IO m) + => [GenericPackageDescription] + -> Maybe (Map PackageName (Map FlagName Bool)) + -> SnapName + -> m BuildPlanCheck +checkSnapBuildPlan gpds flags snap = do + platform <- asks (configPlatform . getConfig) + mbp <- loadMiniBuildPlan snap + + let + compiler = mbpCompilerVersion mbp + snapPkgs = fmap mpiVersion $ mbpPackages mbp + (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds + + if Map.null errs then + return $ BuildPlanCheckOk f + else return $ BuildPlanCheckPartial f errs + +-- | Find a snapshot and set of flags that is compatible with and matches as +-- best as possible with the given 'GenericPackageDescription's. Returns +-- 'Nothing' if no such snapshot is found. +findBuildPlan + :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m + , HasHttpManager env, HasConfig env, HasGHCVariant env + , MonadBaseControl IO m) + => [GenericPackageDescription] + -> [SnapName] + -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool))) +findBuildPlan gpds = do + loop Nothing + where + loop Nothing [] = return Nothing + loop (Just (snap, f, e)) [] + | Map.null e = return (Just (snap, f)) + | otherwise = return Nothing + loop bestYet (snap:rest) = do + $logInfo $ "Checking against build plan " <> renderSnapName snap + result <- checkSnapBuildPlan gpds Nothing snap + case result of + BuildPlanCheckOk f -> return $ Just (snap, f) + BuildPlanCheckPartial f e -> do + $logInfo "" + $logInfo "* Build plan did not match your requirements:" + displayDepErrors e + $logInfo "" + case bestYet of + Nothing -> loop (Just (snap, f, e)) rest + Just prev -> + loop (Just (betterSnap prev (snap, f, e))) rest + + betterSnap (s1, f1, e1) (s2, f2, e2) + | (Map.size e1) <= (Map.size e2) = (s1, f1, e1) + | otherwise = (s2, f2, e2) displayDepErrors :: MonadLogger m => DepErrors -> m () displayDepErrors errs = From a6ff6ddc7fa04d97e829072b7869f29101352183 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 01:38:48 +0530 Subject: [PATCH 02/29] Track dependency errors for GHC wired in packages This commit adds ability to track and distinguish build plan dependency errors related to the packages which are wired in GHC. This interface will be used to detect whether a snapshot can be used at all for building a given package. If GHC wired in packages are incompatible we cannot use the snapshot even with extra dependencies. This is not being used yet but will be used in future commits. --- src/Stack/BuildPlan.hs | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index ef93e7b5ef..181e519f49 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -44,6 +44,7 @@ import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HashSet import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (intercalate) @@ -655,7 +656,8 @@ checkBundleBuildPlan platform compiler pool flags gpds = dupError _ _ = error "Bug: Duplicate packages are not expected here" data BuildPlanCheck = - BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) + BuildPlanCheckFail CompilerVersion DepErrors + | BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors -- | Check a set of 'GenericPackageDescription's and a set of flags against a @@ -677,10 +679,22 @@ checkSnapBuildPlan gpds flags snap = do compiler = mbpCompilerVersion mbp snapPkgs = fmap mpiVersion $ mbpPackages mbp (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds + cerrs = compilerErrors compiler errs if Map.null errs then return $ BuildPlanCheckOk f - else return $ BuildPlanCheckPartial f errs + else if Map.null cerrs then do + return $ BuildPlanCheckPartial f errs + else + return $ BuildPlanCheckFail compiler cerrs + where + compilerErrors compiler errs + | whichCompiler compiler == Ghc = ghcErrors errs + -- FIXME not sure how to handle ghcjs boot packages + | otherwise = Map.empty + + isGhcWiredIn p _ = p `HashSet.member` wiredInPackages + ghcErrors = Map.filterWithKey isGhcWiredIn -- | Find a snapshot and set of flags that is compatible with and matches as -- best as possible with the given 'GenericPackageDescription's. Returns @@ -703,12 +717,12 @@ findBuildPlan gpds = do $logInfo $ "Checking against build plan " <> renderSnapName snap result <- checkSnapBuildPlan gpds Nothing snap case result of + BuildPlanCheckFail _ e -> do + logFailure e + loop bestYet rest BuildPlanCheckOk f -> return $ Just (snap, f) BuildPlanCheckPartial f e -> do - $logInfo "" - $logInfo "* Build plan did not match your requirements:" - displayDepErrors e - $logInfo "" + logFailure e case bestYet of Nothing -> loop (Just (snap, f, e)) rest Just prev -> @@ -718,6 +732,12 @@ findBuildPlan gpds = do | (Map.size e1) <= (Map.size e2) = (s1, f1, e1) | otherwise = (s2, f2, e2) + logFailure errs = do + $logInfo "" + $logInfo "* Build plan did not match your requirements:" + displayDepErrors errs + $logInfo "" + displayDepErrors :: MonadLogger m => DepErrors -> m () displayDepErrors errs = F.forM_ (Map.toList errs) $ \(depName, DepError mversion neededBy) -> do From 95a9ffeda6c13fd10081ad851f38f9c6f9bd064e Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 01:48:33 +0530 Subject: [PATCH 03/29] Improve the build plan selection error messages Provides more informative but concise error messages during stack init build plan selection process. --- src/Stack/BuildPlan.hs | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 181e519f49..7b7d04a75a 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -706,37 +706,46 @@ findBuildPlan => [GenericPackageDescription] -> [SnapName] -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool))) -findBuildPlan gpds = do - loop Nothing +findBuildPlan gpds snaps = do + $logInfo $ "Selecting the best among " + <> T.pack (show (length snaps)) + <> " snapshots...\n" + loop Nothing snaps where loop Nothing [] = return Nothing loop (Just (snap, f, e)) [] | Map.null e = return (Just (snap, f)) | otherwise = return Nothing loop bestYet (snap:rest) = do - $logInfo $ "Checking against build plan " <> renderSnapName snap result <- checkSnapBuildPlan gpds Nothing snap + reportResult result snap case result of - BuildPlanCheckFail _ e -> do - logFailure e - loop bestYet rest + BuildPlanCheckFail _ _ -> loop bestYet rest BuildPlanCheckOk f -> return $ Just (snap, f) BuildPlanCheckPartial f e -> do - logFailure e case bestYet of Nothing -> loop (Just (snap, f, e)) rest Just prev -> loop (Just (betterSnap prev (snap, f, e))) rest betterSnap (s1, f1, e1) (s2, f2, e2) - | (Map.size e1) <= (Map.size e2) = (s1, f1, e1) - | otherwise = (s2, f2, e2) + | (Map.size e1) <= (Map.size e2) = (s1, f1, e1) + | otherwise = (s2, f2, e2) - logFailure errs = do - $logInfo "" - $logInfo "* Build plan did not match your requirements:" + reportResult (BuildPlanCheckOk _) snap = + $logInfo $ "* Selected " <> renderSnapName snap + + reportResult (BuildPlanCheckPartial _ errs) snap = do + $logWarn $ "* Partially matches " <> renderSnapName snap + displayDepErrors errs + + reportResult (BuildPlanCheckFail compiler errs) snap = do + $logWarn $ "* Rejected " + <> renderSnapName snap + <> " due to conflicting compiler (" + <> compilerVersionText compiler + <> ") requirements" displayDepErrors errs - $logInfo "" displayDepErrors :: MonadLogger m => DepErrors -> m () displayDepErrors errs = From 6b0c4d01d748fb80dd050e547f804a95f71b17e2 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 03:01:27 +0530 Subject: [PATCH 04/29] Allow solver to be used with any resolver Currently stack init --solver cannot be used with a specific resolver. It just uses the GHC on your path and provides a compiler resolver corresponding to that GHC and all deps are extra deps. Instead, we want to be able to use a specific snapshot and only deps not matching the snapshot should be extra deps. This commit is a step towards that goal. 1) '--solver' is now a switch which can be used along with a resolver. 'stack init --resolver lts-2.22 --solver' will now be a valid init command. 2) Snapshot selector now returns the snapshot with least number of dependency errors as a partial match. This snapshot is to be used by the solver. Note that the solver is not yet changed to work on an existing snapshot. That will come in a future commit. 3) We now report an explicit error when the specified resolver does not have a compiler compatible with the package dependencies. 4) Note a behavior change for the 'stack init --resolver' command. Earlier it used to write the stack.yaml file even if it did not successully resolve all packages. Now it will fail in that case and suggest '--solver' to resolve the extra dependencies. 5) Separate the snapshot selection interface from the snapshot dependency check interface. 6) Some error message reporting changes. --- src/Stack/BuildPlan.hs | 28 ++++++------- src/Stack/Init.hs | 84 +++++++++++++++++++++++---------------- src/Stack/Options.hs | 13 +++--- src/Stack/Types/Config.hs | 32 +++++++++------ 4 files changed, 88 insertions(+), 69 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 7b7d04a75a..1bf5a363dd 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -11,13 +11,15 @@ module Stack.BuildPlan ( BuildPlanException (..) + , BuildPlanCheck (..) + , checkSnapBuildPlan , MiniBuildPlan(..) , MiniPackageInfo(..) , Snapshots (..) , getSnapshots , loadMiniBuildPlan , resolveBuildPlan - , findBuildPlan + , selectBestSnapshot , ToolMap , getToolMap , shadowMiniBuildPlan @@ -699,38 +701,36 @@ checkSnapBuildPlan gpds flags snap = do -- | Find a snapshot and set of flags that is compatible with and matches as -- best as possible with the given 'GenericPackageDescription's. Returns -- 'Nothing' if no such snapshot is found. -findBuildPlan +selectBestSnapshot :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env , MonadBaseControl IO m) => [GenericPackageDescription] -> [SnapName] - -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool))) -findBuildPlan gpds snaps = do + -> m (Maybe SnapName) +selectBestSnapshot gpds snaps = do $logInfo $ "Selecting the best among " <> T.pack (show (length snaps)) <> " snapshots...\n" loop Nothing snaps where loop Nothing [] = return Nothing - loop (Just (snap, f, e)) [] - | Map.null e = return (Just (snap, f)) - | otherwise = return Nothing + loop (Just (snap, _)) [] = return $ Just snap loop bestYet (snap:rest) = do result <- checkSnapBuildPlan gpds Nothing snap reportResult result snap case result of BuildPlanCheckFail _ _ -> loop bestYet rest - BuildPlanCheckOk f -> return $ Just (snap, f) - BuildPlanCheckPartial f e -> do + BuildPlanCheckOk _ -> return $ Just snap + BuildPlanCheckPartial _ e -> do case bestYet of - Nothing -> loop (Just (snap, f, e)) rest + Nothing -> loop (Just (snap, e)) rest Just prev -> - loop (Just (betterSnap prev (snap, f, e))) rest + loop (Just (betterSnap prev (snap, e))) rest - betterSnap (s1, f1, e1) (s2, f2, e2) - | (Map.size e1) <= (Map.size e2) = (s1, f1, e1) - | otherwise = (s2, f2, e2) + betterSnap (s1, e1) (s2, e2) + | (Map.size e1) <= (Map.size e2) = (s1, e1) + | otherwise = (s2, e2) reportResult (BuildPlanCheckOk _) snap = $logInfo $ "* Selected " <> renderSnapName snap diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index a4fd92b781..41a2a3865c 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -188,43 +188,55 @@ getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, -> [C.GenericPackageDescription] -- ^ cabal descriptions -> InitOpts -> m (Resolver, Map PackageName (Map FlagName Bool), Map PackageName Version) -getDefaultResolver cabalfps gpds initOpts = - case ioMethod initOpts of - MethodSnapshot snapPref -> do - msnapshots <- getSnapshots' - names <- - case msnapshots of - Nothing -> return [] - Just snapshots -> getRecommendedSnapshots snapshots snapPref - mpair <- findBuildPlan gpds names - case mpair of - Just (snap, flags) -> - return (ResolverSnapshot snap, flags, Map.empty) - Nothing -> throwM $ NoMatchingSnapshot names - MethodResolver aresolver -> do - resolver <- makeConcreteResolver aresolver - mpair <- - case resolver of - ResolverSnapshot name -> findBuildPlan gpds [name] - ResolverCompiler _ -> return Nothing - ResolverCustom _ _ -> return Nothing - case mpair of - Just (snap, flags) -> - return (ResolverSnapshot snap, flags, Map.empty) - Nothing -> return (resolver, Map.empty, Map.empty) - MethodSolver -> do - (compilerVersion, extraDeps) <- cabalSolver Ghc (map parent cabalfps) Map.empty Map.empty [] - return - ( ResolverCompiler compilerVersion - , Map.filter (not . Map.null) $ fmap snd extraDeps - , fmap fst extraDeps - ) +getDefaultResolver cabalfps gpds initOpts = do + resolver <- getResolver (ioMethod initOpts) + result <- checkResolverSpec gpds Nothing resolver + + case result of + BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver + BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) + BuildPlanCheckPartial _ _ + | needSolver resolver initOpts -> do + (compilerVersion, extraDeps) <- cabalSolver Ghc (map parent cabalfps) Map.empty Map.empty [] + return + ( ResolverCompiler compilerVersion + , Map.filter (not . Map.null) $ fmap snd extraDeps + , fmap fst extraDeps + ) + | otherwise -> throwM $ ResolverPartial resolver + where + -- TODO support selecting best across regular and custom snapshots + getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref + getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver + + selectSnapResolver snapPref = + getSnapshots' + >>= maybe (throwM NoMatchingSnapshot) + (getRecommendedSnapshots snapPref) + >>= selectBestSnapshot gpds + >>= maybe (throwM NoMatchingSnapshot) + (\s -> do + $logInfo ("Selected snapshot '" + <> (renderSnapName s) + <> "'.") + return $ ResolverSnapshot s) + + checkResolverSpec packages flags resolver = do + case resolver of + ResolverSnapshot name -> checkSnapBuildPlan packages flags name + ResolverCompiler _ -> return $ BuildPlanCheckPartial Map.empty Map.empty + -- TODO support custom resolver for stack init + ResolverCustom _ _ -> return $ BuildPlanCheckPartial Map.empty Map.empty + + needSolver _ (InitOpts {useSolver = True}) = True + needSolver (ResolverCompiler _) _ = True + needSolver _ _ = False getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) - => Snapshots - -> SnapPref + => SnapPref + -> Snapshots -> m [SnapName] -getRecommendedSnapshots snapshots pref = do +getRecommendedSnapshots pref snapshots = do -- Get the most recent LTS and Nightly in the snapshots directory and -- prefer them over anything else, since odds are high that something -- already exists for them. @@ -256,6 +268,8 @@ getRecommendedSnapshots snapshots pref = do data InitOpts = InitOpts { ioMethod :: !Method + -- ^ Use solver + , useSolver :: Bool -- ^ Preferred snapshots , forceOverwrite :: Bool -- ^ Overwrite existing files @@ -266,7 +280,7 @@ data InitOpts = InitOpts data SnapPref = PrefNone | PrefLTS | PrefNightly -- | Method of initializing -data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver | MethodSolver +data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver -- | Turn an 'AbstractResolver' into a 'Resolver'. makeConcreteResolver :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadLogger m) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 2810364f53..9fbc471714 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -670,20 +670,17 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts initOptsParser :: Parser InitOpts initOptsParser = - InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs + InitOpts <$> method <*> solver <*> overwrite <*> fmap not ignoreSubDirs where ignoreSubDirs = switch (long "ignore-subdirs" <> help "Do not search for .cabal files in sub directories") overwrite = switch (long "force" <> help "Force overwriting of an existing stack.yaml if it exists") - method = solver - <|> (MethodResolver <$> resolver) - <|> (MethodSnapshot <$> snapPref) + solver = switch (long "solver" <> + help "Use a dependency solver to determine extra dependencies") - solver = - flag' MethodSolver - (long "solver" <> - help "Use a dependency solver to determine dependencies") + method = (MethodResolver <$> resolver) + <|> (MethodSnapshot <$> snapPref) snapPref = flag' PrefLTS diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index cc7caecb5e..f42e8a270d 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1074,7 +1074,9 @@ data ConfigException | NoProjectConfigFound (Path Abs Dir) (Maybe Text) | UnexpectedTarballContents [Path Abs Dir] [Path Abs File] | BadStackVersionException VersionRange - | NoMatchingSnapshot [SnapName] + | NoMatchingSnapshot + | ResolverMismatch Resolver + | ResolverPartial Resolver | NoSuchDirectory FilePath | ParseGHCVariantException String deriving Typeable @@ -1114,17 +1116,23 @@ instance Show ConfigException where ,"version range specified in stack.yaml (" , T.unpack (versionRangeText requiredRange) , ")." ] - show (NoMatchingSnapshot names) = concat - [ "There was no snapshot found that matched the package " - , "bounds in your .cabal files.\n" - , "Please choose one of the following commands to get started.\n\n" - , unlines $ map - (\name -> " stack init --resolver " ++ T.unpack (renderSnapName name)) - names - , "\nYou'll then need to add some extra-deps. See:\n\n" - , " http://docs.haskellstack.org/en/stable/yaml_configuration.html#extra-deps" - , "\n\nYou can also try falling back to a dependency solver with:\n\n" - , " stack init --solver" + show NoMatchingSnapshot = concat + [ "No snapshot is 'compiler compatible' with the package " + , "constraints specified in your .cabal files.\n" + ] + show (ResolverMismatch resolver) = concat + [ "Selected resolver '" + , T.unpack (resolverName resolver) + , "' is not 'compiler compatible' with the package " + , "constraints specified in your .cabal files.\n" + ] + show (ResolverPartial resolver) = concat + [ "Resolver '" + , T.unpack (resolverName resolver) + , "' does not satisfy all the package " + , "requirements and constraints specified in your .cabal files.\n\n" + , "However, you can use the '--solver' command line switch to resolve " + , "the constraints using external packages." ] show (NoSuchDirectory dir) = concat ["No directory could be located matching the supplied path: " From 643e24b12f22572031f61b90c45272550cc53701 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 12:17:56 +0530 Subject: [PATCH 05/29] Reverse dependency between Init and Config modules Need to import Stack.Setup in Stack.Solver to be able to use ensureCompiler which creates a dependency cycle. The cycle can be fixed by making Init depend on Config instead of the opposite. This commit only includes the code movement due to the above. There are no functionality changes. --- src/Stack/BuildPlan.hs | 41 +---------------- src/Stack/Config.hs | 89 ++++++++++++++++++++++++++++++++++-- src/Stack/ConfigCmd.hs | 2 +- src/Stack/Init.hs | 85 ++-------------------------------- src/Stack/Types/BuildPlan.hs | 31 +++++++++++++ 5 files changed, 123 insertions(+), 125 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 1bf5a363dd..7fefcfda27 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -15,8 +15,6 @@ module Stack.BuildPlan , checkSnapBuildPlan , MiniBuildPlan(..) , MiniPackageInfo(..) - , Snapshots (..) - , getSnapshots , loadMiniBuildPlan , resolveBuildPlan , selectBestSnapshot @@ -37,7 +35,7 @@ import Control.Monad.State.Strict (State, execState, get, modify, put) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 -import Data.Aeson.Extended (FromJSON (..), withObject, withText, (.:), (.:?), (.!=)) +import Data.Aeson.Extended (FromJSON (..), withObject, (.:), (.:?), (.!=)) import Data.Binary.VersionTagged (taggedDecodeOrLoad) import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16 @@ -45,10 +43,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) import qualified Data.Foldable as F -import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map @@ -59,7 +54,6 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Time (Day) import qualified Data.Traversable as Tr import Data.Typeable (Typeable) import Data.Yaml (decodeEither', decodeFileEither) @@ -396,39 +390,6 @@ getToolMap mbp = $ Set.toList $ mpiExes mpi --- | Download the 'Snapshots' value from stackage.org. -getSnapshots :: (MonadThrow m, MonadIO m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env) - => m Snapshots -getSnapshots = askLatestSnapshotUrl >>= parseUrl . T.unpack >>= downloadJSON - --- | Most recent Nightly and newest LTS version per major release. -data Snapshots = Snapshots - { snapshotsNightly :: !Day - , snapshotsLts :: !(IntMap Int) - } - deriving Show -instance FromJSON Snapshots where - parseJSON = withObject "Snapshots" $ \o -> Snapshots - <$> (o .: "nightly" >>= parseNightly) - <*> (fmap IntMap.unions - $ mapM (parseLTS . snd) - $ filter (isLTS . fst) - $ HM.toList o) - where - parseNightly t = - case parseSnapName t of - Left e -> fail $ show e - Right (LTS _ _) -> fail "Unexpected LTS value" - Right (Nightly d) -> return d - - isLTS = ("lts-" `T.isPrefixOf`) - - parseLTS = withText "LTS" $ \t -> - case parseSnapName t of - Left e -> fail $ show e - Right (LTS x y) -> return $ IntMap.singleton x y - Right (Nightly _) -> fail "Unexpected nightly value" - -- | Load up a 'MiniBuildPlan', preferably from cache loadMiniBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 7afaf934b5..151da4d682 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -28,17 +28,20 @@ module Stack.Config ,resolvePackageEntry ,getImplicitGlobalProjectDir ,getIsGMP4 + ,getSnapshots + ,makeConcreteResolver ) where import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Arrow ((***)) +import Control.Exception (assert) import Control.Monad import Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM) import Control.Monad.IO.Class import Control.Monad.Logger hiding (Loc) -import Control.Monad.Reader (MonadReader, ask, runReaderT) +import Control.Monad.Reader (MonadReader, ask, asks, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson.Extended @@ -58,7 +61,7 @@ import qualified Distribution.Text import Distribution.Version (simplifyVersionRange) import GHC.Conc (getNumProcessors) import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl) -import Network.HTTP.Download (download) +import Network.HTTP.Download (download, downloadJSON) import Options.Applicative (Parser, strOption, long, help) import Path import Path.Extra (toFilePathNoTrailingSep) @@ -70,7 +73,6 @@ import Stack.Config.Docker import Stack.Config.Nix import Stack.Constants import qualified Stack.Image as Image -import Stack.Init import Stack.PackageIndex import Stack.Types import Stack.Types.Internal @@ -79,6 +81,87 @@ import System.Environment import System.IO import System.Process.Read +-- | If deprecated path exists, use it and print a warning. +-- Otherwise, return the new path. +tryDeprecatedPath + :: (MonadIO m, MonadLogger m) + => Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed) + -> (Path Abs a -> m Bool) -- ^ Test for existence + -> Path Abs a -- ^ New path + -> Path Abs a -- ^ Deprecated path + -> m (Path Abs a, Bool) -- ^ (Path to use, whether it already exists) +tryDeprecatedPath mWarningDesc exists new old = do + newExists <- exists new + if newExists + then return (new, True) + else do + oldExists <- exists old + if oldExists + then do + case mWarningDesc of + Nothing -> return () + Just desc -> + $logWarn $ T.concat + [ "Warning: Location of ", desc, " at '" + , T.pack (toFilePath old) + , "' is deprecated; rename it to '" + , T.pack (toFilePath new) + , "' instead" ] + return (old, True) + else return (new, False) + +-- | Get the location of the implicit global project directory. +-- If the directory already exists at the deprecated location, its location is returned. +-- Otherwise, the new location is returned. +getImplicitGlobalProjectDir + :: (MonadIO m, MonadLogger m) + => Config -> m (Path Abs Dir) +getImplicitGlobalProjectDir config = + --TEST no warning printed + liftM fst $ tryDeprecatedPath + Nothing + dirExists + (implicitGlobalProjectDir stackRoot) + (implicitGlobalProjectDirDeprecated stackRoot) + where + stackRoot = configStackRoot config + +-- | Download the 'Snapshots' value from stackage.org. +getSnapshots :: (MonadThrow m, MonadIO m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env) + => m Snapshots +getSnapshots = askLatestSnapshotUrl >>= parseUrl . T.unpack >>= downloadJSON + +-- | Turn an 'AbstractResolver' into a 'Resolver'. +makeConcreteResolver :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadLogger m) + => AbstractResolver + -> m Resolver +makeConcreteResolver (ARResolver r) = return r +makeConcreteResolver ar = do + snapshots <- getSnapshots + r <- + case ar of + ARResolver r -> assert False $ return r + ARGlobal -> do + config <- asks getConfig + implicitGlobalDir <- getImplicitGlobalProjectDir config + let fp = implicitGlobalDir stackDotYaml + (ProjectAndConfigMonoid project _, _warnings) <- + liftIO (Yaml.decodeFileEither $ toFilePath fp) + >>= either throwM return + return $ projectResolver project + ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots + ARLatestLTSMajor x -> + case IntMap.lookup x $ snapshotsLts snapshots of + Nothing -> error $ "No LTS release found with major version " ++ show x + Just y -> return $ ResolverSnapshot $ LTS x y + ARLatestLTS + | IntMap.null $ snapshotsLts snapshots -> error "No LTS releases found" + | otherwise -> + let (x, y) = IntMap.findMax $ snapshotsLts snapshots + in return $ ResolverSnapshot $ LTS x y + $logInfo $ "Selected resolver: " <> resolverName r + return r + -- | Get the latest snapshot resolver available. getLatestResolver :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 987845583f..ec83546155 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -21,7 +21,7 @@ import qualified Data.Yaml as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Stack.BuildPlan -import Stack.Init +import Stack.Config (makeConcreteResolver) import Stack.Types data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 41a2a3865c..2417b8c321 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -8,18 +8,15 @@ module Stack.Init , InitOpts (..) , SnapPref (..) , Method (..) - , makeConcreteResolver - , tryDeprecatedPath - , getImplicitGlobalProjectDir ) where import Control.Exception (assert) import Control.Exception.Enclosed (catchAny, handleIO) import Control.Monad (liftM, when, zipWithM_) -import Control.Monad.Catch (MonadMask, MonadThrow, throwM) +import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as L @@ -47,6 +44,8 @@ import Stack.Package import Stack.Solver import Stack.Types import System.Directory (getDirectoryContents) +import Stack.Config ( getSnapshots + , makeConcreteResolver) findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File] findCabalFiles recurse dir = @@ -281,79 +280,3 @@ data SnapPref = PrefNone | PrefLTS | PrefNightly -- | Method of initializing data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver - --- | Turn an 'AbstractResolver' into a 'Resolver'. -makeConcreteResolver :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadLogger m) - => AbstractResolver - -> m Resolver -makeConcreteResolver (ARResolver r) = return r -makeConcreteResolver ar = do - snapshots <- getSnapshots - r <- - case ar of - ARResolver r -> assert False $ return r - ARGlobal -> do - config <- asks getConfig - implicitGlobalDir <- getImplicitGlobalProjectDir config - let fp = implicitGlobalDir stackDotYaml - (ProjectAndConfigMonoid project _, _warnings) <- - liftIO (Yaml.decodeFileEither $ toFilePath fp) - >>= either throwM return - return $ projectResolver project - ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots - ARLatestLTSMajor x -> - case IntMap.lookup x $ snapshotsLts snapshots of - Nothing -> error $ "No LTS release found with major version " ++ show x - Just y -> return $ ResolverSnapshot $ LTS x y - ARLatestLTS - | IntMap.null $ snapshotsLts snapshots -> error "No LTS releases found" - | otherwise -> - let (x, y) = IntMap.findMax $ snapshotsLts snapshots - in return $ ResolverSnapshot $ LTS x y - $logInfo $ "Selected resolver: " <> resolverName r - return r - --- | Get the location of the implicit global project directory. --- If the directory already exists at the deprecated location, its location is returned. --- Otherwise, the new location is returned. -getImplicitGlobalProjectDir - :: (MonadIO m, MonadLogger m) - => Config -> m (Path Abs Dir) -getImplicitGlobalProjectDir config = - --TEST no warning printed - liftM fst $ tryDeprecatedPath - Nothing - dirExists - (implicitGlobalProjectDir stackRoot) - (implicitGlobalProjectDirDeprecated stackRoot) - where - stackRoot = configStackRoot config - --- | If deprecated path exists, use it and print a warning. --- Otherwise, return the new path. -tryDeprecatedPath - :: (MonadIO m, MonadLogger m) - => Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed) - -> (Path Abs a -> m Bool) -- ^ Test for existence - -> Path Abs a -- ^ New path - -> Path Abs a -- ^ Deprecated path - -> m (Path Abs a, Bool) -- ^ (Path to use, whether it already exists) -tryDeprecatedPath mWarningDesc exists new old = do - newExists <- exists new - if newExists - then return (new, True) - else do - oldExists <- exists old - if oldExists - then do - case mWarningDesc of - Nothing -> return () - Just desc -> - $logWarn $ T.concat - [ "Warning: Location of ", desc, " at '" - , T.pack (toFilePath old) - , "' is deprecated; rename it to '" - , T.pack (toFilePath new) - , "' instead" ] - return (old, True) - else return (new, False) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 85cc1782b4..f44f7593d2 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -15,6 +15,7 @@ module Stack.Types.BuildPlan , Maintainer (..) , ExeName (..) , SimpleDesc (..) + , Snapshots (..) , DepInfo (..) , Component (..) , SnapName (..) @@ -34,6 +35,8 @@ import Data.Aeson (FromJSON (..), ToJSON (..), import Data.Binary.VersionTagged import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -359,6 +362,34 @@ parseSnapName t0 = t1 <- T.stripPrefix "nightly-" t0 Nightly <$> readMay (T.unpack t1) +-- | Most recent Nightly and newest LTS version per major release. +data Snapshots = Snapshots + { snapshotsNightly :: !Day + , snapshotsLts :: !(IntMap Int) + } + deriving Show +instance FromJSON Snapshots where + parseJSON = withObject "Snapshots" $ \o -> Snapshots + <$> (o .: "nightly" >>= parseNightly) + <*> (fmap IntMap.unions + $ mapM (parseLTS . snd) + $ filter (isLTS . fst) + $ HashMap.toList o) + where + parseNightly t = + case parseSnapName t of + Left e -> fail $ show e + Right (LTS _ _) -> fail "Unexpected LTS value" + Right (Nightly d) -> return d + + isLTS = ("lts-" `T.isPrefixOf`) + + parseLTS = withText "LTS" $ \t -> + case parseSnapName t of + Left e -> fail $ show e + Right (LTS x y) -> return $ IntMap.singleton x y + Right (Nightly _) -> fail "Unexpected nightly value" + instance ToJSON a => ToJSON (Map ExeName a) where toJSON = toJSON . Map.mapKeysWith const unExeName instance FromJSON a => FromJSON (Map ExeName a) where From 434e300eb110f4941ec6afb2647151e884c42108 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 19:17:49 +0530 Subject: [PATCH 06/29] Ensure, use specified compiler for new/init/solver This commit introduces the following enahncements: 1) Support --install-ghc for stack new/init/solver commands 2) init or solver will now use the correct compiler specified in the resolver on command line during init or in stack.yaml when using the solver command. Before this change solver used the compiler found on path disregarding any configuration settings (for stack solver) or the snapshot chosen (for stack init) or the resolver specified on command line. Note that even with this change stack init --solver still returns a compiler resolver with all deps as extra-deps. Using a snapshot resolver with minimal extra-deps is a matter of a future commit. Fixes #1529 --- src/Stack/Init.hs | 45 +++++---- src/Stack/Setup.hs | 2 + src/Stack/Setup/Installed.hs | 2 +- src/Stack/Solver.hs | 183 +++++++++++++++++++++++++---------- src/Stack/Types/Build.hs | 10 -- src/main/Main.hs | 31 +++--- 6 files changed, 179 insertions(+), 94 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 2417b8c321..5139cf4a46 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -43,6 +43,8 @@ import Stack.Constants import Stack.Package import Stack.Solver import Stack.Types +import Stack.Types.Internal ( HasTerminal, HasReExec + , HasLogLevel) import System.Directory (getDirectoryContents) import Stack.Config ( getSnapshots , makeConcreteResolver) @@ -64,10 +66,14 @@ ignoredDirs = Set.fromList ] -- | Generate stack.yaml -initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) - => Path Abs Dir - -> InitOpts - -> m () +initProject + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => Path Abs Dir + -> InitOpts + -> m () initProject currDir initOpts = do let dest = currDir stackDotYaml dest' = toFilePath dest @@ -87,7 +93,7 @@ initProject currDir initOpts = do (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings - (r, flags, extraDeps) <- getDefaultResolver cabalfps gpds initOpts + (r, flags, extraDeps) <- getDefaultResolver dest cabalfps gpds initOpts let p = Project { projectPackages = pkgs , projectExtraDeps = extraDeps @@ -182,12 +188,19 @@ getSnapshots' = return Nothing -- | Get the default resolver value -getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) - => [Path Abs File] -- ^ cabal files - -> [C.GenericPackageDescription] -- ^ cabal descriptions - -> InitOpts - -> m (Resolver, Map PackageName (Map FlagName Bool), Map PackageName Version) -getDefaultResolver cabalfps gpds initOpts = do +getDefaultResolver + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => Path Abs File -- ^ stack.yaml + -> [Path Abs File] -- ^ cabal dirs + -> [C.GenericPackageDescription] -- ^ cabal descriptions + -> InitOpts + -> m ( Resolver + , Map PackageName (Map FlagName Bool) + , Map PackageName Version) +getDefaultResolver stackYaml cabalfps gpds initOpts = do resolver <- getResolver (ioMethod initOpts) result <- checkResolverSpec gpds Nothing resolver @@ -195,13 +208,9 @@ getDefaultResolver cabalfps gpds initOpts = do BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) BuildPlanCheckPartial _ _ - | needSolver resolver initOpts -> do - (compilerVersion, extraDeps) <- cabalSolver Ghc (map parent cabalfps) Map.empty Map.empty [] - return - ( ResolverCompiler compilerVersion - , Map.filter (not . Map.null) $ fmap snd extraDeps - , fmap fst extraDeps - ) + | needSolver resolver initOpts -> + solveResolverSpec stackYaml (map parent cabalfps) + (resolver, Map.empty, Map.empty) | otherwise -> throwM $ ResolverPartial resolver where -- TODO support selecting best across regular and custom snapshots diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index dbc26c5267..8b38ecaf80 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -16,8 +16,10 @@ module Stack.Setup ( setupEnv , ensureCompiler , ensureDockerStackExe + , getSystemCompiler , SetupOpts (..) , defaultStackSetupYaml + , removeHaskellEnvVars ) where import Control.Applicative diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 2ba12b2f95..5840ae8afe 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -152,7 +152,7 @@ data ExtraDirs = ExtraDirs { edBins :: ![FilePath] , edInclude :: ![FilePath] , edLib :: ![FilePath] - } + } deriving (Show) instance Monoid ExtraDirs where mempty = ExtraDirs [] [] [] mappend (ExtraDirs a b c) (ExtraDirs x y z) = ExtraDirs diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index c940737e1d..2b669dd47e 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -3,8 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Stack.Solver - ( cabalSolver - , solveExtraDeps + ( solveExtraDeps + , solveResolverSpec ) where import Control.Applicative @@ -30,8 +30,12 @@ import Path import Path.IO (parseRelAsAbsDir) import Prelude import Stack.BuildPlan +import Stack.Setup import Stack.Setup.Installed import Stack.Types +import Stack.Types.Internal ( HasTerminal + , HasReExec + , HasLogLevel) import System.Directory (copyFile, createDirectoryIfMissing, getTemporaryDirectory) @@ -40,45 +44,17 @@ import System.IO.Temp (withSystemTempDirectory) import System.Process.Read cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env) - => WhichCompiler + => EnvOverride -> [Path Abs Dir] -- ^ cabal files -> Map PackageName Version -- ^ constraints -> Map PackageName (Map FlagName Bool) -- ^ user-specified flags -> [String] -- ^ additional arguments - -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool)) -cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do - when (null cabalfps) $ throwM SolverNoCabalFiles + -> m (Map PackageName (Version, Map FlagName Bool)) +cabalSolver menv cabalfps constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do configLines <- getCabalConfig dir constraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines - menv0 <- getMinimalEnvOverride - mghc <- findExecutable menv0 "ghc" - platform <- asks getPlatform - menv <- - case mghc of - Just _ -> return menv0 - Nothing -> do - localPrograms <- asks $ configLocalPrograms . getConfig - tools <- listInstalled localPrograms - let ghcName = $(mkPackageName "ghc") - case [version | Tool (PackageIdentifier name version) <- tools, name == ghcName] of - [] -> throwM SolverMissingGHC - versions -> do - let version = maximum versions - $logInfo $ "No GHC on path, selecting: " <> - T.pack (versionString version) - ed <- extraDirs $ Tool $ PackageIdentifier ghcName version - pathsEnv <- augmentPathMap (edBins ed) - (unEnvOverride menv0) - mkEnvOverride platform pathsEnv - mcabal <- findExecutable menv "cabal" - case mcabal of - Nothing -> throwM SolverMissingCabalInstall - Just _ -> return () - - compilerVersion <- getCompilerVersion menv wc - -- Run from a temporary directory to avoid cabal getting confused by any -- sandbox files, see: -- https://github.com/commercialhaskell/stack/issues/356 @@ -100,22 +76,18 @@ cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirector : "--package-db=global" : cabalArgs ++ toConstraintArgs userFlags ++ - fmap toFilePath cabalfps ++ - ["--ghcjs" | wc == Ghcjs] + fmap toFilePath cabalfps $logInfo "Asking cabal to calculate a build plan, please wait" - menv' <- mkEnvOverride platform - $ Map.delete "GHCJS_PACKAGE_PATH" - $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv - bs <- readProcessStdout (Just tmpdir) menv' "cabal" args + bs <- readProcessStdout (Just tmpdir) menv "cabal" args let ls = drop 1 $ dropWhile (not . T.isPrefixOf "In order, ") $ T.lines $ decodeUtf8 bs (errs, pairs) = partitionEithers $ map parseLine ls if null errs - then return (compilerVersion, Map.fromList pairs) + then return (Map.fromList pairs) else error $ "Could not parse cabal-install output: " ++ show errs where parseLine t0 = maybe (Left t0) Right $ do @@ -174,13 +146,120 @@ getCabalConfig dir constraints = do , T.pack $ versionString version ] +setupCompiler + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => CompilerVersion + -> m (Maybe ExtraDirs) +setupCompiler compiler = do + let msg = Just $ T.concat + [ "Compiler version (" <> compilerVersionText compiler <> ") " + , "required by your resolver specification cannot be found.\n\n" + , "Please use '--install-ghc' command line switch to automatically " + , "install the compiler or '--system-ghc' to use a suitable " + , "compiler available on your PATH." ] + + config <- asks getConfig + mpaths <- ensureCompiler SetupOpts + { soptsInstallIfMissing = configInstallGHC config + , soptsUseSystem = configSystemGHC config + , soptsWantedCompiler = compiler + , soptsCompilerCheck = configCompilerCheck config + + , soptsStackYaml = Nothing + , soptsForceReinstall = False + , soptsSanityCheck = False + , soptsSkipGhcCheck = False + , soptsSkipMsys = configSkipMsys config + , soptsUpgradeCabal = False + , soptsResolveMissingGHC = msg + , soptsStackSetupYaml = defaultStackSetupYaml + , soptsGHCBindistURL = Nothing + } + + return mpaths + +setupCabalEnv + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => CompilerVersion + -> m EnvOverride +setupCabalEnv compiler = do + mpaths <- setupCompiler compiler + menv0 <- getMinimalEnvOverride + envMap <- removeHaskellEnvVars + <$> augmentPathMap (maybe [] edBins mpaths) + (unEnvOverride menv0) + platform <- asks getPlatform + menv <- mkEnvOverride platform envMap + + mcabal <- findExecutable menv "cabal" + case mcabal of + Nothing -> throwM SolverMissingCabalInstall + Just _ -> return () + + mver <- getSystemCompiler menv (whichCompiler compiler) + case mver of + Just (version, _) -> + $logInfo $ "Solver: using compiler " <> compilerVersionText version + Nothing -> error "Failed to determine compiler version. \ + \This is most likely a bug." + return menv + +solveResolverSpec + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => Path Abs File -- ^ stack.yaml file location + -> [Path Abs Dir] -- ^ package dirs containing cabal files + -> ( Resolver + , Map PackageName (Map FlagName Bool) + , Map PackageName Version) + -> m ( Resolver + , Map PackageName (Map FlagName Bool) + , Map PackageName Version) +solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do + compilerVer <- getResolverCompiler resolver + menv <- setupCabalEnv compilerVer + extraDeps <- cabalSolver menv cabalDirs extraPackages flags $ + ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs] + return + ( ResolverCompiler compilerVer + , Map.filter (not . Map.null) $ fmap snd extraDeps + , fmap fst extraDeps + ) + + where + getResolverCompiler (ResolverSnapshot snapName) = do + mbp <- loadMiniBuildPlan snapName + return (mbpCompilerVersion mbp) + + getResolverCompiler (ResolverCompiler compiler) = + return compiler + + -- FIXME instead of passing the stackYaml dir we should maintain + -- the file URL in the custom resolver always relative to stackYaml. + getResolverCompiler (ResolverCustom _ url) = do + mbp <- parseCustomMiniBuildPlan stackYaml url + return (mbpCompilerVersion mbp) + -- | Determine missing extra-deps -solveExtraDeps :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env) - => Bool -- ^ modify stack.yaml? - -> m () +solveExtraDeps + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasEnvConfig env, HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => Bool -- ^ modify stack.yaml? + -> m () solveExtraDeps modStackYaml = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig + let stackYaml = bcStackYaml bconfig snapshot <- case bcResolver bconfig of ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName @@ -193,16 +272,14 @@ solveExtraDeps modStackYaml = do (bcExtraDeps bconfig) (mpiVersion <$> snapshot) - wc <- getWhichCompiler - (_compilerVersion, extraDeps) <- cabalSolver - wc - (Map.keys $ envConfigPackages econfig) - packages - (bcFlags bconfig) - [] + (_, flags, extraDeps) <- solveResolverSpec stackYaml + (Map.keys $ envConfigPackages econfig) + (bcResolver bconfig, + (bcFlags bconfig), + packages) let newDeps = extraDeps `Map.difference` packages - newFlags = Map.filter (not . Map.null) $ fmap snd newDeps + newFlags = Map.filter (not . Map.null) $ flags $logInfo "This command is not guaranteed to give you a perfect build plan" if Map.null newDeps @@ -210,7 +287,7 @@ solveExtraDeps modStackYaml = do else do $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking" let o = object - $ ("extra-deps" .= map fromTuple (Map.toList $ fmap fst newDeps)) + $ ("extra-deps" .= map fromTuple (Map.toList newDeps)) : (if Map.null newFlags then [] else ["flags" .= newFlags]) @@ -226,7 +303,7 @@ solveExtraDeps modStackYaml = do let obj' = HashMap.insert "extra-deps" (toJSON $ map fromTuple $ Map.toList - $ Map.union (projectExtraDeps project) (fmap fst newDeps)) + $ Map.union (projectExtraDeps project) newDeps) $ HashMap.insert ("flags" :: Text) (toJSON $ Map.union (projectFlags project) newFlags) obj diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index b0c4756fcc..71c16f2df0 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -121,8 +121,6 @@ data StackBuildException | TargetParseException [Text] | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])] | SolverMissingCabalInstall - | SolverMissingGHC - | SolverNoCabalFiles | SomeTargetsNotBuildable [(PackageName, NamedComponent)] deriving Typeable @@ -326,14 +324,6 @@ instance Show StackBuildException where [ "Solver requires that cabal be on your PATH" , "Try running 'stack install cabal-install'" ] - show SolverMissingGHC = unlines - [ "Solver requires that GHC be on your PATH" - , "Try running 'stack setup'" - ] - show SolverNoCabalFiles = unlines - [ "No cabal files provided. Maybe this is due to not having a stack.yaml file?" - , "Try running 'stack init' to create a stack.yaml" - ] show (SomeTargetsNotBuildable xs) = "The following components have 'buildable: False' set in the cabal configuration, and so cannot be targets:\n " ++ T.unpack (renderPkgComponents xs) ++ diff --git a/src/main/Main.hs b/src/main/Main.hs index c2b460d0d4..73d6e43d09 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1166,23 +1166,30 @@ loadConfigWithOpts go@GlobalOpts{..} = do return lc return (manager,lc) --- | Project initialization -initCmd :: InitOpts -> GlobalOpts -> IO () -initCmd initOpts go = - withConfigAndLock go $ - do pwd <- getWorkingDir +withMiniConfigAndLock + :: GlobalOpts + -> StackT MiniConfig (StackT Config IO) () + -> IO () +withMiniConfigAndLock go inner = + withConfigAndLock go $ do config <- asks getConfig miniConfig <- loadMiniConfig config - runReaderT (initProject pwd initOpts) miniConfig + manager <- asks getHttpManager + runStackTGlobal manager miniConfig go inner + +-- | Project initialization +initCmd :: InitOpts -> GlobalOpts -> IO () +initCmd initOpts go = do + pwd <- getWorkingDir + withMiniConfigAndLock go (initProject pwd initOpts) -- | Create a project directory structure and initialize the stack config. newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO () -newCmd (newOpts,initOpts) go@GlobalOpts{..} = - withConfigAndLock go $ - do dir <- new newOpts - config <- asks getConfig - miniConfig <- loadMiniConfig config - runReaderT (initProject dir initOpts) miniConfig +newCmd (newOpts,initOpts) go@GlobalOpts{..} = do + withMiniConfigAndLock go $ do + dir <- new newOpts + initProject dir initOpts + -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO () From b15c6264ff80eaac6d610c76e8d979fdabefc187 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 20:36:45 +0530 Subject: [PATCH 07/29] Solver: Use snapshot instead of compiler resolver Changes include: 1) For 'init --solver' use the best selected snapshot (having minumum number of dep errors) with minimum extra deps on top of the snapshot. Also use the auto selected flags producing minimal snapshot dep errors for solving. Before this change, solver always used a compiler resolver and everything as extra-deps. 2) Fix a bug in solver. When determining new extra-deps take version number into account, not just the name. If the version is different from the previous or in-snapshot version then its a new dependency. --- src/Stack/Init.hs | 4 ++-- src/Stack/Solver.hs | 39 ++++++++++++++++++++++++--------------- 2 files changed, 26 insertions(+), 17 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 5139cf4a46..4a2f7a05a6 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -207,10 +207,10 @@ getDefaultResolver stackYaml cabalfps gpds initOpts = do case result of BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) - BuildPlanCheckPartial _ _ + BuildPlanCheckPartial flags _ | needSolver resolver initOpts -> solveResolverSpec stackYaml (map parent cabalfps) - (resolver, Map.empty, Map.empty) + (resolver, flags, Map.empty) | otherwise -> throwM $ ResolverPartial resolver where -- TODO support selecting best across regular and custom snapshots diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 2b669dd47e..fe9c4633b4 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -224,29 +224,33 @@ solveResolverSpec , Map PackageName (Map FlagName Bool) , Map PackageName Version) solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do - compilerVer <- getResolverCompiler resolver + (compilerVer, snapPackages) <- getResolverMiniPlan resolver menv <- setupCabalEnv compilerVer - extraDeps <- cabalSolver menv cabalDirs extraPackages flags $ + -- Note - The order in Map.union below is important. + -- We prefer extraPackages over the snapshot + let availablePkgs = Map.union extraPackages snapPackages + pairs <- cabalSolver menv cabalDirs availablePkgs flags $ ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs] - return - ( ResolverCompiler compilerVer - , Map.filter (not . Map.null) $ fmap snd extraDeps - , fmap fst extraDeps - ) + let versiondiff (v, f) v' = if v == v' then Nothing else Just (v, f) + newPairs = Map.differenceWith versiondiff pairs availablePkgs + + return ( resolver + , Map.filter (not . Map.null) (fmap snd pairs) + , fmap fst newPairs) where - getResolverCompiler (ResolverSnapshot snapName) = do + getResolverMiniPlan (ResolverSnapshot snapName) = do mbp <- loadMiniBuildPlan snapName - return (mbpCompilerVersion mbp) + return (mbpCompilerVersion mbp, fmap mpiVersion (mbpPackages mbp)) - getResolverCompiler (ResolverCompiler compiler) = - return compiler + getResolverMiniPlan (ResolverCompiler compiler) = + return (compiler, Map.empty) -- FIXME instead of passing the stackYaml dir we should maintain -- the file URL in the custom resolver always relative to stackYaml. - getResolverCompiler (ResolverCustom _ url) = do + getResolverMiniPlan (ResolverCustom _ url) = do mbp <- parseCustomMiniBuildPlan stackYaml url - return (mbpCompilerVersion mbp) + return (mbpCompilerVersion mbp, fmap mpiVersion (mbpPackages mbp)) -- | Determine missing extra-deps solveExtraDeps @@ -278,8 +282,13 @@ solveExtraDeps modStackYaml = do (bcFlags bconfig), packages) - let newDeps = extraDeps `Map.difference` packages - newFlags = Map.filter (not . Map.null) $ flags + -- FIXME we are not reporting any deleted dependencies + let newDeps = Map.differenceWith + (\v v' -> if v == v' then Nothing else Just v) + extraDeps (bcExtraDeps bconfig) + newFlags = Map.differenceWith + (\f f' -> if f == f' then Nothing else Just f) + flags (bcFlags bconfig) $logInfo "This command is not guaranteed to give you a perfect build plan" if Map.null newDeps From 59cb11b8e4920997057b8ca93a824c0de870fc3a Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 22:53:08 +0530 Subject: [PATCH 08/29] Solver: retry with relaxed contraints if failed With a recent commit solver was made to use packages in the snapshot as contraints when solving. Within those constraints it tries to figure what external packages are needed to build the package. But this strategy may not always work. The package dependencies may want to use a package which is already in the snapshot but requires a version different than in the snapshot. To take care of this we first try with the snapshot packages as hard constraints and if that fails we try solving with those packages as soft constraints i.e. merely preferences. This commit implements this fallback strategy. With this in place we should be able to solve and init any package which can be solved by cabal. If any package is not solved then either the package is broken or we have a bug in stack solver. This commit also added useful information in the status logs and suggestions for next steps or resolutions in case solver fails. --- src/Stack/Solver.hs | 116 ++++++++++++++++++++++++++++--------- src/System/Process/Read.hs | 2 +- 2 files changed, 91 insertions(+), 27 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index fe9c4633b4..d37426e7bf 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -24,12 +24,16 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Encoding (decodeUtf8With) import qualified Data.Yaml as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.IO (parseRelAsAbsDir) import Prelude import Stack.BuildPlan +import Stack.Constants (stackDotYaml) import Stack.Setup import Stack.Setup.Installed import Stack.Types @@ -43,15 +47,18 @@ import qualified System.FilePath as FP import System.IO.Temp (withSystemTempDirectory) import System.Process.Read +data ConstraintType = Constraint | Preference deriving (Eq) + cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env) => EnvOverride -> [Path Abs Dir] -- ^ cabal files + -> ConstraintType -> Map PackageName Version -- ^ constraints -> Map PackageName (Map FlagName Bool) -- ^ user-specified flags -> [String] -- ^ additional arguments - -> m (Map PackageName (Version, Map FlagName Bool)) -cabalSolver menv cabalfps constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do - configLines <- getCabalConfig dir constraints + -> m (Maybe (Map PackageName (Version, Map FlagName Bool))) +cabalSolver menv cabalfps constraintType constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do + configLines <- getCabalConfig dir constraintType constraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines @@ -67,7 +74,6 @@ cabalSolver menv cabalfps constraints userFlags cabalArgs = withSystemTempDirect : "install" : "--enable-tests" : "--enable-benchmarks" - : "-v" : "--dry-run" : "--only-dependencies" : "--reorder-goals" @@ -78,18 +84,30 @@ cabalSolver menv cabalfps constraints userFlags cabalArgs = withSystemTempDirect toConstraintArgs userFlags ++ fmap toFilePath cabalfps - $logInfo "Asking cabal to calculate a build plan, please wait" - - bs <- readProcessStdout (Just tmpdir) menv "cabal" args - let ls = drop 1 - $ dropWhile (not . T.isPrefixOf "In order, ") - $ T.lines - $ decodeUtf8 bs - (errs, pairs) = partitionEithers $ map parseLine ls - if null errs - then return (Map.fromList pairs) - else error $ "Could not parse cabal-install output: " ++ show errs + catch (liftM Just (readProcessStdout (Just tmpdir) menv "cabal" args)) + (\e@(ReadProcessException _ _ _ err) -> do + let errMsg = decodeUtf8With lenientDecode err + if LT.isInfixOf "Could not resolve dependencies" errMsg + then do + $logInfo "Solver: attempt failed." + $logInfo "\n>>>> Cabal errors begin" + $logInfo $ LT.toStrict errMsg + <> "<<<< Cabal errors end\n" + return Nothing + else throwM e) + >>= maybe (return Nothing) parseCabalOutput + where + parseCabalOutput bs = do + let ls = drop 1 + $ dropWhile (not . T.isPrefixOf "In order, ") + $ T.lines + $ decodeUtf8 bs + (errs, pairs) = partitionEithers $ map parseLine ls + if null errs + then return $ Just (Map.fromList pairs) + else error $ "Could not parse cabal-install output: " ++ show errs + parseLine t0 = maybe (Left t0) Right $ do -- get rid of (new package) and (latest: ...) bits ident':flags' <- Just $ T.words $ T.takeWhile (/= '(') t0 @@ -109,8 +127,11 @@ cabalSolver menv cabalfps constraints userFlags cabalArgs = withSystemTempDirect Just x -> (x, True) Just x -> (x, False) toConstraintArgs userFlagMap = - [formatFlagConstraint package flag enabled | (package, fs) <- Map.toList userFlagMap - , (flag, enabled) <- Map.toList fs] + [formatFlagConstraint package flag enabled + | constraintType == Constraint + , (package, fs) <- Map.toList userFlagMap + , (flag, enabled) <- Map.toList fs] + formatFlagConstraint package flag enabled = let sign = if enabled then '+' else '-' in @@ -118,9 +139,10 @@ cabalSolver menv cabalfps constraints userFlags cabalArgs = withSystemTempDirect getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir + -> ConstraintType -> Map PackageName Version -- ^ constraints -> m [Text] -getCabalConfig dir constraints = do +getCabalConfig dir constraintType constraints = do indices <- asks $ configPackageIndices . getConfig remotes <- mapM goIndex indices let cache = T.pack $ "remote-repo-cache: " ++ dir @@ -140,7 +162,9 @@ getCabalConfig dir constraints = do ] goConstraint (name, version) = T.concat - [ "constraint: " + [ (if constraintType == Constraint + then "constraint: " + else "preference: ") , T.pack $ packageNameString name , "==" , T.pack $ versionString version @@ -224,20 +248,60 @@ solveResolverSpec , Map PackageName (Map FlagName Bool) , Map PackageName Version) solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do + $logInfo $ "Solver: using resolver " <> resolverName resolver (compilerVer, snapPackages) <- getResolverMiniPlan resolver menv <- setupCabalEnv compilerVer -- Note - The order in Map.union below is important. -- We prefer extraPackages over the snapshot let availablePkgs = Map.union extraPackages snapPackages - pairs <- cabalSolver menv cabalDirs availablePkgs flags $ - ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs] + solver t = cabalSolver menv cabalDirs t availablePkgs flags $ + ["-v"] -- TODO make it conditional on debug + ++ ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs] + + let srcNames = (T.intercalate " and ") $ + ["packages from " <> resolverName resolver + | not (Map.null snapPackages)] ++ + [T.pack ((show $ Map.size extraPackages) <> " external packages") + | not (Map.null extraPackages)] + + $logInfo "Solver: asking cabal to calculate a build plan..." + unless (Map.null availablePkgs) + ($logInfo $ "Solver: trying with " <> srcNames <> " as hard constraints...") + + mdeps <- solver Constraint + mdeps' <- case mdeps of + Nothing | not (Map.null availablePkgs) -> do + $logInfo $ "Solver: retrying with " <> srcNames <> " as preferences..." + solver Preference + _ -> return mdeps + + case mdeps' of + Just pairs -> do + let versiondiff (v, f) v' = if v == v' then Nothing else Just (v, f) + newPairs = Map.differenceWith versiondiff pairs availablePkgs - let versiondiff (v, f) v' = if v == v' then Nothing else Just (v, f) - newPairs = Map.differenceWith versiondiff pairs availablePkgs + $logInfo $ "Solver: successfully determined a build plan with " + <> T.pack (show $ Map.size newPairs) + <> " new dependencies " - return ( resolver - , Map.filter (not . Map.null) (fmap snd pairs) - , fmap fst newPairs) + return ( resolver + , Map.filter (not . Map.null) (fmap snd pairs) + , fmap fst newPairs) + Nothing -> + error ("Solver could not resolve package dependencies. " + <> "You can try one or more of the following:\n" + <> "- If the problem is due to a stale package index you can try " + <> "again after udating the package index with 'stack update'.\n" + <> "- Create pivot points for the solver by specifying some " + <> "extra dependencies in " <> toFilePath stackDotYaml + <> " and then use 'stack solver' to figure out the rest of the " + <> " dependencies.\n" + <> "- Check if you missed adding a custom package or remote " + <> "package location needed to build your package. Also, you may " + <> "want to remove any unnecessary packages causing dependency " + <> "problems.\n" + <> "- Use '--ignore-subdirs' to avoid using unwanted .cabal files " + <> "in subdirectories.") where getResolverMiniPlan (ResolverSnapshot snapName) = do mbp <- loadMiniBuildPlan snapName diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index a28370a3f3..8f92fd1089 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -198,7 +198,7 @@ instance Show ReadProcessException where maybe [] (\x -> [" in directory ", x]) (cwd cp) ++ [ " exited with " , show ec - , "\n" + , "\n\n" , toStr out , "\n" , toStr err From afbc92cf9638f384ea0872e346a3fc9ca7221600 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 1 Jan 2016 23:25:16 +0530 Subject: [PATCH 09/29] Fix - ignore certain subdirs for stack init There is code in place to ignore .git .stack-work etc. But it did not work due to a trailing path separator mismatch in the logic. Fixed. --- src/Stack/Init.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 4a2f7a05a6..c5b76651a0 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -46,6 +46,7 @@ import Stack.Types import Stack.Types.Internal ( HasTerminal, HasReExec , HasLogLevel) import System.Directory (getDirectoryContents) +import System.FilePath (dropTrailingPathSeparator) import Stack.Config ( getSnapshots , makeConcreteResolver) @@ -55,7 +56,8 @@ findCabalFiles recurse dir = where isCabal path = ".cabal" `isSuffixOf` toFilePath path - isIgnored path = toFilePath (dirname path) `Set.member` ignoredDirs + isIgnored path = dropTrailingPathSeparator (toFilePath (dirname path)) + `Set.member` ignoredDirs -- | Special directories that we don't want to traverse for .cabal files ignoredDirs :: Set FilePath From 26cfaa4c69963286056da17e56101e4ec1b6c397 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 2 Jan 2016 00:08:28 +0530 Subject: [PATCH 10/29] Solver: perform compiler compatibility check With recent changes we perform compiler compatibilty check when choosing snapshots for stack init. We need similar checks for stack solver as well. This change uses the same code to do compiler compatibility check when using the solver command. If the resolver specified in the stack.yaml does not have a compiler which can work with the package we emit an appropriate messages instead of going ahead and then showing difficult to understand cabal errors. --- src/Stack/Init.hs | 33 ++---------------- src/Stack/Solver.hs | 81 +++++++++++++++++++++++++++++++++++---------- 2 files changed, 65 insertions(+), 49 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index c5b76651a0..8d15073be5 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -3,8 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Stack.Init - ( findCabalFiles - , initProject + ( initProject , InitOpts (..) , SnapPref (..) , Method (..) @@ -23,20 +22,17 @@ import qualified Data.ByteString.Lazy as L import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F -import Data.List (isSuffixOf,sortBy) +import Data.List (sortBy) import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe) import Data.Monoid -import Data.Set (Set) -import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Yaml as Yaml import qualified Distribution.PackageDescription as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path -import Path.Find import Path.IO import Stack.BuildPlan import Stack.Constants @@ -46,27 +42,9 @@ import Stack.Types import Stack.Types.Internal ( HasTerminal, HasReExec , HasLogLevel) import System.Directory (getDirectoryContents) -import System.FilePath (dropTrailingPathSeparator) import Stack.Config ( getSnapshots , makeConcreteResolver) -findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File] -findCabalFiles recurse dir = - liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir)) - where - isCabal path = ".cabal" `isSuffixOf` toFilePath path - - isIgnored path = dropTrailingPathSeparator (toFilePath (dirname path)) - `Set.member` ignoredDirs - --- | Special directories that we don't want to traverse for .cabal files -ignoredDirs :: Set FilePath -ignoredDirs = Set.fromList - [ ".git" - , "dist" - , ".stack-work" - ] - -- | Generate stack.yaml initProject :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m @@ -231,13 +209,6 @@ getDefaultResolver stackYaml cabalfps gpds initOpts = do <> "'.") return $ ResolverSnapshot s) - checkResolverSpec packages flags resolver = do - case resolver of - ResolverSnapshot name -> checkSnapBuildPlan packages flags name - ResolverCompiler _ -> return $ BuildPlanCheckPartial Map.empty Map.empty - -- TODO support custom resolver for stack init - ResolverCustom _ _ -> return $ BuildPlanCheckPartial Map.empty Map.empty - needSolver _ (InitOpts {useSolver = True}) = True needSolver (ResolverCompiler _) _ = True needSolver _ _ = False diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index d37426e7bf..7add4f667b 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -3,7 +3,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Stack.Solver - ( solveExtraDeps + ( checkResolverSpec + , findCabalFiles + , solveExtraDeps , solveResolverSpec ) where @@ -18,9 +20,12 @@ import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarni import qualified Data.ByteString as S import Data.Either import qualified Data.HashMap.Strict as HashMap +import Data.List (isSuffixOf) import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid +import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) @@ -28,12 +33,15 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Encoding (decodeUtf8With) import qualified Data.Yaml as Yaml +import qualified Distribution.PackageDescription as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path +import Path.Find (findFiles) import Path.IO (parseRelAsAbsDir) import Prelude import Stack.BuildPlan import Stack.Constants (stackDotYaml) +import Stack.Package (readPackageUnresolved) import Stack.Setup import Stack.Setup.Installed import Stack.Types @@ -316,6 +324,43 @@ solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do mbp <- parseCustomMiniBuildPlan stackYaml url return (mbpCompilerVersion mbp, fmap mpiVersion (mbpPackages mbp)) +-- | Given a bundle of packages and a resolver, check the resolver with respect +-- to the packages and return how well the resolver satisfies the depndencies +-- of the packages. If 'flags' is passed as 'Nothing' then flags are chosen +-- automatically. + +checkResolverSpec + :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m + , HasHttpManager env, HasConfig env, HasGHCVariant env + , MonadBaseControl IO m) + => [C.GenericPackageDescription] + -> Maybe (Map PackageName (Map FlagName Bool)) + -> Resolver + -> m BuildPlanCheck +checkResolverSpec gpds flags resolver = do + case resolver of + ResolverSnapshot name -> checkSnapBuildPlan gpds flags name + ResolverCompiler _ -> return $ BuildPlanCheckPartial Map.empty Map.empty + -- TODO support custom resolver for stack init + ResolverCustom _ _ -> return $ BuildPlanCheckPartial Map.empty Map.empty + +findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File] +findCabalFiles recurse dir = + liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir)) + where + isCabal path = ".cabal" `isSuffixOf` toFilePath path + + isIgnored path = FP.dropTrailingPathSeparator (toFilePath (dirname path)) + `Set.member` ignoredDirs + +-- | Special directories that we don't want to traverse for .cabal files +ignoredDirs :: Set FilePath +ignoredDirs = Set.fromList + [ ".git" + , "dist" + , ".stack-work" + ] + -- | Determine missing extra-deps solveExtraDeps :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m @@ -327,24 +372,24 @@ solveExtraDeps solveExtraDeps modStackYaml = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig + let stackYaml = bcStackYaml bconfig - snapshot <- - case bcResolver bconfig of - ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName - ResolverCompiler _ -> return Map.empty - ResolverCustom _ url -> liftM mbpPackages $ parseCustomMiniBuildPlan - (bcStackYaml bconfig) - url - - let packages = Map.union - (bcExtraDeps bconfig) - (mpiVersion <$> snapshot) - - (_, flags, extraDeps) <- solveResolverSpec stackYaml - (Map.keys $ envConfigPackages econfig) - (bcResolver bconfig, - (bcFlags bconfig), - packages) + cabalDirs = Map.keys $ envConfigPackages econfig + + cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) + (_warnings, gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) + + let oldFlags = bcFlags bconfig + resolver = bcResolver bconfig + + result <- checkResolverSpec gpds (Just oldFlags) resolver + (_, flags, extraDeps) <- case result of + BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver + BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) + BuildPlanCheckPartial _ _ -> solveResolverSpec stackYaml cabalDirs + ( resolver + , oldFlags + , bcExtraDeps bconfig) -- FIXME we are not reporting any deleted dependencies let newDeps = Map.differenceWith From 611ddfb39e9e9d5b93080f4430ff6758a8845548 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 2 Jan 2016 00:59:16 +0530 Subject: [PATCH 11/29] init/solver improve and share error checking code 1) Share the same error checking code across init and solver commands 2) Use relative paths in error messages to make it easier to understand 3) Massaged some error messages --- src/Stack/Init.hs | 44 ++++++++++++++++++++++-------------------- src/Stack/Solver.hs | 47 +++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 66 insertions(+), 25 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 8d15073be5..c87f8b458a 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -11,7 +11,7 @@ module Stack.Init import Control.Exception (assert) import Control.Exception.Enclosed (catchAny, handleIO) -import Control.Monad (liftM, when, zipWithM_) +import Control.Monad (liftM, when) import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class import Control.Monad.Logger @@ -36,12 +36,12 @@ import Path import Path.IO import Stack.BuildPlan import Stack.Constants -import Stack.Package import Stack.Solver import Stack.Types import Stack.Types.Internal ( HasTerminal, HasReExec , HasLogLevel) -import System.Directory (getDirectoryContents) +import System.Directory ( getDirectoryContents + , makeRelativeToCurrentDirectory) import Stack.Config ( getSnapshots , makeConcreteResolver) @@ -57,23 +57,23 @@ initProject initProject currDir initOpts = do let dest = currDir stackDotYaml dest' = toFilePath dest + + reldest <- liftIO $ makeRelativeToCurrentDirectory dest' + exists <- fileExists dest - when (not (forceOverwrite initOpts) && exists) $ - error ("Refusing to overwrite existing stack.yaml, " <> - "please delete before running stack init " <> - "or if you are sure use \"--force\"") + when (not (forceOverwrite initOpts) && exists) $ do + error ("Stack configuration file " <> reldest <> + " exists, use 'stack solver' to fix the existing config file or \ + \'--force' to overwrite it.") - cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir - $logInfo $ "Writing default config file to: " <> T.pack dest' - $logInfo $ "Basing on cabal files:" - mapM_ (\path -> $logInfo $ "- " <> T.pack (toFilePath path)) cabalfps - $logInfo "" + let noPkgMsg = "In order to init, you should have an existing .cabal \ + \file. Please try \"stack new\" instead." - when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead" - (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) - zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings + cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir + gpds <- cabalPackagesCheck cabalfps noPkgMsg - (r, flags, extraDeps) <- getDefaultResolver dest cabalfps gpds initOpts + (r, flags, extraDeps) <- + getDefaultResolver dest (map parent cabalfps) gpds initOpts let p = Project { projectPackages = pkgs , projectExtraDeps = extraDeps @@ -94,9 +94,11 @@ initProject currDir initOpts = do Just rel -> toFilePath rel , peSubdirs = [] } - $logInfo $ "Selected resolver: " <> resolverName r + + $logInfo $ "Initialising stack configuration using resolver: " <> resolverName r + $logInfo $ "Writing stack configuration to: " <> T.pack reldest liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p - $logInfo $ "Wrote project config to: " <> T.pack dest' + $logInfo "All done." -- | Render a stack.yaml file with comments, see: -- https://github.com/commercialhaskell/stack/issues/226 @@ -174,13 +176,13 @@ getDefaultResolver , HasHttpManager env , HasLogLevel env , HasReExec env , HasTerminal env) => Path Abs File -- ^ stack.yaml - -> [Path Abs File] -- ^ cabal dirs + -> [Path Abs Dir] -- ^ cabal dirs -> [C.GenericPackageDescription] -- ^ cabal descriptions -> InitOpts -> m ( Resolver , Map PackageName (Map FlagName Bool) , Map PackageName Version) -getDefaultResolver stackYaml cabalfps gpds initOpts = do +getDefaultResolver stackYaml cabalDirs gpds initOpts = do resolver <- getResolver (ioMethod initOpts) result <- checkResolverSpec gpds Nothing resolver @@ -189,7 +191,7 @@ getDefaultResolver stackYaml cabalfps gpds initOpts = do BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) BuildPlanCheckPartial flags _ | needSolver resolver initOpts -> - solveResolverSpec stackYaml (map parent cabalfps) + solveResolverSpec stackYaml cabalDirs (resolver, flags, Map.empty) | otherwise -> throwM $ ResolverPartial resolver where diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 7add4f667b..fe1bf34d5c 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} module Stack.Solver ( checkResolverSpec + , cabalPackagesCheck , findCabalFiles , solveExtraDeps , solveResolverSpec @@ -41,7 +42,8 @@ import Path.IO (parseRelAsAbsDir) import Prelude import Stack.BuildPlan import Stack.Constants (stackDotYaml) -import Stack.Package (readPackageUnresolved) +import Stack.Package ( printCabalFileWarning + , readPackageUnresolved) import Stack.Setup import Stack.Setup.Installed import Stack.Types @@ -50,7 +52,8 @@ import Stack.Types.Internal ( HasTerminal , HasLogLevel) import System.Directory (copyFile, createDirectoryIfMissing, - getTemporaryDirectory) + getTemporaryDirectory, + makeRelativeToCurrentDirectory) import qualified System.FilePath as FP import System.IO.Temp (withSystemTempDirectory) import System.Process.Read @@ -361,6 +364,34 @@ ignoredDirs = Set.fromList , ".stack-work" ] +-- | Do some basic checks on a list of cabal file paths to be used for creating +-- stack config, print some informative and error messages and if all is ok +-- return @GenericPackageDescription@ list. +cabalPackagesCheck + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => [Path Abs File] + -> String + -> m [C.GenericPackageDescription] +cabalPackagesCheck cabalfps noPkgMsg = do + when (null cabalfps) $ + error noPkgMsg + + relpaths <- mapM makeRel cabalfps + $logInfo $ "Using the following cabal packages:" + $logInfo $ T.pack (formatGroup relpaths) + + (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) + zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings + return gpds + + where + makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath + formatPath path = "- " <> path <> "\n" + formatGroup = concat . (map formatPath) + -- | Determine missing extra-deps solveExtraDeps :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m @@ -374,10 +405,15 @@ solveExtraDeps modStackYaml = do bconfig <- asks getBuildConfig let stackYaml = bcStackYaml bconfig - cabalDirs = Map.keys $ envConfigPackages econfig + stackYamlFP <- makeRel stackYaml + + let cabalDirs = Map.keys $ envConfigPackages econfig + noPkgMsg = "No cabal packages found. Please add at least one directory \ + \containing a .cabal file in '" <> stackYamlFP <> "' or use \ + \'stack init' to automatically generate the config file." cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) - (_warnings, gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) + gpds <- cabalPackagesCheck cabalfps noPkgMsg let oldFlags = bcFlags bconfig resolver = bcResolver bconfig @@ -430,3 +466,6 @@ solveExtraDeps modStackYaml = do else do $logInfo "" $logInfo "To automatically modify your stack.yaml file, rerun with '--modify-stack-yaml'" + + where + makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath From 7a1f282bb9d9259571ca5fcf60369cf82517aa2d Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 2 Jan 2016 01:16:51 +0530 Subject: [PATCH 12/29] init/solver handle duplicate cabal package case When there are duplicate cabal packages in the directory tree or specified in the config file we should detect the case and provide an appropriate error message. --- src/Stack/Init.hs | 10 +++++++++- src/Stack/Solver.hs | 21 +++++++++++++++++---- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index c87f8b458a..d94bf0cb54 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -69,8 +69,16 @@ initProject currDir initOpts = do let noPkgMsg = "In order to init, you should have an existing .cabal \ \file. Please try \"stack new\" instead." + dupPkgFooter = "You have the following options:\n" + <> "- Use '--ignore-subdirs' command line switch to ignore " + <> "packages in subdirectories. You can init subdirectories as " + <> "independent projects.\n" + <> "- Put selected packages in the stack config file " + <> "and then use 'stack solver' command to automatically resolve " + <> "dependencies and update the config file." + cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir - gpds <- cabalPackagesCheck cabalfps noPkgMsg + gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter (r, flags, extraDeps) <- getDefaultResolver dest (map parent cabalfps) gpds initOpts diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index fe1bf34d5c..791bac7b31 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -21,7 +21,8 @@ import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarni import qualified Data.ByteString as S import Data.Either import qualified Data.HashMap.Strict as HashMap -import Data.List (isSuffixOf) +import Data.List (isSuffixOf, intercalate) +import Data.List.Extra (groupSortOn) import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid @@ -42,7 +43,7 @@ import Path.IO (parseRelAsAbsDir) import Prelude import Stack.BuildPlan import Stack.Constants (stackDotYaml) -import Stack.Package ( printCabalFileWarning +import Stack.Package (printCabalFileWarning , readPackageUnresolved) import Stack.Setup import Stack.Setup.Installed @@ -374,8 +375,9 @@ cabalPackagesCheck , HasTerminal env) => [Path Abs File] -> String + -> String -> m [C.GenericPackageDescription] -cabalPackagesCheck cabalfps noPkgMsg = do +cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do when (null cabalfps) $ error noPkgMsg @@ -383,12 +385,21 @@ cabalPackagesCheck cabalfps noPkgMsg = do $logInfo $ "Using the following cabal packages:" $logInfo $ T.pack (formatGroup relpaths) + when (dupGroups relpaths /= []) $ + error $ "Duplicate cabal package names cannot be used in a single " + <> "stack project. Following duplicates were found:\n" + <> intercalate "\n" (dupGroups relpaths) + <> "\n" + <> dupPkgFooter + (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings return gpds where makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath + groups = filter ((> 1) . length) . groupSortOn (FP.takeFileName) + dupGroups = (map formatGroup) . groups formatPath path = "- " <> path <> "\n" formatGroup = concat . (map formatPath) @@ -411,9 +422,11 @@ solveExtraDeps modStackYaml = do noPkgMsg = "No cabal packages found. Please add at least one directory \ \containing a .cabal file in '" <> stackYamlFP <> "' or use \ \'stack init' to automatically generate the config file." + dupPkgFooter = "Please remove the directories containing duplicate \ + \entries from '" <> stackYamlFP <> "'." cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) - gpds <- cabalPackagesCheck cabalfps noPkgMsg + gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter let oldFlags = bcFlags bconfig resolver = bcResolver bconfig From 5c10d9a84593c2af2090c4f35dc67f424039b7e7 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 2 Jan 2016 01:42:48 +0530 Subject: [PATCH 13/29] Tweak solver error messages Remove the warnings about not providing a good build plan. Now we either provide a successful plan or we fail and provide suggestions. We no longer write an inconsistent stack.yaml. Report relative filenames in error/status messages. --- src/Stack/Solver.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 791bac7b31..98a5edffee 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -416,14 +416,15 @@ solveExtraDeps modStackYaml = do bconfig <- asks getBuildConfig let stackYaml = bcStackYaml bconfig - stackYamlFP <- makeRel stackYaml + relStackYaml <- liftIO $ makeRelativeToCurrentDirectory + $ toFilePath stackYaml let cabalDirs = Map.keys $ envConfigPackages econfig noPkgMsg = "No cabal packages found. Please add at least one directory \ - \containing a .cabal file in '" <> stackYamlFP <> "' or use \ + \containing a .cabal file in '" <> relStackYaml <> "' or use \ \'stack init' to automatically generate the config file." dupPkgFooter = "Please remove the directories containing duplicate \ - \entries from '" <> stackYamlFP <> "'." + \entries from '" <> relStackYaml <> "'." cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter @@ -448,11 +449,9 @@ solveExtraDeps modStackYaml = do (\f f' -> if f == f' then Nothing else Just f) flags (bcFlags bconfig) - $logInfo "This command is not guaranteed to give you a perfect build plan" if Map.null newDeps - then $logInfo "No needed changes found" + then $logInfo $ "No changes needed to " <> T.pack relStackYaml else do - $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking" let o = object $ ("extra-deps" .= map fromTuple (Map.toList newDeps)) : (if Map.null newFlags @@ -475,10 +474,7 @@ solveExtraDeps modStackYaml = do (toJSON $ Map.union (projectFlags project) newFlags) obj liftIO $ Yaml.encodeFile fp obj' - $logInfo $ T.pack $ "Updated " ++ fp + $logInfo $ "Updated " <> T.pack relStackYaml else do $logInfo "" $logInfo "To automatically modify your stack.yaml file, rerun with '--modify-stack-yaml'" - - where - makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath From cdbfa10ea35233a056ad0fc90b923407bbf444a3 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 3 Jan 2016 02:48:59 +0530 Subject: [PATCH 14/29] Solver: expunge unnecessary dependencies and flags In addition to adding new flags and dependencies solver now also reports and deletes any dependencies and flags which are no longer needed. --- src/Stack/Solver.hs | 103 ++++++++++++++++++++++++++------------------ 1 file changed, 61 insertions(+), 42 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 98a5edffee..3cdf3fdbc6 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -290,11 +290,11 @@ solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do case mdeps' of Just pairs -> do let versiondiff (v, f) v' = if v == v' then Nothing else Just (v, f) - newPairs = Map.differenceWith versiondiff pairs availablePkgs + newPairs = Map.differenceWith versiondiff pairs snapPackages $logInfo $ "Solver: successfully determined a build plan with " <> T.pack (show $ Map.size newPairs) - <> " new dependencies " + <> " external dependencies " return ( resolver , Map.filter (not . Map.null) (fmap snd pairs) @@ -429,8 +429,9 @@ solveExtraDeps modStackYaml = do cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter - let oldFlags = bcFlags bconfig - resolver = bcResolver bconfig + let oldFlags = bcFlags bconfig + oldExtraDeps = bcExtraDeps bconfig + resolver = bcResolver bconfig result <- checkResolverSpec gpds (Just oldFlags) resolver (_, flags, extraDeps) <- case result of @@ -439,42 +440,60 @@ solveExtraDeps modStackYaml = do BuildPlanCheckPartial _ _ -> solveResolverSpec stackYaml cabalDirs ( resolver , oldFlags - , bcExtraDeps bconfig) - - -- FIXME we are not reporting any deleted dependencies - let newDeps = Map.differenceWith - (\v v' -> if v == v' then Nothing else Just v) - extraDeps (bcExtraDeps bconfig) - newFlags = Map.differenceWith - (\f f' -> if f == f' then Nothing else Just f) - flags (bcFlags bconfig) - - if Map.null newDeps - then $logInfo $ "No changes needed to " <> T.pack relStackYaml + , oldExtraDeps) + + let + vDiff v v' = if v == v' then Nothing else Just v + depsDiff = Map.differenceWith vDiff + newDeps = depsDiff extraDeps oldExtraDeps + goneDeps = depsDiff oldExtraDeps extraDeps + + fDiff f f' = if f == f' then Nothing else Just f + flagsDiff = Map.differenceWith fDiff + newFlags = flagsDiff flags oldFlags + goneFlags = flagsDiff oldFlags flags + + changed = any (not . Map.null) [newDeps, goneDeps] + || any (not . Map.null) [newFlags, goneFlags] + + if changed then do + printFlags newFlags "New" + printDeps newDeps "New" + + printFlags goneFlags "Deleted" + printDeps goneDeps "Deleted" + + if modStackYaml then do + writeStackYaml stackYaml extraDeps flags + $logInfo $ "Updated " <> T.pack relStackYaml else do - let o = object - $ ("extra-deps" .= map fromTuple (Map.toList newDeps)) - : (if Map.null newFlags - then [] - else ["flags" .= newFlags]) - mapM_ $logInfo $ T.lines $ decodeUtf8 $ Yaml.encode o - - if modStackYaml - then do - let fp = toFilePath $ bcStackYaml bconfig - obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return - (ProjectAndConfigMonoid project _, warnings) <- - liftIO (Yaml.decodeFileEither fp) >>= either throwM return - logJSONWarnings fp warnings - let obj' = - HashMap.insert "extra-deps" - (toJSON $ map fromTuple $ Map.toList - $ Map.union (projectExtraDeps project) newDeps) - $ HashMap.insert ("flags" :: Text) - (toJSON $ Map.union (projectFlags project) newFlags) - obj - liftIO $ Yaml.encodeFile fp obj' - $logInfo $ "Updated " <> T.pack relStackYaml - else do - $logInfo "" - $logInfo "To automatically modify your stack.yaml file, rerun with '--modify-stack-yaml'" + $logInfo "To automatically modify your stack.yaml file, \ + \rerun with '--modify-stack-yaml'" + else + $logInfo $ "No changes needed to " <> T.pack relStackYaml + + where + printFlags fl msg = do + when ((not . Map.null) fl) $ do + $logInfo "" + $logInfo $ T.pack msg <> " flags:" + $logInfo $ decodeUtf8 $ Yaml.encode $ object ["flags" .= fl] + + printDeps deps msg = do + when ((not . Map.null) deps) $ do + $logInfo "" + $logInfo $ T.pack msg <> " dependencies:" + $logInfo $ decodeUtf8 $ Yaml.encode $ object $ + [("extra-deps" .= map fromTuple (Map.toList deps))] + + writeStackYaml path deps fl = do + let fp = toFilePath path + obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return + (ProjectAndConfigMonoid _ _, warnings) <- + liftIO (Yaml.decodeFileEither fp) >>= either throwM return + logJSONWarnings fp warnings + let obj' = + HashMap.insert "extra-deps" + (toJSON $ map fromTuple $ Map.toList deps) + $ HashMap.insert ("flags" :: Text) (toJSON fl) obj + liftIO $ Yaml.encodeFile fp obj' From c666434e1a454580abb3b2e258730104bc51dd2f Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 4 Jan 2016 02:15:54 +0530 Subject: [PATCH 15/29] nitfix solver error messages --- src/Stack/Options.hs | 2 +- src/Stack/Solver.hs | 44 ++++++++++++++++++++++++-------------------- 2 files changed, 25 insertions(+), 21 deletions(-) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 9fbc471714..b5d9c6579f 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -694,7 +694,7 @@ initOptsParser = resolver = option readAbstractResolver (long "resolver" <> metavar "RESOLVER" <> - help "Use the given resolver, even if not all dependencies are met") + help "Use the specified resolver") -- | Parser for a logging level. logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 3cdf3fdbc6..0e1ef38b27 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -101,7 +101,7 @@ cabalSolver menv cabalfps constraintType constraints userFlags cabalArgs = withS let errMsg = decodeUtf8With lenientDecode err if LT.isInfixOf "Could not resolve dependencies" errMsg then do - $logInfo "Solver: attempt failed." + $logInfo "Attempt failed." $logInfo "\n>>>> Cabal errors begin" $logInfo $ LT.toStrict errMsg <> "<<<< Cabal errors end\n" @@ -241,7 +241,7 @@ setupCabalEnv compiler = do mver <- getSystemCompiler menv (whichCompiler compiler) case mver of Just (version, _) -> - $logInfo $ "Solver: using compiler " <> compilerVersionText version + $logInfo $ "Using compiler: " <> compilerVersionText version Nothing -> error "Failed to determine compiler version. \ \This is most likely a bug." return menv @@ -260,7 +260,7 @@ solveResolverSpec , Map PackageName (Map FlagName Bool) , Map PackageName Version) solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do - $logInfo $ "Solver: using resolver " <> resolverName resolver + $logInfo $ "Using resolver: " <> resolverName resolver (compilerVer, snapPackages) <- getResolverMiniPlan resolver menv <- setupCabalEnv compilerVer -- Note - The order in Map.union below is important. @@ -276,14 +276,14 @@ solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do [T.pack ((show $ Map.size extraPackages) <> " external packages") | not (Map.null extraPackages)] - $logInfo "Solver: asking cabal to calculate a build plan..." + $logInfo "Asking cabal to calculate a build plan..." unless (Map.null availablePkgs) - ($logInfo $ "Solver: trying with " <> srcNames <> " as hard constraints...") + ($logInfo $ "Trying with " <> srcNames <> " as hard constraints...") mdeps <- solver Constraint mdeps' <- case mdeps of Nothing | not (Map.null availablePkgs) -> do - $logInfo $ "Solver: retrying with " <> srcNames <> " as preferences..." + $logInfo $ "Retrying with " <> srcNames <> " as preferences..." solver Preference _ -> return mdeps @@ -292,9 +292,9 @@ solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do let versiondiff (v, f) v' = if v == v' then Nothing else Just (v, f) newPairs = Map.differenceWith versiondiff pairs snapPackages - $logInfo $ "Solver: successfully determined a build plan with " + $logInfo $ "Successfully determined a build plan with " <> T.pack (show $ Map.size newPairs) - <> " external dependencies " + <> " external dependencies." return ( resolver , Map.filter (not . Map.null) (fmap snd pairs) @@ -304,14 +304,13 @@ solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do <> "You can try one or more of the following:\n" <> "- If the problem is due to a stale package index you can try " <> "again after udating the package index with 'stack update'.\n" - <> "- Create pivot points for the solver by specifying some " + <> "- Guide the solver by specifying some of the " <> "extra dependencies in " <> toFilePath stackDotYaml - <> " and then use 'stack solver' to figure out the rest of the " - <> " dependencies.\n" + <> " and then use 'stack solver' figure out the rest.\n" <> "- Check if you missed adding a custom package or remote " - <> "package location needed to build your package. Also, you may " - <> "want to remove any unnecessary packages causing dependency " - <> "problems.\n" + <> "package location needed to build your package.\n" + <> "- You may also want to remove any unnecessary packages " + <> "causing dependency problems.\n" <> "- Use '--ignore-subdirs' to avoid using unwanted .cabal files " <> "in subdirectories.") where @@ -382,7 +381,7 @@ cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do error noPkgMsg relpaths <- mapM makeRel cabalfps - $logInfo $ "Using the following cabal packages:" + $logInfo $ "Using cabal packages:" $logInfo $ T.pack (formatGroup relpaths) when (dupGroups relpaths /= []) $ @@ -419,10 +418,12 @@ solveExtraDeps modStackYaml = do relStackYaml <- liftIO $ makeRelativeToCurrentDirectory $ toFilePath stackYaml + $logInfo $ "Using configuration file: " <> T.pack relStackYaml let cabalDirs = Map.keys $ envConfigPackages econfig - noPkgMsg = "No cabal packages found. Please add at least one directory \ - \containing a .cabal file in '" <> relStackYaml <> "' or use \ - \'stack init' to automatically generate the config file." + noPkgMsg = "No cabal packages found in " <> relStackYaml <> + ". Please add at least one directory containing a .cabal \ + \file. You can also use 'stack init' to automatically \ + \generate the config file." dupPkgFooter = "Please remove the directories containing duplicate \ \entries from '" <> relStackYaml <> "'." @@ -457,6 +458,9 @@ solveExtraDeps modStackYaml = do || any (not . Map.null) [newFlags, goneFlags] if changed then do + $logInfo $ "The following changes will be made to " + <> T.pack relStackYaml <> ":" + printFlags newFlags "New" printDeps newDeps "New" @@ -467,8 +471,8 @@ solveExtraDeps modStackYaml = do writeStackYaml stackYaml extraDeps flags $logInfo $ "Updated " <> T.pack relStackYaml else do - $logInfo "To automatically modify your stack.yaml file, \ - \rerun with '--modify-stack-yaml'" + $logInfo $ "To automatically update " <> T.pack relStackYaml + <> ", rerun with '--modify-stack-yaml'" else $logInfo $ "No changes needed to " <> T.pack relStackYaml From dd7f1e46a06b38a1a52192ce903e05ceb6c63f68 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 4 Jan 2016 02:27:25 +0530 Subject: [PATCH 16/29] Correctly parse the flags in cabal solver output Also, always use the user specified flags as constraint. --- src/Stack/Solver.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 0e1ef38b27..cc75972167 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -121,8 +121,17 @@ cabalSolver menv cabalfps constraintType constraints userFlags cabalArgs = withS else error $ "Could not parse cabal-install output: " ++ show errs parseLine t0 = maybe (Left t0) Right $ do - -- get rid of (new package) and (latest: ...) bits - ident':flags' <- Just $ T.words $ T.takeWhile (/= '(') t0 + -- Sample output to parse: + -- text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package)) + -- An ugly parser to extract module id and flags + let t1 = T.concat $ + [ T.takeWhile (/= '(') + , (T.takeWhile (/= '(')) + . (T.drop 1) + . (T.dropWhile (/= ')')) + ] <*> [t0] + + ident':flags' <- Just $ T.words t1 PackageIdentifier name version <- parsePackageIdentifierFromString $ T.unpack ident' flags <- mapM parseFlag flags' @@ -140,8 +149,7 @@ cabalSolver menv cabalfps constraintType constraints userFlags cabalArgs = withS Just x -> (x, False) toConstraintArgs userFlagMap = [formatFlagConstraint package flag enabled - | constraintType == Constraint - , (package, fs) <- Map.toList userFlagMap + | (package, fs) <- Map.toList userFlagMap , (flag, enabled) <- Map.toList fs] formatFlagConstraint package flag enabled = From 3c6fa73c59a364e9a1c9fe1fc52d2a8fc062fc69 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 4 Jan 2016 03:30:22 +0530 Subject: [PATCH 17/29] Override snapshot with local versions for solver When a package being built has a version in snapshot as well then the solver constraints should always use the local version. --- src/Stack/BuildPlan.hs | 18 ++++++++++-------- src/Stack/Init.hs | 2 +- src/Stack/Solver.hs | 12 +++++++++--- 3 files changed, 20 insertions(+), 12 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 7fefcfda27..488e921af6 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -10,7 +10,8 @@ -- snapshot. module Stack.BuildPlan - ( BuildPlanException (..) + ( gpdPackages + , BuildPlanException (..) , BuildPlanCheck (..) , checkSnapBuildPlan , MiniBuildPlan(..) @@ -459,6 +460,13 @@ loadBuildPlan name = do handle404 (Status 404 _) _ _ = Just $ SomeException $ SnapshotNotFound name handle404 _ _ _ = Nothing +gpdPackages :: [GenericPackageDescription] -> Map PackageName Version +gpdPackages gpds = Map.fromList $ + map (fromCabalIdent . C.package . C.packageDescription) gpds + where + fromCabalIdent (C.PackageIdentifier name version) = + (fromCabalPackageName name, fromCabalVersion version) + gpdPackageName :: GenericPackageDescription -> PackageName gpdPackageName = fromCabalPackageName . C.pkgName @@ -608,13 +616,7 @@ checkBundleBuildPlan platform compiler pool flags gpds = pkgPlan (Just f) gpd = checkPackageBuildPlan platform compiler pool' (flags' f gpd) gpd flags' f gpd = maybe Map.empty id (Map.lookup (gpdPackageName gpd) f) - pool' = Map.union buildPkgs pool - - buildPkgs = Map.fromList $ - map (fromCabalIdent . C.package . C.packageDescription) gpds - - fromCabalIdent (C.PackageIdentifier name version) = - (fromCabalPackageName name, fromCabalVersion version) + pool' = Map.union (gpdPackages gpds) pool dupError _ _ = error "Bug: Duplicate packages are not expected here" diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index d94bf0cb54..28c2f55104 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -199,7 +199,7 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) BuildPlanCheckPartial flags _ | needSolver resolver initOpts -> - solveResolverSpec stackYaml cabalDirs + solveResolverSpec stackYaml cabalDirs (gpdPackages gpds) (resolver, flags, Map.empty) | otherwise -> throwM $ ResolverPartial resolver where diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index cc75972167..4bd231a77d 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -261,19 +261,24 @@ solveResolverSpec , HasTerminal env) => Path Abs File -- ^ stack.yaml file location -> [Path Abs Dir] -- ^ package dirs containing cabal files + -> Map PackageName Version -- ^ local packages to build -> ( Resolver , Map PackageName (Map FlagName Bool) , Map PackageName Version) -> m ( Resolver , Map PackageName (Map FlagName Bool) , Map PackageName Version) -solveResolverSpec stackYaml cabalDirs (resolver, flags, extraPackages) = do +solveResolverSpec stackYaml cabalDirs packages + (resolver, flags, extraPackages) = do $logInfo $ "Using resolver: " <> resolverName resolver (compilerVer, snapPackages) <- getResolverMiniPlan resolver menv <- setupCabalEnv compilerVer -- Note - The order in Map.union below is important. - -- We prefer extraPackages over the snapshot - let availablePkgs = Map.union extraPackages snapPackages + -- If versions of packages we are building are also available in the + -- snapshot then we override those with the versions we are building. + -- Also, we prefer extraPackages over the snapshot packages. + let availablePkgs = Map.union packages $ + Map.union extraPackages snapPackages solver t = cabalSolver menv cabalDirs t availablePkgs flags $ ["-v"] -- TODO make it conditional on debug ++ ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs] @@ -447,6 +452,7 @@ solveExtraDeps modStackYaml = do BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) BuildPlanCheckPartial _ _ -> solveResolverSpec stackYaml cabalDirs + (gpdPackages gpds) ( resolver , oldFlags , oldExtraDeps) From 02ae47c1a3340e1229d0f55ff2e7e911dd1b59c5 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 4 Jan 2016 14:53:09 +0530 Subject: [PATCH 18/29] Remove redundant status message Other minor cosmetic changes as well. --- src/Stack/BuildPlan.hs | 7 ++++--- src/Stack/Init.hs | 10 +++------- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 488e921af6..3d053f0567 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -695,8 +695,9 @@ selectBestSnapshot gpds snaps = do | (Map.size e1) <= (Map.size e2) = (s1, e1) | otherwise = (s2, e2) - reportResult (BuildPlanCheckOk _) snap = + reportResult (BuildPlanCheckOk _) snap = do $logInfo $ "* Selected " <> renderSnapName snap + $logInfo "" reportResult (BuildPlanCheckPartial _ errs) snap = do $logWarn $ "* Partially matches " <> renderSnapName snap @@ -705,9 +706,9 @@ selectBestSnapshot gpds snaps = do reportResult (BuildPlanCheckFail compiler errs) snap = do $logWarn $ "* Rejected " <> renderSnapName snap - <> " due to conflicting compiler (" + <> " due to conflict of compiler (" <> compilerVersionText compiler - <> ") requirements" + <> ") packages" displayDepErrors errs displayDepErrors :: MonadLogger m => DepErrors -> m () diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 28c2f55104..fc3c4e5c7e 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -204,20 +204,16 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do | otherwise -> throwM $ ResolverPartial resolver where -- TODO support selecting best across regular and custom snapshots - getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref + getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver selectSnapResolver snapPref = getSnapshots' >>= maybe (throwM NoMatchingSnapshot) - (getRecommendedSnapshots snapPref) + (getRecommendedSnapshots snapPref) >>= selectBestSnapshot gpds >>= maybe (throwM NoMatchingSnapshot) - (\s -> do - $logInfo ("Selected snapshot '" - <> (renderSnapName s) - <> "'.") - return $ ResolverSnapshot s) + (return . ResolverSnapshot) needSolver _ (InitOpts {useSolver = True}) = True needSolver (ResolverCompiler _) _ = True From f91eac2013b9a421c4f7f0122bb2558da4531622 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 4 Jan 2016 18:01:02 +0530 Subject: [PATCH 19/29] Force write an incomplete config when solver fails Also, made the post failure recommendations more concise and a few other minor error message tweaks. --- src/Stack/Init.hs | 31 ++++++++++++++++++++++++++----- src/Stack/Solver.hs | 35 ++++++++++++++--------------------- src/Stack/Types/Build.hs | 15 +++++++++++++++ 3 files changed, 55 insertions(+), 26 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index fc3c4e5c7e..12a5f103d4 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -103,8 +103,11 @@ initProject currDir initOpts = do , peSubdirs = [] } - $logInfo $ "Initialising stack configuration using resolver: " <> resolverName r - $logInfo $ "Writing stack configuration to: " <> T.pack reldest + $logInfo $ "Initialising configuration using resolver: " <> resolverName r + $logInfo $ + (if exists then "Overwriting existing configuration file: " + else "Writing configuration to file: ") + <> T.pack reldest liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p $logInfo "All done." @@ -198,11 +201,29 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) BuildPlanCheckPartial flags _ - | needSolver resolver initOpts -> - solveResolverSpec stackYaml cabalDirs (gpdPackages gpds) - (resolver, flags, Map.empty) + | needSolver resolver initOpts -> solve (resolver, flags) | otherwise -> throwM $ ResolverPartial resolver + where + solve (res, f) = do + let partialSpec = (res, f, Map.empty) + mresolver <- solveResolverSpec stackYaml cabalDirs + (gpdPackages gpds) + partialSpec + case mresolver of + Just r -> return r + Nothing + | forceOverwrite initOpts -> do + $logWarn "\nSolver could not arrive at a workable build \ + \plan.\nProceeding to create a config with an \ + \incomplete plan anyway..." + return partialSpec + | otherwise -> do + let footer = "Use '--force' to create " + <> toFilePath stackDotYaml <> + " with an incomplete build plan anyway." + throwM (SolverGiveUp $ Just footer) + -- TODO support selecting best across regular and custom snapshots getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 4bd231a77d..32bc1cfcc7 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -42,7 +42,6 @@ import Path.Find (findFiles) import Path.IO (parseRelAsAbsDir) import Prelude import Stack.BuildPlan -import Stack.Constants (stackDotYaml) import Stack.Package (printCabalFileWarning , readPackageUnresolved) import Stack.Setup @@ -265,9 +264,9 @@ solveResolverSpec -> ( Resolver , Map PackageName (Map FlagName Bool) , Map PackageName Version) - -> m ( Resolver - , Map PackageName (Map FlagName Bool) - , Map PackageName Version) + -> m (Maybe ( Resolver + , Map PackageName (Map FlagName Bool) + , Map PackageName Version)) solveResolverSpec stackYaml cabalDirs packages (resolver, flags, extraPackages) = do $logInfo $ "Using resolver: " <> resolverName resolver @@ -309,23 +308,13 @@ solveResolverSpec stackYaml cabalDirs packages <> T.pack (show $ Map.size newPairs) <> " external dependencies." - return ( resolver + return $ Just ( resolver , Map.filter (not . Map.null) (fmap snd pairs) , fmap fst newPairs) - Nothing -> - error ("Solver could not resolve package dependencies. " - <> "You can try one or more of the following:\n" - <> "- If the problem is due to a stale package index you can try " - <> "again after udating the package index with 'stack update'.\n" - <> "- Guide the solver by specifying some of the " - <> "extra dependencies in " <> toFilePath stackDotYaml - <> " and then use 'stack solver' figure out the rest.\n" - <> "- Check if you missed adding a custom package or remote " - <> "package location needed to build your package.\n" - <> "- You may also want to remove any unnecessary packages " - <> "causing dependency problems.\n" - <> "- Use '--ignore-subdirs' to avoid using unwanted .cabal files " - <> "in subdirectories.") + Nothing -> do + $logInfo $ "Failed to arrive at a workable build plan using " + <> resolverName resolver <> " resolver." + return Nothing where getResolverMiniPlan (ResolverSnapshot snapName) = do mbp <- loadMiniBuildPlan snapName @@ -448,15 +437,19 @@ solveExtraDeps modStackYaml = do resolver = bcResolver bconfig result <- checkResolverSpec gpds (Just oldFlags) resolver - (_, flags, extraDeps) <- case result of + resolverSpec <- case result of BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver - BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) + BuildPlanCheckOk flags -> return $ Just (resolver, flags, Map.empty) BuildPlanCheckPartial _ _ -> solveResolverSpec stackYaml cabalDirs (gpdPackages gpds) ( resolver , oldFlags , oldExtraDeps) + (flags, extraDeps) <- case resolverSpec of + Nothing -> throwM (SolverGiveUp Nothing) + Just (_, f, e) -> return (f, e) + let vDiff v v' = if v == v' then Nothing else Just v depsDiff = Map.differenceWith vDiff diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 71c16f2df0..af28f5ab20 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -70,6 +70,7 @@ import GHC.Generics import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ()) import Path.Extra (toFilePathNoTrailingSep) import Prelude +import Stack.Constants (stackDotYaml) import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.Compiler @@ -120,6 +121,7 @@ data StackBuildException | InvalidFlagSpecification (Set UnusedFlags) | TargetParseException [Text] | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])] + | SolverGiveUp (Maybe String) | SolverMissingCabalInstall | SomeTargetsNotBuildable [(PackageName, NamedComponent)] deriving Typeable @@ -320,6 +322,19 @@ instance Show StackBuildException where : (packageNameString name ++ " used in:") : map goDir dirs goDir dir = "- " ++ toFilePath dir + show (SolverGiveUp footer) = concat + [ "\nSolver could not resolve package dependencies. " + , "You can:\n" + , "- Use 'stack update' to update the package index and try again.\n" + , "- Add some extra dependencies in " <> toFilePath stackDotYaml + , " and then use 'stack solver' to figure out the rest.\n" + , "- Add any missed local or remote source package required to " + , "build your package.\n" + , "- Remove any unnecessary packages which may be causing dependency " + , "issues.\n" + , "- Use '--ignore-subdirs' to ignore packages in subdirectories.\n" + , maybe "" (("\n" <>) . id) footer + ] show SolverMissingCabalInstall = unlines [ "Solver requires that cabal be on your PATH" , "Try running 'stack install cabal-install'" From d90251f4fd7a33482c53192785cbc16d735ae3a2 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 4 Jan 2016 23:01:31 +0530 Subject: [PATCH 20/29] Solver: handle src packages not having version set --- src/Stack/Solver.hs | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 32bc1cfcc7..12f3ecc292 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -11,6 +11,7 @@ module Stack.Solver ) where import Control.Applicative +import Control.Exception (assert) import Control.Exception.Enclosed (tryIO) import Control.Monad.Catch import Control.Monad.IO.Class @@ -156,7 +157,7 @@ cabalSolver menv cabalfps constraintType constraints userFlags cabalArgs = withS in "--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag] -getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) +getCabalConfig :: (MonadLogger m, MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir -> ConstraintType -> Map PackageName Version -- ^ constraints @@ -267,18 +268,23 @@ solveResolverSpec -> m (Maybe ( Resolver , Map PackageName (Map FlagName Bool) , Map PackageName Version)) -solveResolverSpec stackYaml cabalDirs packages +solveResolverSpec stackYaml cabalDirs srcPackages (resolver, flags, extraPackages) = do $logInfo $ "Using resolver: " <> resolverName resolver (compilerVer, snapPackages) <- getResolverMiniPlan resolver menv <- setupCabalEnv compilerVer + + let assertVer v = assert ((not . null . versionString) v) $ return () + mapM_ assertVer snapPackages + mapM_ assertVer extraPackages + -- Note - The order in Map.union below is important. - -- If versions of packages we are building are also available in the - -- snapshot then we override those with the versions we are building. - -- Also, we prefer extraPackages over the snapshot packages. - let availablePkgs = Map.union packages $ - Map.union extraPackages snapPackages - solver t = cabalSolver menv cabalDirs t availablePkgs flags $ + -- We prefer extraPackages over the snapshot packages. + let externalPackages = Map.union extraPackages snapPackages + -- We cannot have the snapshot versions of source packages as + -- constraints. + constraints = Map.difference externalPackages srcPackages + solver t = cabalSolver menv cabalDirs t constraints flags $ ["-v"] -- TODO make it conditional on debug ++ ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs] @@ -289,12 +295,12 @@ solveResolverSpec stackYaml cabalDirs packages | not (Map.null extraPackages)] $logInfo "Asking cabal to calculate a build plan..." - unless (Map.null availablePkgs) + unless (Map.null constraints) ($logInfo $ "Trying with " <> srcNames <> " as hard constraints...") mdeps <- solver Constraint mdeps' <- case mdeps of - Nothing | not (Map.null availablePkgs) -> do + Nothing | not (Map.null constraints) -> do $logInfo $ "Retrying with " <> srcNames <> " as preferences..." solver Preference _ -> return mdeps From 62faff0dfa5c24e215d4dd0a23effacee050c407 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 5 Jan 2016 13:53:26 +0530 Subject: [PATCH 21/29] Fix GHC 7.8.4 compilation Instead of using mapM_ on a Map moved the assert deeper where it can be applied on a single Map entry. --- src/Stack/Solver.hs | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 12f3ecc292..dfef34c8bc 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -181,14 +181,16 @@ getCabalConfig dir constraintType constraints = do , ":http://0.0.0.0/fake-url" ] - goConstraint (name, version) = T.concat - [ (if constraintType == Constraint - then "constraint: " - else "preference: ") - , T.pack $ packageNameString name - , "==" - , T.pack $ versionString version - ] + goConstraint (name, version) = + assert (not . null . versionString $ version) $ + T.concat + [ (if constraintType == Constraint + then "constraint: " + else "preference: ") + , T.pack $ packageNameString name + , "==" + , T.pack $ versionString version + ] setupCompiler :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m @@ -274,10 +276,6 @@ solveResolverSpec stackYaml cabalDirs srcPackages (compilerVer, snapPackages) <- getResolverMiniPlan resolver menv <- setupCabalEnv compilerVer - let assertVer v = assert ((not . null . versionString) v) $ return () - mapM_ assertVer snapPackages - mapM_ assertVer extraPackages - -- Note - The order in Map.union below is important. -- We prefer extraPackages over the snapshot packages. let externalPackages = Map.union extraPackages snapPackages From 2ddf64c66b78ba9f4b75284acdc96d786c9ff6f3 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 5 Jan 2016 15:36:18 +0530 Subject: [PATCH 22/29] Solver: Update resolver when updating config When solver is called with --resolver and resolver changes from what is there in stack.yaml already then show changed resolver in output and also update it in config when called with --modify-stack-yaml Also, reformatted the output so as to distinguish regular messages a bit from yaml formatted messages. --- src/Stack/Solver.hs | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index dfef34c8bc..e99c0c7041 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -469,17 +469,22 @@ solveExtraDeps modStackYaml = do || any (not . Map.null) [newFlags, goneFlags] if changed then do + $logInfo "" $logInfo $ "The following changes will be made to " <> T.pack relStackYaml <> ":" - printFlags newFlags "New" - printDeps newDeps "New" + -- TODO print whether resolver changed from previous + $logInfo $ "* Resolver is " <> resolverName resolver - printFlags goneFlags "Deleted" - printDeps goneDeps "Deleted" + -- TODO indent the yaml output + printFlags newFlags "* Flags to be added" + printDeps newDeps "* Dependencies to be added" + + printFlags goneFlags "* Flags to be deleted" + printDeps goneDeps "* Dependencies to be deleted" if modStackYaml then do - writeStackYaml stackYaml extraDeps flags + writeStackYaml stackYaml resolver extraDeps flags $logInfo $ "Updated " <> T.pack relStackYaml else do $logInfo $ "To automatically update " <> T.pack relStackYaml @@ -490,18 +495,16 @@ solveExtraDeps modStackYaml = do where printFlags fl msg = do when ((not . Map.null) fl) $ do - $logInfo "" - $logInfo $ T.pack msg <> " flags:" + $logInfo $ T.pack msg $logInfo $ decodeUtf8 $ Yaml.encode $ object ["flags" .= fl] printDeps deps msg = do when ((not . Map.null) deps) $ do - $logInfo "" - $logInfo $ T.pack msg <> " dependencies:" + $logInfo $ T.pack msg $logInfo $ decodeUtf8 $ Yaml.encode $ object $ [("extra-deps" .= map fromTuple (Map.toList deps))] - writeStackYaml path deps fl = do + writeStackYaml path res deps fl = do let fp = toFilePath path obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return (ProjectAndConfigMonoid _ _, warnings) <- @@ -510,5 +513,6 @@ solveExtraDeps modStackYaml = do let obj' = HashMap.insert "extra-deps" (toJSON $ map fromTuple $ Map.toList deps) - $ HashMap.insert ("flags" :: Text) (toJSON fl) obj + $ HashMap.insert ("flags" :: Text) (toJSON fl) + $ HashMap.insert ("resolver" :: Text) (toJSON (resolverName res)) obj liftIO $ Yaml.encodeFile fp obj' From 5126e680ab9fca8b189d161c3d0b594d2f99506b Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 5 Jan 2016 15:48:52 +0530 Subject: [PATCH 23/29] Solver: change option name --modify-stack-yaml The solver option --modify-stack-yaml is changed to --update-config --- src/Stack/Options.hs | 4 ++-- src/Stack/Solver.hs | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index b5d9c6579f..5f20614f43 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -783,8 +783,8 @@ ghcVariantParser hide = -- | Parser for @solverCmd@ solverOptsParser :: Parser Bool solverOptsParser = boolFlags False - "modify-stack-yaml" - "Automatically modify stack.yaml with the solver's recommendations" + "update-config" + "Automatically update stack.yaml with the solver's recommendations" idm -- | Parser for test arguments. diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index e99c0c7041..4e51f3c5d1 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -483,12 +483,13 @@ solveExtraDeps modStackYaml = do printFlags goneFlags "* Flags to be deleted" printDeps goneDeps "* Dependencies to be deleted" + -- TODO backup the old config file if modStackYaml then do writeStackYaml stackYaml resolver extraDeps flags $logInfo $ "Updated " <> T.pack relStackYaml else do $logInfo $ "To automatically update " <> T.pack relStackYaml - <> ", rerun with '--modify-stack-yaml'" + <> ", rerun with '--update-config'" else $logInfo $ "No changes needed to " <> T.pack relStackYaml From 86334c6062954ffa078cea283896a351ca52077e Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 6 Jan 2016 01:31:36 +0530 Subject: [PATCH 24/29] Take flags into account to compute extra deps Solver issues fixed with this commit are: When solver returns flag changes for packages which are in snapshot, we update the flags in stack.yaml but we do not put those packages in extra dependencies. When we run stack build it complains about it. We are not comparing the snapshot package flags (we compare only the version) when determining extra dependencies. If the snapshot flags are different than those the solver arrived at then we need to put those packages in extra dependencies. Otherwise the plan will not build because the status of flags can change dependencies. --- src/Stack/Init.hs | 12 +-- src/Stack/Solver.hs | 193 ++++++++++++++++++++++++++++---------------- 2 files changed, 132 insertions(+), 73 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 12a5f103d4..9ce8558223 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -206,18 +206,20 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do where solve (res, f) = do - let partialSpec = (res, f, Map.empty) + let srcConstraints = mergeConstraints (gpdPackages gpds) f mresolver <- solveResolverSpec stackYaml cabalDirs - (gpdPackages gpds) - partialSpec + (res, srcConstraints, Map.empty) case mresolver of - Just r -> return r + Just (src, ext) -> do + let flags = fmap snd (Map.union src ext) + flags' = Map.filter (not . Map.null) flags + return (res, flags', fmap fst ext) Nothing | forceOverwrite initOpts -> do $logWarn "\nSolver could not arrive at a workable build \ \plan.\nProceeding to create a config with an \ \incomplete plan anyway..." - return partialSpec + return (res, f, Map.empty) | otherwise -> do let footer = "Use '--force' to create " <> toFilePath stackDotYaml <> diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 4e51f3c5d1..8e0f89155c 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -6,6 +6,7 @@ module Stack.Solver ( checkResolverSpec , cabalPackagesCheck , findCabalFiles + , mergeConstraints , solveExtraDeps , solveResolverSpec ) where @@ -60,17 +61,22 @@ import System.IO.Temp (withSystemTempDirectory) import System.Process.Read data ConstraintType = Constraint | Preference deriving (Eq) +type ConstraintSpec = Map PackageName (Version, Map FlagName Bool) cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env) => EnvOverride -> [Path Abs Dir] -- ^ cabal files -> ConstraintType - -> Map PackageName Version -- ^ constraints - -> Map PackageName (Map FlagName Bool) -- ^ user-specified flags + -> ConstraintSpec -- ^ src constraints + -> ConstraintSpec -- ^ dep constraints -> [String] -- ^ additional arguments - -> m (Maybe (Map PackageName (Version, Map FlagName Bool))) -cabalSolver menv cabalfps constraintType constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do - configLines <- getCabalConfig dir constraintType constraints + -> m (Maybe ConstraintSpec) +cabalSolver menv cabalfps constraintType + srcConstraints depConstraints cabalArgs = + withSystemTempDirectory "cabal-solver" $ \dir -> do + + let versionConstraints = fmap fst depConstraints + configLines <- getCabalConfig dir constraintType versionConstraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines @@ -93,7 +99,7 @@ cabalSolver menv cabalfps constraintType constraints userFlags cabalArgs = withS : "--package-db=clear" : "--package-db=global" : cabalArgs ++ - toConstraintArgs userFlags ++ + toConstraintArgs (flagConstraints constraintType) ++ fmap toFilePath cabalfps catch (liftM Just (readProcessStdout (Just tmpdir) menv "cabal" args)) @@ -157,6 +163,15 @@ cabalSolver menv cabalfps constraintType constraints userFlags cabalArgs = withS in "--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag] + -- Note the order of the Map union is important + -- We override a package in snapshot by a src package + flagConstraints Constraint = fmap snd (Map.union srcConstraints + depConstraints) + -- Even when using preferences we want to + -- keep the src package flags unchanged + -- TODO - this should be done only for manual flags. + flagConstraints Preference = fmap snd srcConstraints + getCabalConfig :: (MonadLogger m, MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir -> ConstraintType @@ -256,6 +271,27 @@ setupCabalEnv compiler = do \This is most likely a bug." return menv +mergeConstraints + :: Map PackageName v + -> Map PackageName (Map p f) + -> Map PackageName (v, Map p f) +mergeConstraints = Map.mergeWithKey + -- combine entry in both maps + (\_ v f -> Just (v, f)) + -- convert entry in first map only + (fmap (flip (,) Map.empty)) + -- convert entry in second map only + (\m -> if Map.null m then Map.empty + else error "Bug: An entry in flag map must have a corresponding \ + \entry in the version map") + +diffConstraints + :: (Eq v, Eq f) + => (v, f) -> (v, f) -> Maybe (v, f) +diffConstraints (v, f) (v', f') + | (v == v') && (f == f') = Nothing + | otherwise = Just (v, f) + solveResolverSpec :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasGHCVariant env @@ -263,75 +299,88 @@ solveResolverSpec , HasTerminal env) => Path Abs File -- ^ stack.yaml file location -> [Path Abs Dir] -- ^ package dirs containing cabal files - -> Map PackageName Version -- ^ local packages to build -> ( Resolver - , Map PackageName (Map FlagName Bool) - , Map PackageName Version) - -> m (Maybe ( Resolver - , Map PackageName (Map FlagName Bool) - , Map PackageName Version)) -solveResolverSpec stackYaml cabalDirs srcPackages - (resolver, flags, extraPackages) = do + , ConstraintSpec -- ^ src package constraints + , ConstraintSpec) -- ^ extra dependency constraints + -> m (Maybe ( ConstraintSpec -- ^ resulting src package specs + , ConstraintSpec)) -- ^ resulting external package specs +solveResolverSpec stackYaml cabalDirs + (resolver, srcConstraints, extraConstraints) = do $logInfo $ "Using resolver: " <> resolverName resolver - (compilerVer, snapPackages) <- getResolverMiniPlan resolver + (compilerVer, snapConstraints) <- getResolverConstraints resolver menv <- setupCabalEnv compilerVer - -- Note - The order in Map.union below is important. - -- We prefer extraPackages over the snapshot packages. - let externalPackages = Map.union extraPackages snapPackages - -- We cannot have the snapshot versions of source packages as - -- constraints. - constraints = Map.difference externalPackages srcPackages - solver t = cabalSolver menv cabalDirs t constraints flags $ + let -- Note - The order in Map.union below is important. + -- We want to override snapshot with extra deps + depConstraints = Map.union extraConstraints snapConstraints + -- Make sure deps do not include any src packages + -- There are two reasons for this: + -- 1. We do not want snapshot versions to override the sources + -- 2. Sources may not have versions leading to bad cabal constraints + depOnlyConstraints = Map.difference depConstraints srcConstraints + solver t = cabalSolver menv cabalDirs t + srcConstraints depOnlyConstraints $ ["-v"] -- TODO make it conditional on debug ++ ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs] let srcNames = (T.intercalate " and ") $ ["packages from " <> resolverName resolver - | not (Map.null snapPackages)] ++ - [T.pack ((show $ Map.size extraPackages) <> " external packages") - | not (Map.null extraPackages)] + | not (Map.null snapConstraints)] ++ + [T.pack ((show $ Map.size extraConstraints) <> " external packages") + | not (Map.null extraConstraints)] $logInfo "Asking cabal to calculate a build plan..." - unless (Map.null constraints) + unless (Map.null depOnlyConstraints) ($logInfo $ "Trying with " <> srcNames <> " as hard constraints...") mdeps <- solver Constraint mdeps' <- case mdeps of - Nothing | not (Map.null constraints) -> do + Nothing | not (Map.null depOnlyConstraints) -> do $logInfo $ "Retrying with " <> srcNames <> " as preferences..." solver Preference _ -> return mdeps case mdeps' of - Just pairs -> do - let versiondiff (v, f) v' = if v == v' then Nothing else Just (v, f) - newPairs = Map.differenceWith versiondiff pairs snapPackages - - $logInfo $ "Successfully determined a build plan with " - <> T.pack (show $ Map.size newPairs) - <> " external dependencies." - - return $ Just ( resolver - , Map.filter (not . Map.null) (fmap snd pairs) - , fmap fst newPairs) - Nothing -> do - $logInfo $ "Failed to arrive at a workable build plan using " - <> resolverName resolver <> " resolver." - return Nothing + Just deps -> do + let + -- All src package constraints returned by cabal. + -- Flags may have changed. + srcs = Map.intersection deps srcConstraints + inSnap = Map.intersection deps snapConstraints + -- All packages which are in the snapshot but cabal solver + -- returned versions or flags different from the snapshot. + inSnapChanged = Map.differenceWith diffConstraints + inSnap snapConstraints + -- Packages neither in snapshot, nor srcs + extra = Map.difference deps (Map.union srcConstraints + snapConstraints) + external = Map.union inSnapChanged extra + + $logInfo $ "Successfully determined a build plan with " + <> T.pack (show $ Map.size external) + <> " external dependencies." + + return $ Just (srcs, external) + Nothing -> do + $logInfo $ "Failed to arrive at a workable build plan using " + <> resolverName resolver <> " resolver." + return Nothing where - getResolverMiniPlan (ResolverSnapshot snapName) = do + mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi) + mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp) + + getResolverConstraints (ResolverSnapshot snapName) = do mbp <- loadMiniBuildPlan snapName - return (mbpCompilerVersion mbp, fmap mpiVersion (mbpPackages mbp)) + return (mbpCompilerVersion mbp, mbpConstraints mbp) - getResolverMiniPlan (ResolverCompiler compiler) = + getResolverConstraints (ResolverCompiler compiler) = return (compiler, Map.empty) -- FIXME instead of passing the stackYaml dir we should maintain -- the file URL in the custom resolver always relative to stackYaml. - getResolverMiniPlan (ResolverCustom _ url) = do + getResolverConstraints (ResolverCustom _ url) = do mbp <- parseCustomMiniBuildPlan stackYaml url - return (mbpCompilerVersion mbp, fmap mpiVersion (mbpPackages mbp)) + return (mbpCompilerVersion mbp, mbpConstraints mbp) -- | Given a bundle of packages and a resolver, check the resolver with respect -- to the packages and return how well the resolver satisfies the depndencies @@ -436,36 +485,44 @@ solveExtraDeps modStackYaml = do cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter - let oldFlags = bcFlags bconfig - oldExtraDeps = bcExtraDeps bconfig - resolver = bcResolver bconfig + let oldFlags = bcFlags bconfig + oldExtraVersions = bcExtraDeps bconfig + resolver = bcResolver bconfig + oldSrcs = gpdPackages gpds + oldSrcFlags = Map.intersection oldFlags oldSrcs + oldExtraFlags = Map.intersection oldFlags oldExtraVersions - result <- checkResolverSpec gpds (Just oldFlags) resolver - resolverSpec <- case result of + srcConstraints = mergeConstraints oldSrcs oldSrcFlags + extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags + + resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver + resultSpecs <- case resolverResult of BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver - BuildPlanCheckOk flags -> return $ Just (resolver, flags, Map.empty) - BuildPlanCheckPartial _ _ -> solveResolverSpec stackYaml cabalDirs - (gpdPackages gpds) - ( resolver - , oldFlags - , oldExtraDeps) - - (flags, extraDeps) <- case resolverSpec of + BuildPlanCheckOk flags -> + return $ Just ((mergeConstraints oldSrcs flags), Map.empty) + BuildPlanCheckPartial _ _ -> + solveResolverSpec stackYaml cabalDirs + (resolver, srcConstraints, extraConstraints) + + (srcs, edeps) <- case resultSpecs of Nothing -> throwM (SolverGiveUp Nothing) - Just (_, f, e) -> return (f, e) + Just x -> return x let + flags = Map.filter (not . Map.null) (fmap snd (Map.union srcs edeps)) + versions = fmap fst edeps + vDiff v v' = if v == v' then Nothing else Just v - depsDiff = Map.differenceWith vDiff - newDeps = depsDiff extraDeps oldExtraDeps - goneDeps = depsDiff oldExtraDeps extraDeps + versionsDiff = Map.differenceWith vDiff + newVersions = versionsDiff versions oldExtraVersions + goneVersions = versionsDiff oldExtraVersions versions fDiff f f' = if f == f' then Nothing else Just f flagsDiff = Map.differenceWith fDiff newFlags = flagsDiff flags oldFlags goneFlags = flagsDiff oldFlags flags - changed = any (not . Map.null) [newDeps, goneDeps] + changed = any (not . Map.null) [newVersions, goneVersions] || any (not . Map.null) [newFlags, goneFlags] if changed then do @@ -478,14 +535,14 @@ solveExtraDeps modStackYaml = do -- TODO indent the yaml output printFlags newFlags "* Flags to be added" - printDeps newDeps "* Dependencies to be added" + printDeps newVersions "* Dependencies to be added" printFlags goneFlags "* Flags to be deleted" - printDeps goneDeps "* Dependencies to be deleted" + printDeps goneVersions "* Dependencies to be deleted" -- TODO backup the old config file if modStackYaml then do - writeStackYaml stackYaml resolver extraDeps flags + writeStackYaml stackYaml resolver versions flags $logInfo $ "Updated " <> T.pack relStackYaml else do $logInfo $ "To automatically update " <> T.pack relStackYaml From 551ce58f35d9f316af51257baeea89076ced36fe Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 6 Jan 2016 19:29:39 +0530 Subject: [PATCH 25/29] Do not write empty flags with stack init --force Filter out any empty flag values so that we do not end up having lots of package flags set to empty values in stack.yaml. --- src/Stack/Init.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 9ce8558223..ad41dceddb 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -85,7 +85,8 @@ initProject currDir initOpts = do let p = Project { projectPackages = pkgs , projectExtraDeps = extraDeps - , projectFlags = flags + -- TODO do not write flags with default values + , projectFlags = Map.filter (not . Map.null) flags , projectResolver = r , projectCompiler = Nothing , projectExtraPackageDBs = [] @@ -211,9 +212,7 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do (res, srcConstraints, Map.empty) case mresolver of Just (src, ext) -> do - let flags = fmap snd (Map.union src ext) - flags' = Map.filter (not . Map.null) flags - return (res, flags', fmap fst ext) + return (res, fmap snd (Map.union src ext), fmap fst ext) Nothing | forceOverwrite initOpts -> do $logWarn "\nSolver could not arrive at a workable build \ From f71f80e23b7f1d20591863ffa89e197692b59195 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 7 Jan 2016 00:44:50 +0530 Subject: [PATCH 26/29] Show flags along with dep errors in debug mode The build plan checks show dependency errors about packages when a particular build plan does not match. But flags can affect dependencies and are therefore needed to verify the errors. This commit adds code to print the flags as well in debug mode. Avoid in normal mode for the sake of brevity of info. --- src/Stack/BuildPlan.hs | 39 +++++++++++++++++++++++++++------------ src/Stack/Init.hs | 2 +- src/Stack/Solver.hs | 2 +- 3 files changed, 29 insertions(+), 14 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 3d053f0567..c51e7fde7f 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -27,7 +27,7 @@ module Stack.BuildPlan import Control.Applicative import Control.Exception (assert) -import Control.Monad (liftM, forM) +import Control.Monad (liftM, forM, when) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger @@ -621,9 +621,10 @@ checkBundleBuildPlan platform compiler pool flags gpds = dupError _ _ = error "Bug: Duplicate packages are not expected here" data BuildPlanCheck = - BuildPlanCheckFail CompilerVersion DepErrors - | BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) + BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors + | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors + CompilerVersion -- | Check a set of 'GenericPackageDescription's and a set of flags against a -- given snapshot. Returns how well the snapshot satisfies the dependencies of @@ -651,7 +652,7 @@ checkSnapBuildPlan gpds flags snap = do else if Map.null cerrs then do return $ BuildPlanCheckPartial f errs else - return $ BuildPlanCheckFail compiler cerrs + return $ BuildPlanCheckFail f cerrs compiler where compilerErrors compiler errs | whichCompiler compiler == Ghc = ghcErrors errs @@ -683,7 +684,7 @@ selectBestSnapshot gpds snaps = do result <- checkSnapBuildPlan gpds Nothing snap reportResult result snap case result of - BuildPlanCheckFail _ _ -> loop bestYet rest + BuildPlanCheckFail _ _ _ -> loop bestYet rest BuildPlanCheckOk _ -> return $ Just snap BuildPlanCheckPartial _ e -> do case bestYet of @@ -699,20 +700,24 @@ selectBestSnapshot gpds snaps = do $logInfo $ "* Selected " <> renderSnapName snap $logInfo "" - reportResult (BuildPlanCheckPartial _ errs) snap = do + reportResult (BuildPlanCheckPartial f errs) snap = do $logWarn $ "* Partially matches " <> renderSnapName snap - displayDepErrors errs + displayDepErrors f errs - reportResult (BuildPlanCheckFail compiler errs) snap = do + reportResult (BuildPlanCheckFail f errs compiler) snap = do $logWarn $ "* Rejected " <> renderSnapName snap <> " due to conflict of compiler (" <> compilerVersionText compiler <> ") packages" - displayDepErrors errs - -displayDepErrors :: MonadLogger m => DepErrors -> m () -displayDepErrors errs = + displayDepErrors f errs + +displayDepErrors + :: MonadLogger m + => Map PackageName (Map FlagName Bool) + -> DepErrors + -> m () +displayDepErrors flags errs = F.forM_ (Map.toList errs) $ \(depName, DepError mversion neededBy) -> do $logInfo $ T.concat [ " " @@ -731,7 +736,17 @@ displayDepErrors errs = , " requires " , T.pack $ display range ] + F.forM_ (Map.toList neededBy) $ \(user, _) -> + maybe (return ()) (printFlags user) (Map.lookup user flags) $logInfo "" + where + printFlags user fl = when (not $ Map.null fl) $ + $logDebug $ T.concat + [ " - " + , T.pack $ packageNameString user + , " configured with flags " + , T.pack $ (show fl) + ] shadowMiniBuildPlan :: MiniBuildPlan -> Set PackageName diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index ad41dceddb..4807f585fc 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -199,11 +199,11 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do result <- checkResolverSpec gpds Nothing resolver case result of - BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) BuildPlanCheckPartial flags _ | needSolver resolver initOpts -> solve (resolver, flags) | otherwise -> throwM $ ResolverPartial resolver + BuildPlanCheckFail _ _ _ -> throwM $ ResolverMismatch resolver where solve (res, f) = do diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 8e0f89155c..4be3773691 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -497,12 +497,12 @@ solveExtraDeps modStackYaml = do resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver resultSpecs <- case resolverResult of - BuildPlanCheckFail _ _ -> throwM $ ResolverMismatch resolver BuildPlanCheckOk flags -> return $ Just ((mergeConstraints oldSrcs flags), Map.empty) BuildPlanCheckPartial _ _ -> solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, extraConstraints) + BuildPlanCheckFail _ _ _ -> throwM $ ResolverMismatch resolver (srcs, edeps) <- case resultSpecs of Nothing -> throwM (SolverGiveUp Nothing) From 27136065fceafe118c1c061467501174cf3a453d Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 7 Jan 2016 02:06:25 +0530 Subject: [PATCH 27/29] Solver: report missing packages When only selected packages are added in stack.yaml solver will now print a message about which packages are available under the current dir subtree which are not found in the config. --- src/Stack/Solver.hs | 42 ++++++++++++++++++++++++++++++++++-------- 1 file changed, 34 insertions(+), 8 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 4be3773691..c5bc914a77 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -23,7 +23,7 @@ import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarni import qualified Data.ByteString as S import Data.Either import qualified Data.HashMap.Strict as HashMap -import Data.List (isSuffixOf, intercalate) +import Data.List ((\\), isSuffixOf, intercalate) import Data.List.Extra (groupSortOn) import Data.Map (Map) import qualified Data.Map as Map @@ -41,7 +41,7 @@ import qualified Distribution.PackageDescription as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.Find (findFiles) -import Path.IO (parseRelAsAbsDir) +import Path.IO (getWorkingDir, parseRelAsAbsDir) import Prelude import Stack.BuildPlan import Stack.Package (printCabalFileWarning @@ -451,13 +451,36 @@ cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do return gpds where - makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath groups = filter ((> 1) . length) . groupSortOn (FP.takeFileName) dupGroups = (map formatGroup) . groups - formatPath path = "- " <> path <> "\n" - formatGroup = concat . (map formatPath) --- | Determine missing extra-deps +makeRel :: (MonadIO m) => Path Abs File -> m FilePath +makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath + +formatGroup :: [String] -> String +formatGroup = concat . (map formatPath) + where formatPath path = "- " <> path <> "\n" + +reportMissingCabalFiles + :: (MonadIO m, MonadLogger m) => [Path Abs File] -> Bool -> m () +reportMissingCabalFiles cabalfps includeSubdirs = do + allCabalfps <- findCabalFiles (includeSubdirs) =<< getWorkingDir + + relpaths <- mapM makeRel (allCabalfps \\ cabalfps) + $logWarn $ "The following packages are missing from the config:" + $logWarn $ T.pack (formatGroup relpaths) + +-- | Solver can be thought of as a counterpart of init. init creates a +-- stack.yaml whereas solver verifies or fixes an existing one. It can verify +-- the dependencies of the packages and determine if any extra-dependecies +-- outside the snapshots are needed. +-- +-- TODO Currently solver uses a stack.yaml in the parent chain when there is +-- no stack.yaml in the current directory. It should instead look for a +-- stack yaml only in the current directory and suggest init if there is +-- none available. That will make the behavior consistent with init and provide +-- a correct meaning to a --ignore-subdirs option if implemented. + solveExtraDeps :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasEnvConfig env, HasGHCVariant env @@ -470,8 +493,7 @@ solveExtraDeps modStackYaml = do bconfig <- asks getBuildConfig let stackYaml = bcStackYaml bconfig - relStackYaml <- liftIO $ makeRelativeToCurrentDirectory - $ toFilePath stackYaml + relStackYaml <- makeRel stackYaml $logInfo $ "Using configuration file: " <> T.pack relStackYaml let cabalDirs = Map.keys $ envConfigPackages econfig @@ -485,6 +507,10 @@ solveExtraDeps modStackYaml = do cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter + -- TODO when solver supports --ignore-subdirs option pass that as the + -- second argument here. + reportMissingCabalFiles cabalfps True + let oldFlags = bcFlags bconfig oldExtraVersions = bcExtraDeps bconfig resolver = bcResolver bconfig From 99002f1164b70ee2393b193263be7a7320612ef6 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 7 Jan 2016 04:30:23 +0530 Subject: [PATCH 28/29] init: Cleanup default flag values before writing The resolver build plan may return source package flags set to their default values. If so remove any flags set to default values before writing them to stack.yaml. --- src/Stack/BuildPlan.hs | 24 ++++++++++++++++++++++++ src/Stack/Init.hs | 3 +-- src/Stack/Solver.hs | 7 ++++--- 3 files changed, 29 insertions(+), 5 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index c51e7fde7f..7d0be16491 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -17,6 +17,7 @@ module Stack.BuildPlan , MiniBuildPlan(..) , MiniPackageInfo(..) , loadMiniBuildPlan + , removeSrcPkgDefaultFlags , resolveBuildPlan , selectBestSnapshot , ToolMap @@ -492,6 +493,29 @@ gpdPackageDeps gpd cv platform flags = , packageConfigPlatform = platform } +-- Remove any src package flags having default values +-- Remove any package entries with no flags set +removeSrcPkgDefaultFlags :: [C.GenericPackageDescription] + -> Map PackageName (Map FlagName Bool) + -> Map PackageName (Map FlagName Bool) +removeSrcPkgDefaultFlags gpds flags = + let defaults = Map.unions (map gpdDefaultFlags gpds) + flags' = Map.differenceWith removeSame flags defaults + in Map.filter (not . Map.null) flags' + where + removeSame f1 f2 = + let diff v v' = if v == v' then Nothing else Just v + in Just $ Map.differenceWith diff f1 f2 + + gpdDefaultFlags gpd = + let tuples = map getDefault (C.genPackageFlags gpd) + in Map.singleton (gpdPackageName gpd) (Map.fromList tuples) + + flagName' = fromCabalFlagName . C.flagName + getDefault f + | C.flagDefault f = (flagName' f, True) + | otherwise = (flagName' f, False) + -- | Find the set of @FlagName@s necessary to get the given -- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will -- only modify non-manual flags, and will prefer default values for flags. diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 4807f585fc..5606884acd 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -85,8 +85,7 @@ initProject currDir initOpts = do let p = Project { projectPackages = pkgs , projectExtraDeps = extraDeps - -- TODO do not write flags with default values - , projectFlags = Map.filter (not . Map.null) flags + , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = r , projectCompiler = Nothing , projectExtraPackageDBs = [] diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index c5bc914a77..25ccd37d3c 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -467,8 +467,9 @@ reportMissingCabalFiles cabalfps includeSubdirs = do allCabalfps <- findCabalFiles (includeSubdirs) =<< getWorkingDir relpaths <- mapM makeRel (allCabalfps \\ cabalfps) - $logWarn $ "The following packages are missing from the config:" - $logWarn $ T.pack (formatGroup relpaths) + when (not (null relpaths)) $ do + $logWarn $ "The following packages are missing from the config:" + $logWarn $ T.pack (formatGroup relpaths) -- | Solver can be thought of as a counterpart of init. init creates a -- stack.yaml whereas solver verifies or fixes an existing one. It can verify @@ -535,7 +536,7 @@ solveExtraDeps modStackYaml = do Just x -> return x let - flags = Map.filter (not . Map.null) (fmap snd (Map.union srcs edeps)) + flags = removeSrcPkgDefaultFlags gpds (fmap snd (Map.union srcs edeps)) versions = fmap fst edeps vDiff v v' = if v == v' then Nothing else Just v From 885a35403683192796ad03a1dcd7261dd99eae58 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 8 Jan 2016 00:33:01 +0530 Subject: [PATCH 29/29] Lay down corrective actions at each solver failure Specify clear steps to help out the user when a 'stack init' or solver fails. Make the help output more clear, concise and complete. --- src/Stack/BuildPlan.hs | 95 ++++++++++++++++++++++++++------------- src/Stack/Init.hs | 43 +++++++++++------- src/Stack/Options.hs | 3 +- src/Stack/Solver.hs | 21 +++++++-- src/Stack/Types/Build.hs | 19 +++----- src/Stack/Types/Config.hs | 37 ++++++++------- 6 files changed, 137 insertions(+), 81 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 7d0be16491..7d13365ccf 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -23,12 +23,14 @@ module Stack.BuildPlan , ToolMap , getToolMap , shadowMiniBuildPlan + , showCompilerErrors + , showDepErrors , parseCustomMiniBuildPlan ) where import Control.Applicative import Control.Exception (assert) -import Control.Monad (liftM, forM, when) +import Control.Monad (liftM, forM) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger @@ -726,26 +728,50 @@ selectBestSnapshot gpds snaps = do reportResult (BuildPlanCheckPartial f errs) snap = do $logWarn $ "* Partially matches " <> renderSnapName snap - displayDepErrors f errs + $logWarn $ indent $ showDepErrors f errs reportResult (BuildPlanCheckFail f errs compiler) snap = do - $logWarn $ "* Rejected " - <> renderSnapName snap - <> " due to conflict of compiler (" - <> compilerVersionText compiler - <> ") packages" - displayDepErrors f errs - -displayDepErrors - :: MonadLogger m - => Map PackageName (Map FlagName Bool) + $logWarn $ "* Rejected " <> renderSnapName snap + $logWarn $ indent $ showCompilerErrors f errs compiler + + indent t = T.unlines $ fmap (" " <>) (T.lines t) + +showCompilerErrors + :: Map PackageName (Map FlagName Bool) -> DepErrors - -> m () -displayDepErrors flags errs = - F.forM_ (Map.toList errs) $ \(depName, DepError mversion neededBy) -> do - $logInfo $ T.concat - [ " " - , T.pack $ packageNameString depName + -> CompilerVersion + -> Text +showCompilerErrors flags errs compiler = + -- TODO print the package filename to enable quick mapping for the user + T.concat + [ compilerVersionText compiler + , " cannot be used for these packages:\n" + , T.concat (map formatError (Map.toList errs)) + , showDepErrors flags errs -- TODO only in debug mode + ] + where + formatError (_, DepError _ neededBy) = T.concat $ + map formatItem (Map.toList neededBy) + + formatItem (user, _) = T.concat + [ " - " + , T.pack $ packageNameString user + , "\n" + ] + +showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text +showDepErrors flags errs = + T.concat $ map formatError (Map.toList errs) + where + formatError (depName, DepError mversion neededBy) = T.concat + [ showDepVersion depName mversion + , T.concat (map showRequirement (Map.toList neededBy)) + -- TODO only in debug + , T.concat (map showFlags (Map.toList neededBy)) + ] + + showDepVersion depName mversion = T.concat + [ T.pack $ packageNameString depName , case mversion of Nothing -> " not found" Just version -> T.concat @@ -753,24 +779,33 @@ displayDepErrors flags errs = , T.pack $ versionString version , " found" ] + , "\n" ] - F.forM_ (Map.toList neededBy) $ \(user, range) -> $logInfo $ T.concat + + showRequirement (user, range) = T.concat [ " - " , T.pack $ packageNameString user , " requires " , T.pack $ display range + , "\n" ] - F.forM_ (Map.toList neededBy) $ \(user, _) -> - maybe (return ()) (printFlags user) (Map.lookup user flags) - $logInfo "" - where - printFlags user fl = when (not $ Map.null fl) $ - $logDebug $ T.concat - [ " - " - , T.pack $ packageNameString user - , " configured with flags " - , T.pack $ (show fl) - ] + + showFlags (user, _) = + maybe "" (printFlags user) (Map.lookup user flags) + + printFlags user fl = + if (not $ Map.null fl) then + T.concat + [ " - " + , T.pack $ packageNameString user + , " flags: " + , T.pack $ intercalate ", " + $ map formatFlags (Map.toList fl) + , "\n" + ] + else "" + + formatFlags (f, v) = (show f) ++ " = " ++ (show v) shadowMiniBuildPlan :: MiniBuildPlan -> Set PackageName diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 5606884acd..c71ecda940 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -198,11 +198,13 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do result <- checkResolverSpec gpds Nothing resolver case result of - BuildPlanCheckOk flags -> return (resolver, flags, Map.empty) - BuildPlanCheckPartial flags _ - | needSolver resolver initOpts -> solve (resolver, flags) - | otherwise -> throwM $ ResolverPartial resolver - BuildPlanCheckFail _ _ _ -> throwM $ ResolverMismatch resolver + BuildPlanCheckOk f-> return (resolver, f, Map.empty) + BuildPlanCheckPartial f e + | needSolver resolver initOpts -> solve (resolver, f) + | otherwise -> + throwM $ ResolverPartial resolver (showDepErrors f e) + BuildPlanCheckFail f e c -> + throwM $ ResolverMismatch resolver (showCompilerErrors f e c) where solve (res, f) = do @@ -218,23 +220,30 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do \plan.\nProceeding to create a config with an \ \incomplete plan anyway..." return (res, f, Map.empty) - | otherwise -> do - let footer = "Use '--force' to create " - <> toFilePath stackDotYaml <> - " with an incomplete build plan anyway." - throwM (SolverGiveUp $ Just footer) + | otherwise -> throwM (SolverGiveUp giveUpMsg) + + giveUpMsg = concat + [ " - Use '--ignore-subdirs' to skip packages in subdirectories.\n" + , " - Update external packages with 'stack update' and try again.\n" + , " - Use '--force' to create an initial " + , toFilePath stackDotYaml <> ", tweak it and run 'stack solver':\n" + , " - Remove any unnecessary packages.\n" + , " - Add any missing remote packages.\n" + , " - Add extra dependencies to guide solver.\n" + ] -- TODO support selecting best across regular and custom snapshots getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver - selectSnapResolver snapPref = - getSnapshots' - >>= maybe (throwM NoMatchingSnapshot) - (getRecommendedSnapshots snapPref) - >>= selectBestSnapshot gpds - >>= maybe (throwM NoMatchingSnapshot) - (return . ResolverSnapshot) + selectSnapResolver snapPref = do + msnaps <- getSnapshots' + snaps <- maybe (error "No snapshots to select from.") + (getRecommendedSnapshots snapPref) + msnaps + selectBestSnapshot gpds snaps + >>= maybe (throwM (NoMatchingSnapshot snaps)) + (return . ResolverSnapshot) needSolver _ (InitOpts {useSolver = True}) = True needSolver (ResolverCompiler _) _ = True diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 5f20614f43..4851771498 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -675,7 +675,8 @@ initOptsParser = ignoreSubDirs = switch (long "ignore-subdirs" <> help "Do not search for .cabal files in sub directories") overwrite = switch (long "force" <> - help "Force overwriting of an existing stack.yaml if it exists") + help "Force overwriting an existing stack.yaml or \ + \creating a stack.yaml with incomplete config.") solver = switch (long "solver" <> help "Use a dependency solver to determine extra dependencies") diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 25ccd37d3c..3c12cf9ec5 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -44,6 +44,7 @@ import Path.Find (findFiles) import Path.IO (getWorkingDir, parseRelAsAbsDir) import Prelude import Stack.BuildPlan +import Stack.Constants (stackDotYaml) import Stack.Package (printCabalFileWarning , readPackageUnresolved) import Stack.Setup @@ -529,10 +530,11 @@ solveExtraDeps modStackYaml = do BuildPlanCheckPartial _ _ -> solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, extraConstraints) - BuildPlanCheckFail _ _ _ -> throwM $ ResolverMismatch resolver + BuildPlanCheckFail f e c -> + throwM $ ResolverMismatch resolver (showCompilerErrors f e c) (srcs, edeps) <- case resultSpecs of - Nothing -> throwM (SolverGiveUp Nothing) + Nothing -> throwM (SolverGiveUp giveUpMsg) Just x -> return x let @@ -578,15 +580,18 @@ solveExtraDeps modStackYaml = do $logInfo $ "No changes needed to " <> T.pack relStackYaml where + indent t = T.unlines $ fmap (" " <>) (T.lines t) + printFlags fl msg = do when ((not . Map.null) fl) $ do $logInfo $ T.pack msg - $logInfo $ decodeUtf8 $ Yaml.encode $ object ["flags" .= fl] + $logInfo $ indent $ decodeUtf8 $ Yaml.encode + $ object ["flags" .= fl] printDeps deps msg = do when ((not . Map.null) deps) $ do $logInfo $ T.pack msg - $logInfo $ decodeUtf8 $ Yaml.encode $ object $ + $logInfo $ indent $ decodeUtf8 $ Yaml.encode $ object $ [("extra-deps" .= map fromTuple (Map.toList deps))] writeStackYaml path res deps fl = do @@ -601,3 +606,11 @@ solveExtraDeps modStackYaml = do $ HashMap.insert ("flags" :: Text) (toJSON fl) $ HashMap.insert ("resolver" :: Text) (toJSON (resolverName res)) obj liftIO $ Yaml.encodeFile fp obj' + + giveUpMsg = concat + [ " - Update external packages with 'stack update' and try again.\n" + , " - Tweak " <> toFilePath stackDotYaml <> " and try again\n" + , " - Remove any unnecessary packages.\n" + , " - Add any missing remote packages.\n" + , " - Add extra dependencies to guide solver.\n" + ] diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index af28f5ab20..d95d80a359 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -70,7 +70,6 @@ import GHC.Generics import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ()) import Path.Extra (toFilePathNoTrailingSep) import Prelude -import Stack.Constants (stackDotYaml) import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.Compiler @@ -121,7 +120,7 @@ data StackBuildException | InvalidFlagSpecification (Set UnusedFlags) | TargetParseException [Text] | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])] - | SolverGiveUp (Maybe String) + | SolverGiveUp String | SolverMissingCabalInstall | SomeTargetsNotBuildable [(PackageName, NamedComponent)] deriving Typeable @@ -322,18 +321,10 @@ instance Show StackBuildException where : (packageNameString name ++ " used in:") : map goDir dirs goDir dir = "- " ++ toFilePath dir - show (SolverGiveUp footer) = concat - [ "\nSolver could not resolve package dependencies. " - , "You can:\n" - , "- Use 'stack update' to update the package index and try again.\n" - , "- Add some extra dependencies in " <> toFilePath stackDotYaml - , " and then use 'stack solver' to figure out the rest.\n" - , "- Add any missed local or remote source package required to " - , "build your package.\n" - , "- Remove any unnecessary packages which may be causing dependency " - , "issues.\n" - , "- Use '--ignore-subdirs' to ignore packages in subdirectories.\n" - , maybe "" (("\n" <>) . id) footer + show (SolverGiveUp msg) = concat + [ "\nSolver could not resolve package dependencies.\n" + , "You can try the following:\n" + , msg ] show SolverMissingCabalInstall = unlines [ "Solver requires that cabal be on your PATH" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index f42e8a270d..311af287f0 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1074,9 +1074,9 @@ data ConfigException | NoProjectConfigFound (Path Abs Dir) (Maybe Text) | UnexpectedTarballContents [Path Abs Dir] [Path Abs File] | BadStackVersionException VersionRange - | NoMatchingSnapshot - | ResolverMismatch Resolver - | ResolverPartial Resolver + | NoMatchingSnapshot [SnapName] + | ResolverMismatch Resolver Text + | ResolverPartial Resolver Text | NoSuchDirectory FilePath | ParseGHCVariantException String deriving Typeable @@ -1116,23 +1116,30 @@ instance Show ConfigException where ,"version range specified in stack.yaml (" , T.unpack (versionRangeText requiredRange) , ")." ] - show NoMatchingSnapshot = concat - [ "No snapshot is 'compiler compatible' with the package " - , "constraints specified in your .cabal files.\n" + show (NoMatchingSnapshot names) = concat + [ "None of the following snapshots provides a compiler matching " + , "your package(s):\n" + , unlines $ map (\name -> " - " <> T.unpack (renderSnapName name)) + names + , "\nYou can try the following options:\n" + , " - Exclude mismatching package(s) and build the rest.\n" + , " - Use '--ignore-subdirs' to exclude subdirectories.\n" + , " - Manually create a config, then use 'stack solver'\n" + , " - Use '--resolver' to specify a matching snapshot/resolver\n" + , " - Use a custom snapshot having the right compiler.\n" ] - show (ResolverMismatch resolver) = concat + show (ResolverMismatch resolver errDesc) = concat [ "Selected resolver '" , T.unpack (resolverName resolver) - , "' is not 'compiler compatible' with the package " - , "constraints specified in your .cabal files.\n" + , "' does not have a matching compiler to build your package(s).\n" + , T.unpack errDesc ] - show (ResolverPartial resolver) = concat - [ "Resolver '" + show (ResolverPartial resolver errDesc) = concat + [ "Selected resolver '" , T.unpack (resolverName resolver) - , "' does not satisfy all the package " - , "requirements and constraints specified in your .cabal files.\n\n" - , "However, you can use the '--solver' command line switch to resolve " - , "the constraints using external packages." + , "' does not have all the packages to match your requirements.\n" + , T.unpack $ T.unlines $ fmap (" " <>) (T.lines errDesc) + , "\nHowever, you can try '--solver' to use external packages." ] show (NoSuchDirectory dir) = concat ["No directory could be located matching the supplied path: "