From 16faae120cddad87de9525b73542b5a268a6c53d Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 8 Jan 2016 04:45:40 +0530 Subject: [PATCH 01/25] Create show instances for build plan check results --- src/Stack/BuildPlan.hs | 15 +++++++++------ src/Stack/Init.hs | 12 ++++++------ src/Stack/Solver.hs | 4 ++-- src/Stack/Types/Config.hs | 8 ++++---- 4 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 7d13365ccf..d72bde1085 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -23,8 +23,6 @@ module Stack.BuildPlan , ToolMap , getToolMap , shadowMiniBuildPlan - , showCompilerErrors - , showDepErrors , parseCustomMiniBuildPlan ) where @@ -652,6 +650,11 @@ data BuildPlanCheck = | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors CompilerVersion +instance Show BuildPlanCheck where + show (BuildPlanCheckOk _) = "" + show (BuildPlanCheckPartial f e) = T.unpack $ showDepErrors f e + show (BuildPlanCheckFail f e c) = T.unpack $ showCompilerErrors f e c + -- | 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. @@ -726,13 +729,13 @@ selectBestSnapshot gpds snaps = do $logInfo $ "* Selected " <> renderSnapName snap $logInfo "" - reportResult (BuildPlanCheckPartial f errs) snap = do + reportResult r@(BuildPlanCheckPartial _ _) snap = do $logWarn $ "* Partially matches " <> renderSnapName snap - $logWarn $ indent $ showDepErrors f errs + $logWarn $ indent $ T.pack $ show r - reportResult (BuildPlanCheckFail f errs compiler) snap = do + reportResult r@(BuildPlanCheckFail _ _ _) snap = do $logWarn $ "* Rejected " <> renderSnapName snap - $logWarn $ indent $ showCompilerErrors f errs compiler + $logWarn $ indent $ T.pack $ show r indent t = T.unlines $ fmap (" " <>) (T.lines t) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index c71ecda940..3ee3fab1dc 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -198,13 +198,12 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do result <- checkResolverSpec gpds Nothing resolver case result of - BuildPlanCheckOk f-> return (resolver, f, Map.empty) - BuildPlanCheckPartial f e + BuildPlanCheckOk f -> return (resolver, f, Map.empty) + (BuildPlanCheckPartial f _) | needSolver resolver initOpts -> solve (resolver, f) - | otherwise -> - throwM $ ResolverPartial resolver (showDepErrors f e) - BuildPlanCheckFail f e c -> - throwM $ ResolverMismatch resolver (showCompilerErrors f e c) + | otherwise -> throwM $ ResolverPartial resolver (show result) + (BuildPlanCheckFail _ _ _) -> + throwM $ ResolverMismatch resolver (show result) where solve (res, f) = do @@ -257,6 +256,7 @@ 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. + -- TODO Include all major compiler versions available existing <- liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $ snapshotsDir >>= diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 672878e847..e089b88c40 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -536,8 +536,8 @@ solveExtraDeps modStackYaml = do BuildPlanCheckPartial _ _ -> solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, extraConstraints) - BuildPlanCheckFail f e c -> - throwM $ ResolverMismatch resolver (showCompilerErrors f e c) + (BuildPlanCheckFail _ _ _) -> + throwM $ ResolverMismatch resolver (show resolverResult) (srcs, edeps) <- case resultSpecs of Nothing -> throwM (SolverGiveUp giveUpMsg) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 8c6b02cf6d..254bc04a24 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1076,8 +1076,8 @@ data ConfigException | UnexpectedTarballContents [Path Abs Dir] [Path Abs File] | BadStackVersionException VersionRange | NoMatchingSnapshot [SnapName] - | ResolverMismatch Resolver Text - | ResolverPartial Resolver Text + | ResolverMismatch Resolver String + | ResolverPartial Resolver String | NoSuchDirectory FilePath | ParseGHCVariantException String deriving Typeable @@ -1133,13 +1133,13 @@ instance Show ConfigException where [ "Selected resolver '" , T.unpack (resolverName resolver) , "' does not have a matching compiler to build your package(s).\n" - , T.unpack errDesc + , errDesc ] show (ResolverPartial resolver errDesc) = concat [ "Selected resolver '" , T.unpack (resolverName resolver) , "' does not have all the packages to match your requirements.\n" - , T.unpack $ T.unlines $ fmap (" " <>) (T.lines errDesc) + , unlines $ fmap (" " <>) (lines errDesc) , "\nHowever, you can try '--solver' to use external packages." ] show (NoSuchDirectory dir) = concat From c1b1bb4e8847aa469ef38b6903bba1a614724750 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 15 Jan 2016 02:30:28 +0530 Subject: [PATCH 02/25] Implement Ord and Eq instances for BuildPlanCheck --- src/Stack/BuildPlan.hs | 41 +++++++++++++++++++++++++++++++---------- 1 file changed, 31 insertions(+), 10 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index d72bde1085..fcc8f8001d 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -650,6 +650,29 @@ data BuildPlanCheck = | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors CompilerVersion +-- Greater means a better plan +instance Ord BuildPlanCheck where + (BuildPlanCheckPartial _ e1) `compare` (BuildPlanCheckPartial _ e2) = + compare (Map.size e1) (Map.size e2) + + (BuildPlanCheckFail _ e1 _) `compare` (BuildPlanCheckFail _ e2 _) = + compare (Map.size e1) (Map.size e2) + + (BuildPlanCheckOk _) `compare` (BuildPlanCheckOk _) = EQ + (BuildPlanCheckOk _) `compare` (BuildPlanCheckPartial _ _) = GT + (BuildPlanCheckOk _) `compare` (BuildPlanCheckFail _ _ _) = GT + (BuildPlanCheckPartial _ _) `compare` (BuildPlanCheckFail _ _ _) = GT + _ `compare` _ = LT + +instance Eq BuildPlanCheck where + (BuildPlanCheckOk _) == (BuildPlanCheckOk _) = True + (BuildPlanCheckPartial _ e1) == (BuildPlanCheckPartial _ e2) = + (Map.size e1) == (Map.size e2) + (BuildPlanCheckFail _ e1 _) == (BuildPlanCheckFail _ e2 _) = + (Map.size e1) == (Map.size e2) + + _ == _ = False + instance Show BuildPlanCheck where show (BuildPlanCheckOk _) = "" show (BuildPlanCheckPartial f e) = T.unpack $ showDepErrors f e @@ -712,21 +735,19 @@ selectBestSnapshot gpds snaps = do loop bestYet (snap:rest) = do result <- checkSnapBuildPlan gpds Nothing snap reportResult result snap + let new = (snap, result) case result of - BuildPlanCheckFail _ _ _ -> loop bestYet rest BuildPlanCheckOk _ -> return $ Just snap - BuildPlanCheckPartial _ e -> do - case bestYet of - Nothing -> loop (Just (snap, e)) rest - Just prev -> - loop (Just (betterSnap prev (snap, e))) rest + _ -> case bestYet of + Nothing -> loop (Just new) rest + Just old -> loop (Just (betterSnap old new)) rest - betterSnap (s1, e1) (s2, e2) - | (Map.size e1) <= (Map.size e2) = (s1, e1) - | otherwise = (s2, e2) + betterSnap (s1, r1) (s2, r2) + | r1 <= r2 = (s1, r1) + | otherwise = (s2, r2) reportResult (BuildPlanCheckOk _) snap = do - $logInfo $ "* Selected " <> renderSnapName snap + $logInfo $ "* Matches " <> renderSnapName snap $logInfo "" reportResult r@(BuildPlanCheckPartial _ _) snap = do From f9449e6be65db2b5f1564938b5ded92780a07372 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 15 Jan 2016 03:02:31 +0530 Subject: [PATCH 03/25] stack init: ignore resolver incompatible packages When doing stack init, some of the packages may not be compatible with the resolver compiler while others just build ok. In that case we provide the user an option to ignore those packages and use the rest. If --force is specified stack will create a config with those packages which are compatible. Fixes #1621 --- src/Stack/BuildPlan.hs | 15 +++-- src/Stack/Init.hs | 144 +++++++++++++++++++++++++++++------------ src/Stack/Solver.hs | 14 ++-- 3 files changed, 120 insertions(+), 53 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index fcc8f8001d..8227f4af3d 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -10,10 +10,13 @@ -- snapshot. module Stack.BuildPlan - ( gpdPackages - , BuildPlanException (..) + ( BuildPlanException (..) , BuildPlanCheck (..) , checkSnapBuildPlan + , DepError(..) + , DepErrors + , gpdPackages + , gpdPackageName , MiniBuildPlan(..) , MiniPackageInfo(..) , loadMiniBuildPlan @@ -723,21 +726,21 @@ selectBestSnapshot , MonadBaseControl IO m) => [GenericPackageDescription] -> [SnapName] - -> m (Maybe SnapName) + -> m (SnapName, BuildPlanCheck) 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, _)) [] = return $ Just snap + loop Nothing [] = error "Bug: in best snapshot selection" + loop (Just pair) [] = return pair loop bestYet (snap:rest) = do result <- checkSnapBuildPlan gpds Nothing snap reportResult result snap let new = (snap, result) case result of - BuildPlanCheckOk _ -> return $ Just snap + BuildPlanCheckOk _ -> return new _ -> case bestYet of Nothing -> loop (Just new) rest Just old -> loop (Just (betterSnap old new)) rest diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 3ee3fab1dc..cc4edc68b8 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -78,11 +78,11 @@ initProject currDir initOpts = do <> "dependencies and update the config file." cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir - gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter + bundle <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter - (r, flags, extraDeps) <- - getDefaultResolver dest (map parent cabalfps) gpds initOpts - let p = Project + (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts bundle + let gpds = Map.elems $ fmap snd rbundle + p = Project { projectPackages = pkgs , projectExtraDeps = extraDeps , projectFlags = removeSrcPkgDefaultFlags gpds flags @@ -90,15 +90,15 @@ initProject currDir initOpts = do , projectCompiler = Nothing , projectExtraPackageDBs = [] } - pkgs = map toPkg cabalfps - toPkg fp = PackageEntry + pkgs = map toPkg $ Map.elems (fmap fst rbundle) + toPkg dir = PackageEntry { peValidWanted = Nothing , peExtraDepMaybe = Nothing , peLocation = PLFilePath $ - case stripDir currDir $ parent fp of + case stripDir currDir dir of Nothing - | currDir == parent fp -> "." - | otherwise -> assert False $ toFilePath $ parent fp + | currDir == dir -> "." + | otherwise -> assert False $ toFilePath dir Just rel -> toFilePath rel , peSubdirs = [] } @@ -187,38 +187,113 @@ getDefaultResolver , HasHttpManager env , HasLogLevel env , HasReExec env , HasTerminal env) => Path Abs File -- ^ stack.yaml - -> [Path Abs Dir] -- ^ cabal dirs - -> [C.GenericPackageDescription] -- ^ cabal descriptions -> InitOpts + -> Map PackageName (Path Abs Dir, C.GenericPackageDescription) + -- ^ Src package name: cabal dir, cabal package description -> m ( Resolver , Map PackageName (Map FlagName Bool) - , Map PackageName Version) -getDefaultResolver stackYaml cabalDirs gpds initOpts = do - resolver <- getResolver (ioMethod initOpts) - result <- checkResolverSpec gpds Nothing resolver + , Map PackageName Version + , Map PackageName (Path Abs Dir, C.GenericPackageDescription)) + -- ^ ( Resolver + -- , Flags for src packages and extra deps + -- , Extra dependencies + -- , Src packages actually considered) +getDefaultResolver stackYaml initOpts bundle = + getResolver (ioMethod initOpts) + >>= getWorkingResolverPlan stackYaml initOpts bundle + where + -- TODO support selecting best across regular and custom snapshots + getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref + getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver + + selectSnapResolver snapPref = do + msnaps <- getSnapshots' + snaps <- maybe (error "No snapshots to select from.") + (getRecommendedSnapshots snapPref) + msnaps + let gpds = Map.elems (fmap snd bundle) + (s, r) <- selectBestSnapshot gpds snaps + case r of + (BuildPlanCheckFail _ _ _) | not (forceOverwrite initOpts) + -> throwM (NoMatchingSnapshot snaps) + _ -> return $ ResolverSnapshot s + +getWorkingResolverPlan + :: ( 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 + -> InitOpts + -> Map PackageName (Path Abs Dir, C.GenericPackageDescription) + -- ^ Src package name: cabal dir, cabal package description + -> Resolver + -> m ( Resolver + , Map PackageName (Map FlagName Bool) + , Map PackageName Version + , Map PackageName (Path Abs Dir, C.GenericPackageDescription)) + -- ^ ( Resolver + -- , Flags for src packages and extra deps + -- , Extra dependencies + -- , Src packages actually considered) +getWorkingResolverPlan stackYaml initOpts bundle resolver = do + go bundle + where + go info = do + eres <- checkBundleResolver stackYaml initOpts info resolver + -- if some packages failed try again using the rest + case eres of + Right (f, edeps)-> return (resolver, f, edeps, info) + Left e + | Map.null good -> + return (resolver, Map.empty, Map.empty, Map.empty) + | otherwise -> do + assert ((Map.size good) < (Map.size info)) (go good) + where + failed = Map.unions (Map.elems (fmap deNeededBy e)) + good = Map.difference info failed +checkBundleResolver + :: ( 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 + -> InitOpts + -> Map PackageName (Path Abs Dir, C.GenericPackageDescription) + -- ^ Src package name: cabal dir, cabal package description + -> Resolver + -> m (Either DepErrors ( Map PackageName (Map FlagName Bool) + , Map PackageName Version)) +checkBundleResolver stackYaml initOpts bundle resolver = do + result <- checkResolverSpec gpds Nothing resolver case result of - BuildPlanCheckOk f -> return (resolver, f, Map.empty) + BuildPlanCheckOk f -> return $ Right (f, Map.empty) (BuildPlanCheckPartial f _) - | needSolver resolver initOpts -> solve (resolver, f) + | needSolver resolver initOpts -> do + liftM (\x -> Right x) (solve f) | otherwise -> throwM $ ResolverPartial resolver (show result) - (BuildPlanCheckFail _ _ _) -> - throwM $ ResolverMismatch resolver (show result) - + (BuildPlanCheckFail _ e _) + | (forceOverwrite initOpts) -> do + return $ Left e + | otherwise -> throwM $ ResolverMismatch resolver (show result) where - solve (res, f) = do - let srcConstraints = mergeConstraints (gpdPackages gpds) f - mresolver <- solveResolverSpec stackYaml cabalDirs - (res, srcConstraints, Map.empty) - case mresolver of - Just (src, ext) -> do - return (res, fmap snd (Map.union src ext), fmap fst ext) + gpds = Map.elems (fmap snd bundle) + solve flags = do + let cabalDirs = Map.elems (fmap fst bundle) + srcConstraints = mergeConstraints (gpdPackages gpds) flags + + mresult <- solveResolverSpec stackYaml cabalDirs + (resolver, srcConstraints, Map.empty) + case mresult of + Just (src, ext) -> + return (fmap snd (Map.union src ext), 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 (res, f, Map.empty) + return (flags, Map.empty) | otherwise -> throwM (SolverGiveUp giveUpMsg) giveUpMsg = concat @@ -231,19 +306,6 @@ getDefaultResolver stackYaml cabalDirs gpds initOpts = do , " - 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 = 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 needSolver _ _ = False diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index e089b88c40..a49a68c485 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -437,7 +437,7 @@ cabalPackagesCheck => [Path Abs File] -> String -> String - -> m [C.GenericPackageDescription] + -> m (Map PackageName (Path Abs Dir, C.GenericPackageDescription)) cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do when (null cabalfps) $ error noPkgMsg @@ -455,7 +455,10 @@ cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings - return gpds + return $ Map.fromList + $ zipWith (\dir gpd -> ((gpdPackageName gpd),(dir, gpd))) + (map parent cabalfps) + gpds where groups = filter ((> 1) . length) . groupSortOn (FP.takeFileName) @@ -513,13 +516,13 @@ solveExtraDeps modStackYaml = do \entries from '" <> relStackYaml <> "'." 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 + bundle <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter - let oldFlags = bcFlags bconfig + let gpds = Map.elems $ fmap snd bundle + oldFlags = bcFlags bconfig oldExtraVersions = bcExtraDeps bconfig resolver = bcResolver bconfig oldSrcs = gpdPackages gpds @@ -568,7 +571,6 @@ solveExtraDeps modStackYaml = do -- TODO print whether resolver changed from previous $logInfo $ "* Resolver is " <> resolverName resolver - -- TODO indent the yaml output printFlags newFlags "* Flags to be added" printDeps newVersions "* Dependencies to be added" From b2162af3345c17101dd2f04cf16e3ef90e13f831 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 15 Jan 2016 03:21:25 +0530 Subject: [PATCH 04/25] Provide detailed messages when ignoring packages --- src/Stack/BuildPlan.hs | 24 +++++++++++++----------- src/Stack/Init.hs | 11 +++++++++++ src/Stack/Types/Config.hs | 5 +---- 3 files changed, 25 insertions(+), 15 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 8227f4af3d..09fa664367 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -26,6 +26,7 @@ module Stack.BuildPlan , ToolMap , getToolMap , shadowMiniBuildPlan + , showMismatchingPackages , parseCustomMiniBuildPlan ) where @@ -763,28 +764,29 @@ selectBestSnapshot gpds snaps = do indent t = T.unlines $ fmap (" " <>) (T.lines t) +showMismatchingPackages :: DepErrors -> Text +showMismatchingPackages errs = + let list = Map.keys $ Map.unions (Map.elems (fmap deNeededBy errs)) + in T.concat (map formatItem list) + where + formatItem pkg = T.concat + [ " - " + , T.pack $ packageNameString pkg + , "\n" + ] + showCompilerErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> 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)) + , showMismatchingPackages 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 = diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index cc4edc68b8..70d41940f6 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -237,6 +237,7 @@ getWorkingResolverPlan -- , Extra dependencies -- , Src packages actually considered) getWorkingResolverPlan stackYaml initOpts bundle resolver = do + $logInfo $ "Selected resolver: " <> resolverName resolver go bundle where go info = do @@ -248,10 +249,13 @@ getWorkingResolverPlan stackYaml initOpts bundle resolver = do | Map.null good -> return (resolver, Map.empty, Map.empty, Map.empty) | otherwise -> do + $logWarn "Ignoring compiler incompatible packages:" + $logWarn $ indent $ showMismatchingPackages e assert ((Map.size good) < (Map.size info)) (go good) where failed = Map.unions (Map.elems (fmap deNeededBy e)) good = Map.difference info failed + indent t = T.unlines $ fmap (" " <>) (T.lines t) checkBundleResolver :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m @@ -271,13 +275,20 @@ checkBundleResolver stackYaml initOpts bundle resolver = do BuildPlanCheckOk f -> return $ Right (f, Map.empty) (BuildPlanCheckPartial f _) | needSolver resolver initOpts -> do + $logWarn $ "Resolver " <> resolverName resolver + <> " will need external packages: " + $logWarn $ indent $ T.pack $ show result liftM (\x -> Right x) (solve f) | otherwise -> throwM $ ResolverPartial resolver (show result) (BuildPlanCheckFail _ e _) | (forceOverwrite initOpts) -> do + $logWarn $ "Resolver compiler mismatch: " + <> resolverName resolver + $logWarn $ indent $ T.pack $ show result return $ Left e | otherwise -> throwM $ ResolverMismatch resolver (show result) where + indent t = T.unlines $ fmap (" " <>) (T.lines t) gpds = Map.elems (fmap snd bundle) solve flags = do let cabalDirs = Map.elems (fmap fst bundle) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 254bc04a24..a3888b7efa 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1123,11 +1123,8 @@ instance Show ConfigException where , 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 '--force' to ignore mismatching package(s).\n" , " - Use '--resolver' to specify a matching snapshot/resolver\n" - , " - Use a custom snapshot having the right compiler.\n" ] show (ResolverMismatch resolver errDesc) = concat [ "Selected resolver '" From fcfebe094c013dfdee85cd5efb0400ff841896b3 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 15 Jan 2016 04:16:09 +0530 Subject: [PATCH 05/25] init - summarise warnings before writing config Warnings about: - ignored packages - extra dependencies --- src/Stack/BuildPlan.hs | 10 ++++------ src/Stack/Init.hs | 22 +++++++++++++++++++++- 2 files changed, 25 insertions(+), 7 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 09fa664367..33ce3aa404 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -26,7 +26,7 @@ module Stack.BuildPlan , ToolMap , getToolMap , shadowMiniBuildPlan - , showMismatchingPackages + , showMapPackages , parseCustomMiniBuildPlan ) where @@ -764,10 +764,8 @@ selectBestSnapshot gpds snaps = do indent t = T.unlines $ fmap (" " <>) (T.lines t) -showMismatchingPackages :: DepErrors -> Text -showMismatchingPackages errs = - let list = Map.keys $ Map.unions (Map.elems (fmap deNeededBy errs)) - in T.concat (map formatItem list) +showMapPackages :: Map PackageName a -> Text +showMapPackages mp = T.concat (map formatItem $ Map.keys mp) where formatItem pkg = T.concat [ " - " @@ -784,7 +782,7 @@ showCompilerErrors flags errs compiler = T.concat [ compilerVersionText compiler , " cannot be used for these packages:\n" - , showMismatchingPackages errs + , showMapPackages $ Map.unions (Map.elems (fmap deNeededBy errs)) , showDepErrors flags errs -- TODO only in debug mode ] diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 70d41940f6..04fa61da61 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -81,6 +81,11 @@ initProject currDir initOpts = do bundle <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts bundle + + -- TODO insert ignored packages as commented out + -- TODO insert warnings in the file when there are ignored packages or + -- extra dependencies. Then always create a config and use --force only + -- for overwriting. let gpds = Map.elems $ fmap snd rbundle p = Project { projectPackages = pkgs @@ -104,6 +109,21 @@ initProject currDir initOpts = do } $logInfo $ "Initialising configuration using resolver: " <> resolverName r + + let ignored = Map.difference bundle rbundle + indent t = T.unlines $ fmap (" " <>) (T.lines t) + + when (Map.size ignored > 0) $ do + $logWarn $ "Warning! Ignoring " + <> (T.pack $ show $ Map.size ignored) + <> " out of " + <> (T.pack $ show $ Map.size bundle) + <> " packages:" + $logWarn $ indent $ showMapPackages ignored + + when (Map.size extraDeps > 0) $ do + $logWarn $ "Warning! " <> (T.pack $ show $ Map.size extraDeps) + <> " external dependencies were added." $logInfo $ (if exists then "Overwriting existing configuration file: " else "Writing configuration to file: ") @@ -250,7 +270,7 @@ getWorkingResolverPlan stackYaml initOpts bundle resolver = do return (resolver, Map.empty, Map.empty, Map.empty) | otherwise -> do $logWarn "Ignoring compiler incompatible packages:" - $logWarn $ indent $ showMismatchingPackages e + $logWarn $ indent $ showMapPackages failed assert ((Map.size good) < (Map.size info)) (go good) where failed = Map.unions (Map.elems (fmap deNeededBy e)) From 58eb46c1039f62e032d363449c8635cfed860f11 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 15 Jan 2016 07:18:06 +0530 Subject: [PATCH 06/25] init: add ignored packages as commented in config Packages which are not compatible with the resolver are added to the config but commented out. See #1621 --- src/Stack/Init.hs | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 04fa61da61..8cefc6d3b2 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -19,6 +19,7 @@ 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 +import qualified Data.ByteString.Char8 as BC import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F @@ -95,16 +96,19 @@ initProject currDir initOpts = do , projectCompiler = Nothing , projectExtraPackageDBs = [] } + + makeRel dir = + case stripDir currDir dir of + Nothing + | currDir == dir -> "." + | otherwise -> assert False $ toFilePath dir + Just rel -> toFilePath rel + pkgs = map toPkg $ Map.elems (fmap fst rbundle) toPkg dir = PackageEntry { peValidWanted = Nothing , peExtraDepMaybe = Nothing - , peLocation = PLFilePath $ - case stripDir currDir dir of - Nothing - | currDir == dir -> "." - | otherwise -> assert False $ toFilePath dir - Just rel -> toFilePath rel + , peLocation = PLFilePath $ makeRel dir , peSubdirs = [] } @@ -128,18 +132,21 @@ initProject currDir initOpts = do (if exists then "Overwriting existing configuration file: " else "Writing configuration to file: ") <> T.pack reldest - liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p + liftIO $ L.writeFile dest' + $ B.toLazyByteString + $ renderStackYaml p (Map.elems $ fmap (makeRel . fst) ignored) $logInfo "All done." -- | Render a stack.yaml file with comments, see: -- https://github.com/commercialhaskell/stack/issues/226 -renderStackYaml :: Project -> B.Builder -renderStackYaml p = +renderStackYaml :: Project -> [FilePath]-> B.Builder +renderStackYaml p ignoredPackages = case Yaml.toJSON p of Yaml.Object o -> renderObject o _ -> assert False $ B.byteString $ Yaml.encode p where renderObject o = + B.byteString "# This file was automatically generated by stack init\n" <> B.byteString "# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html\n\n" <> F.foldMap (goComment o) comments <> goOthers (o `HM.difference` HM.fromList comments) <> @@ -158,9 +165,15 @@ renderStackYaml p = \# Allow a newer minor version of GHC than the snapshot specifies\n\ \# compiler-check: newer-minor\n" + ignoredPackagesComment = + if ignoredPackages /= [] then + "\n# Some packages were found to be incompatible with the resolver and \ + \have been commented out" + else "" + comments = [ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)") - , ("packages", "Local packages, usually specified by relative directory name") + , ("packages", "Local packages, usually specified by relative directory name" <> ignoredPackagesComment) , ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)") , ("flags", "Override default flag values for local packages and extra-deps") , ("extra-package-dbs", "Extra package databases containing global packages") @@ -174,6 +187,11 @@ renderStackYaml p = B.byteString comment <> B.byteString "\n" <> B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <> + if (name == "packages") then + B.byteString $ BC.pack $ concat + $ (map (\x -> "#- " ++ x ++ "\n") + ignoredPackages) ++ ["\n"] + else "" <> B.byteString "\n" goOthers o From 93debc6fa634f778b052179f0428a3854a611784 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Fri, 15 Jan 2016 21:12:01 +0530 Subject: [PATCH 07/25] init - add a user warning message to stack.yaml When there are some issues with the config file add warning messages for the user to be displayed everytime the config file is read. The messages can be suppressed by a user action i.e. remove it from the config if the user accepts the config. See #1621 --- src/Stack/Config.hs | 8 +++++++- src/Stack/Init.hs | 42 ++++++++++++++++++++++++++++----------- src/Stack/Types/Config.hs | 12 ++++++++--- 3 files changed, 46 insertions(+), 16 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 3ef8e8d3ab..f0795befc1 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -374,6 +374,11 @@ loadConfig configArgs mstackYaml mresolver = do (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}}) extraConfigs0 mproject <- loadProjectConfig mstackYaml + + let printUserMessage (p, _, _) = + maybe (return ()) ($logWarn . T.pack) (projectUserMsg p) + maybe (return ()) printUserMessage mproject + let mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject config <- configFromConfigMonoid stackRoot userConfigPath mresolver mproject' $ mconcat $ case mproject of @@ -435,7 +440,8 @@ loadBuildConfig mproject config mresolver mcompiler = do $logInfo ("Writing implicit global project config file to: " <> T.pack dest') $logInfo "Note: You can change the snapshot via the resolver field there." let p = Project - { projectPackages = mempty + { projectUserMsg = Nothing + , projectPackages = mempty , projectExtraDeps = mempty , projectFlags = mempty , projectResolver = r diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 8cefc6d3b2..e5b4cda26c 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -83,13 +83,32 @@ initProject currDir initOpts = do (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts bundle - -- TODO insert ignored packages as commented out - -- TODO insert warnings in the file when there are ignored packages or - -- extra dependencies. Then always create a config and use --force only - -- for overwriting. - let gpds = Map.elems $ fmap snd rbundle + let ignored = Map.difference bundle rbundle + missingPkgMsg + | (Map.size ignored > 0) = + "Warning: Some packages were found to be incompatible with \ + \the resolver and have been left commented out in the \ + \packages section.\n" + | otherwise = "" + + extraDepMsg + | (Map.size extraDeps > 0) = + "Warning: Specified resolver could not satisfy all \ + \dependencies. Some external packages have been added \ + \as dependencies.\n" + | otherwise = "" + + footer + | (Map.size ignored > 0) || (Map.size extraDeps > 0) = + "You can suppress this message by removing it from \ + \stack.yaml\n" + | otherwise = "" + + userMsg = missingPkgMsg <> extraDepMsg <> footer + gpds = Map.elems $ fmap snd rbundle p = Project - { projectPackages = pkgs + { projectUserMsg = if userMsg == "" then Nothing else Just userMsg + , projectPackages = pkgs , projectExtraDeps = extraDeps , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = r @@ -111,12 +130,10 @@ initProject currDir initOpts = do , peLocation = PLFilePath $ makeRel dir , peSubdirs = [] } + indent t = T.unlines $ fmap (" " <>) (T.lines t) $logInfo $ "Initialising configuration using resolver: " <> resolverName r - let ignored = Map.difference bundle rbundle - indent t = T.unlines $ fmap (" " <>) (T.lines t) - when (Map.size ignored > 0) $ do $logWarn $ "Warning! Ignoring " <> (T.pack $ show $ Map.size ignored) @@ -167,12 +184,13 @@ renderStackYaml p ignoredPackages = ignoredPackagesComment = if ignoredPackages /= [] then - "\n# Some packages were found to be incompatible with the resolver and \ + "\n# Note: Some packages were found to be incompatible with the resolver and \ \have been commented out" else "" comments = - [ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)") + [ ("user-message", "A message to be displayed to the user. Used when autogenerated config ignored some packages or added extra deps.") + , ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)") , ("packages", "Local packages, usually specified by relative directory name" <> ignoredPackagesComment) , ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)") , ("flags", "Override default flag values for local packages and extra-deps") @@ -181,7 +199,7 @@ renderStackYaml p ignoredPackages = goComment o (name, comment) = case HM.lookup name o of - Nothing -> assert False mempty + Nothing -> assert (name == "user-message") mempty Just v -> B.byteString "# " <> B.byteString comment <> diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index a3888b7efa..0ee37113f7 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -604,7 +604,10 @@ instance FromJSON (PackageLocation, [JSONWarning]) where -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. data Project = Project - { projectPackages :: ![PackageEntry] + { projectUserMsg :: !(Maybe String) + -- ^ A warning message to display to the user when the auto generated + -- config may have issues. + , projectPackages :: ![PackageEntry] -- ^ Components of the package list , projectExtraDeps :: !(Map PackageName Version) -- ^ Components of the package list referring to package/version combos, @@ -622,12 +625,13 @@ data Project = Project instance ToJSON Project where toJSON p = object $ (maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p)) + ((maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p)) [ "packages" .= projectPackages p , "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p) , "flags" .= projectFlags p , "resolver" .= projectResolver p , "extra-package-dbs" .= projectExtraPackageDBs p - ] + ]) -- | How we resolve which dependencies to install given a set of packages. data Resolver @@ -1370,10 +1374,12 @@ instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warning flags <- o ..:? "flags" ..!= mempty resolver <- jsonSubWarnings (o ..: "resolver") compiler <- o ..:? "compiler" + msg <- o ..:? "user-message" config <- parseConfigMonoidJSON o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] let project = Project - { projectPackages = dirs + { projectUserMsg = msg + , projectPackages = dirs , projectExtraDeps = extraDeps , projectFlags = flags , projectResolver = resolver From 925952b7b5084170b74ee29b29599c950a4b61ae Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 16 Jan 2016 03:37:21 +0530 Subject: [PATCH 08/25] Solver: remove one package in conflict and retry When there is an unresolved conflict among the dependencies of multiple source packages then remove one of the conflicting packages and then retry. The package chosen to be removed is the one which is on top of the dependency pyramid i.e. noone else depends on it. The functionality is not yet complete. It will be complete once cabal output is parsed and the list of conflicting packages is fed to the upper level logic. See #1616 --- src/Stack/BuildPlan.hs | 9 +++-- src/Stack/Init.hs | 75 ++++++++++++++++++++++++++++-------------- src/Stack/Solver.hs | 57 ++++++++++++++++++++------------ 3 files changed, 93 insertions(+), 48 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 33ce3aa404..cacb21af31 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -15,6 +15,7 @@ module Stack.BuildPlan , checkSnapBuildPlan , DepError(..) , DepErrors + , gpdPackageDeps , gpdPackages , gpdPackageName , MiniBuildPlan(..) @@ -27,6 +28,7 @@ module Stack.BuildPlan , getToolMap , shadowMiniBuildPlan , showMapPackages + , showPackages , parseCustomMiniBuildPlan ) where @@ -764,8 +766,8 @@ selectBestSnapshot gpds snaps = do indent t = T.unlines $ fmap (" " <>) (T.lines t) -showMapPackages :: Map PackageName a -> Text -showMapPackages mp = T.concat (map formatItem $ Map.keys mp) +showPackages :: [PackageName] -> Text +showPackages pkgs = T.concat (map formatItem pkgs) where formatItem pkg = T.concat [ " - " @@ -773,6 +775,9 @@ showMapPackages mp = T.concat (map formatItem $ Map.keys mp) , "\n" ] +showMapPackages :: Map PackageName a -> Text +showMapPackages mp = showPackages $ Map.keys mp + showCompilerErrors :: Map PackageName (Map FlagName Bool) -> DepErrors diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index e5b4cda26c..5be69e3f2c 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -15,7 +15,7 @@ import Control.Monad (liftM, when) import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (MonadReader) +import Control.Monad.Reader (asks, MonadReader) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as L @@ -23,11 +23,11 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F -import Data.List (sortBy) +import Data.List (intersect, sortBy) import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (fromJust, mapMaybe) import Data.Monoid import qualified Data.Text as T import qualified Data.Yaml as Yaml @@ -301,17 +301,27 @@ getWorkingResolverPlan stackYaml initOpts bundle resolver = do -- if some packages failed try again using the rest case eres of Right (f, edeps)-> return (resolver, f, edeps, info) - Left e - | Map.null good -> + Left bad + | Map.null good -> do + $logWarn "None of the packages were found to be \ + \compatible with the resolver compiler." return (resolver, Map.empty, Map.empty, Map.empty) | otherwise -> do - $logWarn "Ignoring compiler incompatible packages:" - $logWarn $ indent $ showMapPackages failed - assert ((Map.size good) < (Map.size info)) (go good) + when ((Map.size good) == (Map.size info)) $ + error "Bug: No packages to ignore" + + if length bad > 1 then do + $logWarn "Ignoring compiler incompatible packages:" + $logWarn $ indent $ showPackages bad + else + $logWarn $ "Ignoring compiler incompatible package: " + <> (T.pack $ packageNameString (head bad)) + + go good where - failed = Map.unions (Map.elems (fmap deNeededBy e)) - good = Map.difference info failed - indent t = T.unlines $ fmap (" " <>) (T.lines t) + indent t = T.unlines $ fmap (" " <>) (T.lines t) + isGood k _ = not (k `elem` bad) + good = Map.filterWithKey isGood info checkBundleResolver :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m @@ -323,8 +333,8 @@ checkBundleResolver -> Map PackageName (Path Abs Dir, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description -> Resolver - -> m (Either DepErrors ( Map PackageName (Map FlagName Bool) - , Map PackageName Version)) + -> m (Either [PackageName] ( Map PackageName (Map FlagName Bool) + , Map PackageName Version)) checkBundleResolver stackYaml initOpts bundle resolver = do result <- checkResolverSpec gpds Nothing resolver case result of @@ -334,14 +344,15 @@ checkBundleResolver stackYaml initOpts bundle resolver = do $logWarn $ "Resolver " <> resolverName resolver <> " will need external packages: " $logWarn $ indent $ T.pack $ show result - liftM (\x -> Right x) (solve f) + solve f | otherwise -> throwM $ ResolverPartial resolver (show result) (BuildPlanCheckFail _ e _) | (forceOverwrite initOpts) -> do $logWarn $ "Resolver compiler mismatch: " <> resolverName resolver $logWarn $ indent $ T.pack $ show result - return $ Left e + let failed = Map.unions (Map.elems (fmap deNeededBy e)) + return $ Left (Map.keys failed) | otherwise -> throwM $ ResolverMismatch resolver (show result) where indent t = T.unlines $ fmap (" " <>) (T.lines t) @@ -350,18 +361,32 @@ checkBundleResolver stackYaml initOpts bundle resolver = do let cabalDirs = Map.elems (fmap fst bundle) srcConstraints = mergeConstraints (gpdPackages gpds) flags - mresult <- solveResolverSpec stackYaml cabalDirs + eresult <- solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, Map.empty) - case mresult of - Just (src, ext) -> - return (fmap snd (Map.union src ext), 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 (flags, Map.empty) + case eresult of + Right (src, ext) -> + return $ Right (fmap snd (Map.union src ext), fmap fst ext) + Left packages + | forceOverwrite initOpts, srcpkgs /= []-> do + pkg <- findOneIndependent srcpkgs flags + return $ Left [pkg] | otherwise -> throwM (SolverGiveUp giveUpMsg) + where srcpkgs = intersect (Map.keys bundle) packages + + -- among a list of packages find one on which none among the rest of the + -- packages depend. This package is a good candidate to be removed from + -- the list of packages when there is conflict in dependencies among this + -- set of packages. + findOneIndependent packages flags = do + platform <- asks (configPlatform . getConfig) + (compiler, _) <- getResolverConstraints stackYaml resolver + let getGpd pkg = snd (fromJust (Map.lookup pkg bundle)) + getFlags pkg = fromJust (Map.lookup pkg flags) + deps pkg = gpdPackageDeps (getGpd pkg) compiler platform + (getFlags pkg) + allDeps = concat $ map (Map.keys . deps) packages + isIndependent pkg = not $ pkg `elem` allDeps + return $ head (filter isIndependent packages) giveUpMsg = concat [ " - Use '--ignore-subdirs' to skip packages in subdirectories.\n" diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index a49a68c485..2223f34f17 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -6,6 +6,7 @@ module Stack.Solver ( checkResolverSpec , cabalPackagesCheck , findCabalFiles + , getResolverConstraints , mergeConstraints , solveExtraDeps , solveResolverSpec @@ -307,14 +308,14 @@ solveResolverSpec , ConstraintSpec) -- ^ ( resolver -- , src package constraints -- , extra dependency constraints ) - -> m (Maybe ( ConstraintSpec - , ConstraintSpec)) -- ^ ( resulting src package specs - -- , resulting external package specs ) + -> m (Either [PackageName] (ConstraintSpec , ConstraintSpec)) + -- ^ (Conflicting packages + -- (resulting src package specs, external dependency specs)) solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, extraConstraints) = do $logInfo $ "Using resolver: " <> resolverName resolver - (compilerVer, snapConstraints) <- getResolverConstraints resolver + (compilerVer, snapConstraints) <- getResolverConstraints stackYaml resolver menv <- setupCabalEnv compilerVer let -- Note - The order in Map.union below is important. @@ -367,28 +368,39 @@ solveResolverSpec stackYaml cabalDirs <> T.pack (show $ Map.size external) <> " external dependencies." - return $ Just (srcs, external) + return $ Right (srcs, external) Nothing -> do $logInfo $ "Failed to arrive at a workable build plan using " <> resolverName resolver <> " resolver." - return Nothing + -- TODO get the list of conflicting packages from cabal and return + -- it here. + return $ Left [] + +getResolverConstraints + :: ( 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 + -> Resolver + -> m (CompilerVersion, + Map PackageName (Version, Map FlagName Bool)) +getResolverConstraints stackYaml resolver + | (ResolverSnapshot snapName) <- resolver = do + mbp <- loadMiniBuildPlan snapName + return (mbpCompilerVersion mbp, mbpConstraints mbp) + | (ResolverCustom _ url) <- resolver = do + -- FIXME instead of passing the stackYaml dir we should maintain + -- the file URL in the custom resolver always relative to stackYaml. + mbp <- parseCustomMiniBuildPlan stackYaml url + return (mbpCompilerVersion mbp, mbpConstraints mbp) + | (ResolverCompiler compiler) <- resolver = + return (compiler, Map.empty) + | otherwise = error "Not reached" where mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi) mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp) - getResolverConstraints (ResolverSnapshot snapName) = do - mbp <- loadMiniBuildPlan snapName - return (mbpCompilerVersion mbp, mbpConstraints mbp) - - 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. - getResolverConstraints (ResolverCustom _ url) = do - mbp <- parseCustomMiniBuildPlan stackYaml url - 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 -- of the packages. If 'flags' is passed as 'Nothing' then flags are chosen @@ -536,9 +548,12 @@ solveExtraDeps modStackYaml = do resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just ((mergeConstraints oldSrcs flags), Map.empty) - BuildPlanCheckPartial _ _ -> - solveResolverSpec stackYaml cabalDirs + BuildPlanCheckPartial _ _ -> do + eres <- solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, extraConstraints) + -- TODO Solver should also use the init code to ignore incompatible + -- packages + return $ either (const Nothing) Just eres (BuildPlanCheckFail _ _ _) -> throwM $ ResolverMismatch resolver (show resolverResult) From b7c535f5ca9b1021498ce69d8a39e7a30d89cfec Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 16 Jan 2016 17:40:28 +0530 Subject: [PATCH 09/25] Solver: resolve conflict by ignoring packages When there is an unresolvable conflict among the dependencies of multiple user packages ignore one of them and try again to resolve the rest. This commit adds code for parsing cabal output to find out user packages involved in the conflict. This output is then used to decide one of those packages to be ignored from consideration in the next try. Fixes #1616 --- src/Stack/Init.hs | 31 +++++++++--------- src/Stack/Solver.hs | 77 ++++++++++++++++++++++++++++++++------------- 2 files changed, 71 insertions(+), 37 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 5be69e3f2c..41f4c8dfa0 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -301,27 +301,28 @@ getWorkingResolverPlan stackYaml initOpts bundle resolver = do -- if some packages failed try again using the rest case eres of Right (f, edeps)-> return (resolver, f, edeps, info) - Left bad - | Map.null good -> do - $logWarn "None of the packages were found to be \ - \compatible with the resolver compiler." + Left ignored + | Map.null available -> do + $logWarn "*** Could not find a working plan for any of \ + \the user packages.\nProceeding to create a \ + \config anyway." return (resolver, Map.empty, Map.empty, Map.empty) | otherwise -> do - when ((Map.size good) == (Map.size info)) $ + when ((Map.size available) == (Map.size info)) $ error "Bug: No packages to ignore" - if length bad > 1 then do - $logWarn "Ignoring compiler incompatible packages:" - $logWarn $ indent $ showPackages bad + if length ignored > 1 then do + $logWarn "*** Ignoring packages:" + $logWarn $ indent $ showPackages ignored else - $logWarn $ "Ignoring compiler incompatible package: " - <> (T.pack $ packageNameString (head bad)) + $logWarn $ "*** Ignoring package: " + <> (T.pack $ packageNameString (head ignored)) - go good + go available where indent t = T.unlines $ fmap (" " <>) (T.lines t) - isGood k _ = not (k `elem` bad) - good = Map.filterWithKey isGood info + isAvailable k _ = not (k `elem` ignored) + available = Map.filterWithKey isAvailable info checkBundleResolver :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m @@ -341,14 +342,14 @@ checkBundleResolver stackYaml initOpts bundle resolver = do BuildPlanCheckOk f -> return $ Right (f, Map.empty) (BuildPlanCheckPartial f _) | needSolver resolver initOpts -> do - $logWarn $ "Resolver " <> resolverName resolver + $logWarn $ "*** Resolver " <> resolverName resolver <> " will need external packages: " $logWarn $ indent $ T.pack $ show result solve f | otherwise -> throwM $ ResolverPartial resolver (show result) (BuildPlanCheckFail _ e _) | (forceOverwrite initOpts) -> do - $logWarn $ "Resolver compiler mismatch: " + $logWarn $ "*** Resolver compiler mismatch: " <> resolverName resolver $logWarn $ indent $ T.pack $ show result let failed = Map.unions (Map.elems (fmap deNeededBy e)) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 2223f34f17..b594ad0c01 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -28,6 +28,7 @@ import Data.List ((\\), isSuffixOf, intercalate) import Data.List.Extra (groupSortOn) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (catMaybes, isNothing) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set @@ -38,7 +39,9 @@ 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.Package as C import qualified Distribution.PackageDescription as C +import qualified Distribution.Text as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.Find (findFiles) @@ -72,7 +75,7 @@ cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, Mo -> ConstraintSpec -- ^ src constraints -> ConstraintSpec -- ^ dep constraints -> [String] -- ^ additional arguments - -> m (Maybe ConstraintSpec) + -> m (Either [PackageName] ConstraintSpec) cabalSolver menv cabalfps constraintType srcConstraints depConstraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do @@ -104,22 +107,52 @@ cabalSolver menv cabalfps constraintType toConstraintArgs (flagConstraints constraintType) ++ fmap toFilePath cabalfps - catch (liftM Just (readProcessStdout (Just tmpdir) menv "cabal" args)) + catch (liftM Right (readProcessStdout (Just tmpdir) menv "cabal" args)) (\ex -> case ex of - ReadProcessException _ _ _ err -> do - let errMsg = decodeUtf8With lenientDecode err - if LT.isInfixOf "Could not resolve dependencies" errMsg - then do - $logInfo "Attempt failed." - $logInfo "\n>>>> Cabal errors begin" - $logInfo $ LT.toStrict errMsg - <> "<<<< Cabal errors end\n" - return Nothing - else throwM ex + ReadProcessException _ _ _ err -> return $ Left err _ -> throwM ex) - >>= maybe (return Nothing) parseCabalOutput + >>= either parseCabalErrors parseCabalOutput where + errCheck = LT.isInfixOf "Could not resolve dependencies" + + parseCabalErrors err = do + let errExit = error "Could not parse cabal-install errors" + msg = decodeUtf8With lenientDecode err + + if errCheck msg then do + $logInfo "Attempt failed." + $logInfo "\n>>>> Cabal errors begin" + $logInfo $ LT.toStrict msg + <> "<<<< Cabal errors end\n" + $logInfo $ "*** User packages involved in cabal failure: " + <> (LT.toStrict $ LT.intercalate ", " + $ parseConflictingPkgs msg) + let pkgs = parseConflictingPkgs msg + mPkgNames = map (C.simpleParse . T.unpack . LT.toStrict) pkgs + pkgNames = map (fromCabalPackageName . C.pkgName) + (catMaybes mPkgNames) + + when (any isNothing mPkgNames) $ + $logInfo $ "*** Only some package names could be parsed: " <> + (T.pack (intercalate ", " (map show pkgNames))) + + if pkgNames /= [] then do + return $ Left pkgNames + else errExit + else errExit + + parseConflictingPkgs msg = + let ls = dropWhile (not . errCheck) $ LT.lines msg + select s = ((LT.isPrefixOf "trying:" s) + || (LT.isPrefixOf "next goal:" s)) + && (LT.isSuffixOf "(user goal)" s) + pkgName = (take 1) + . LT.words + . (LT.drop 1) + . (LT.dropWhile (/= ':')) + in concat $ map pkgName (filter select ls) + parseCabalOutput bs = do let ls = drop 1 $ dropWhile (not . T.isPrefixOf "In order, ") @@ -127,7 +160,7 @@ cabalSolver menv cabalfps constraintType $ decodeUtf8 bs (errs, pairs) = partitionEithers $ map parseLine ls if null errs - then return $ Just (Map.fromList pairs) + then return $ Right (Map.fromList pairs) else error $ "Could not parse cabal-install output: " ++ show errs parseLine t0 = maybe (Left t0) Right $ do @@ -341,15 +374,15 @@ solveResolverSpec stackYaml cabalDirs unless (Map.null depOnlyConstraints) ($logInfo $ "Trying with " <> srcNames <> " as hard constraints...") - mdeps <- solver Constraint - mdeps' <- case mdeps of - Nothing | not (Map.null depOnlyConstraints) -> do + eresult <- solver Constraint + eresult' <- case eresult of + Left _ | not (Map.null depOnlyConstraints) -> do $logInfo $ "Retrying with " <> srcNames <> " as preferences..." solver Preference - _ -> return mdeps + _ -> return eresult - case mdeps' of - Just deps -> do + case eresult' of + Right deps -> do let -- All src package constraints returned by cabal. -- Flags may have changed. @@ -369,12 +402,12 @@ solveResolverSpec stackYaml cabalDirs <> " external dependencies." return $ Right (srcs, external) - Nothing -> do + Left x -> do $logInfo $ "Failed to arrive at a workable build plan using " <> resolverName resolver <> " resolver." -- TODO get the list of conflicting packages from cabal and return -- it here. - return $ Left [] + return $ Left x getResolverConstraints :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m From 3e6508d087d974491e7eb2bd64045cecb9af665a Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 17 Jan 2016 13:49:51 +0530 Subject: [PATCH 10/25] init - ignore duplicated package names When using stack init if duplicated package names are found automatically ignore the duplicates with a warning. --- src/Stack/BuildPlan.hs | 13 +++-- src/Stack/Init.hs | 107 ++++++++++++++++++++++++----------------- src/Stack/Solver.hs | 53 +++++++++++--------- 3 files changed, 98 insertions(+), 75 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index cacb21af31..fada987341 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -27,8 +27,7 @@ module Stack.BuildPlan , ToolMap , getToolMap , shadowMiniBuildPlan - , showMapPackages - , showPackages + , showItems , parseCustomMiniBuildPlan ) where @@ -766,17 +765,17 @@ selectBestSnapshot gpds snaps = do indent t = T.unlines $ fmap (" " <>) (T.lines t) -showPackages :: [PackageName] -> Text -showPackages pkgs = T.concat (map formatItem pkgs) +showItems :: Show a => [a] -> Text +showItems items = T.concat (map formatItem items) where - formatItem pkg = T.concat + formatItem item = T.concat [ " - " - , T.pack $ packageNameString pkg + , T.pack $ show item , "\n" ] showMapPackages :: Map PackageName a -> Text -showMapPackages mp = showPackages $ Map.keys mp +showMapPackages mp = showItems $ Map.keys mp showCompilerErrors :: Map PackageName (Map FlagName Bool) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 41f4c8dfa0..c92ed70a7f 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -70,20 +70,19 @@ 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 - bundle <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter + (bundle, dupPkgs) <- cabalPackagesCheck cabalfps noPkgMsg Nothing (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts bundle let ignored = Map.difference bundle rbundle + dupPkgMsg + | (dupPkgs /= []) = + "Warning: Some packages were found to have names conflicting \ + \with others and have been commented out in the \ + \packages section.\n" + | otherwise = "" + missingPkgMsg | (Map.size ignored > 0) = "Warning: Some packages were found to be incompatible with \ @@ -98,13 +97,15 @@ initProject currDir initOpts = do \as dependencies.\n" | otherwise = "" - footer - | (Map.size ignored > 0) || (Map.size extraDeps > 0) = - "You can suppress this message by removing it from \ - \stack.yaml\n" - | otherwise = "" + makeUserMsg msgs = + let msg = concat msgs + in if msg /= "" then + msg <> "You can suppress this message by removing it from \ + \stack.yaml\n" + else "" + + userMsg = makeUserMsg [dupPkgMsg, missingPkgMsg, extraDepMsg] - userMsg = missingPkgMsg <> extraDepMsg <> footer gpds = Map.elems $ fmap snd rbundle p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg @@ -116,31 +117,41 @@ initProject currDir initOpts = do , projectExtraPackageDBs = [] } - makeRel dir = + makeRelDir dir = case stripDir currDir dir of Nothing | currDir == dir -> "." | otherwise -> assert False $ toFilePath dir Just rel -> toFilePath rel - pkgs = map toPkg $ Map.elems (fmap fst rbundle) + makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath + + pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle) toPkg dir = PackageEntry { peValidWanted = Nothing , peExtraDepMaybe = Nothing - , peLocation = PLFilePath $ makeRel dir + , peLocation = PLFilePath $ makeRelDir dir , peSubdirs = [] } indent t = T.unlines $ fmap (" " <>) (T.lines t) $logInfo $ "Initialising configuration using resolver: " <> resolverName r + $logInfo $ "Total number of packages considered: " + <> (T.pack $ show $ (Map.size bundle + length dupPkgs)) + + when (dupPkgs /= []) $ do + $logWarn $ "Warning! Ignoring " + <> (T.pack $ show $ length dupPkgs) + <> " duplicate packages:" + rels <- mapM makeRel dupPkgs + $logWarn $ indent $ showItems rels when (Map.size ignored > 0) $ do $logWarn $ "Warning! Ignoring " <> (T.pack $ show $ Map.size ignored) - <> " out of " - <> (T.pack $ show $ Map.size bundle) - <> " packages:" - $logWarn $ indent $ showMapPackages ignored + <> " packages due to dependency conflicts:" + rels <- mapM makeRel (Map.elems (fmap fst ignored)) + $logWarn $ indent $ showItems $ rels when (Map.size extraDeps > 0) $ do $logWarn $ "Warning! " <> (T.pack $ show $ Map.size extraDeps) @@ -151,13 +162,15 @@ initProject currDir initOpts = do <> T.pack reldest liftIO $ L.writeFile dest' $ B.toLazyByteString - $ renderStackYaml p (Map.elems $ fmap (makeRel . fst) ignored) + $ renderStackYaml p + (Map.elems $ fmap (makeRelDir . parent . fst) ignored) + (map (makeRelDir . parent) dupPkgs) $logInfo "All done." -- | Render a stack.yaml file with comments, see: -- https://github.com/commercialhaskell/stack/issues/226 -renderStackYaml :: Project -> [FilePath]-> B.Builder -renderStackYaml p ignoredPackages = +renderStackYaml :: Project -> [FilePath] -> [FilePath] -> B.Builder +renderStackYaml p ignoredPackages dupPackages = case Yaml.toJSON p of Yaml.Object o -> renderObject o _ -> assert False $ B.byteString $ Yaml.encode p @@ -182,21 +195,31 @@ renderStackYaml p ignoredPackages = \# Allow a newer minor version of GHC than the snapshot specifies\n\ \# compiler-check: newer-minor\n" - ignoredPackagesComment = - if ignoredPackages /= [] then - "\n# Note: Some packages were found to be incompatible with the resolver and \ - \have been commented out" - else "" - comments = [ ("user-message", "A message to be displayed to the user. Used when autogenerated config ignored some packages or added extra deps.") , ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)") - , ("packages", "Local packages, usually specified by relative directory name" <> ignoredPackagesComment) + , ("packages", "Local packages, usually specified by relative directory name") , ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)") , ("flags", "Override default flag values for local packages and extra-deps") , ("extra-package-dbs", "Extra package databases containing global packages") ] + commentedPackages = + let ignoredComment = "# The following packages have been ignored \ + \due to incompatibility with the resolver compiler or \ + \dependency conflicts with other packages" + dupComment = "# The following packages have been ignored due \ + \to package name conflict with other packages" + in commentPackages ignoredComment ignoredPackages + <> commentPackages dupComment dupPackages + + commentPackages comment pkgs + | pkgs /= [] = + B.byteString (BC.pack $ comment ++ "\n") + <> (B.byteString $ BC.pack $ concat + $ (map (\x -> "#- " ++ x ++ "\n") pkgs) ++ ["\n"]) + | otherwise = "" + goComment o (name, comment) = case HM.lookup name o of Nothing -> assert (name == "user-message") mempty @@ -205,11 +228,7 @@ renderStackYaml p ignoredPackages = B.byteString comment <> B.byteString "\n" <> B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <> - if (name == "packages") then - B.byteString $ BC.pack $ concat - $ (map (\x -> "#- " ++ x ++ "\n") - ignoredPackages) ++ ["\n"] - else "" <> + if (name == "packages") then commentedPackages else "" <> B.byteString "\n" goOthers o @@ -244,12 +263,12 @@ getDefaultResolver , HasTerminal env) => Path Abs File -- ^ stack.yaml -> InitOpts - -> Map PackageName (Path Abs Dir, C.GenericPackageDescription) + -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description -> m ( Resolver , Map PackageName (Map FlagName Bool) , Map PackageName Version - , Map PackageName (Path Abs Dir, C.GenericPackageDescription)) + , Map PackageName (Path Abs File, C.GenericPackageDescription)) -- ^ ( Resolver -- , Flags for src packages and extra deps -- , Extra dependencies @@ -281,13 +300,13 @@ getWorkingResolverPlan , HasTerminal env) => Path Abs File -- ^ stack.yaml -> InitOpts - -> Map PackageName (Path Abs Dir, C.GenericPackageDescription) + -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description -> Resolver -> m ( Resolver , Map PackageName (Map FlagName Bool) , Map PackageName Version - , Map PackageName (Path Abs Dir, C.GenericPackageDescription)) + , Map PackageName (Path Abs File, C.GenericPackageDescription)) -- ^ ( Resolver -- , Flags for src packages and extra deps -- , Extra dependencies @@ -313,7 +332,7 @@ getWorkingResolverPlan stackYaml initOpts bundle resolver = do if length ignored > 1 then do $logWarn "*** Ignoring packages:" - $logWarn $ indent $ showPackages ignored + $logWarn $ indent $ showItems ignored else $logWarn $ "*** Ignoring package: " <> (T.pack $ packageNameString (head ignored)) @@ -331,7 +350,7 @@ checkBundleResolver , HasTerminal env) => Path Abs File -- ^ stack.yaml -> InitOpts - -> Map PackageName (Path Abs Dir, C.GenericPackageDescription) + -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description -> Resolver -> m (Either [PackageName] ( Map PackageName (Map FlagName Bool) @@ -359,7 +378,7 @@ checkBundleResolver stackYaml initOpts bundle resolver = do indent t = T.unlines $ fmap (" " <>) (T.lines t) gpds = Map.elems (fmap snd bundle) solve flags = do - let cabalDirs = Map.elems (fmap fst bundle) + let cabalDirs = map parent (Map.elems (fmap fst bundle)) srcConstraints = mergeConstraints (gpdPackages gpds) flags eresult <- solveResolverSpec stackYaml cabalDirs diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index b594ad0c01..0b9e259b2e 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -125,7 +125,7 @@ cabalSolver menv cabalfps constraintType $logInfo "\n>>>> Cabal errors begin" $logInfo $ LT.toStrict msg <> "<<<< Cabal errors end\n" - $logInfo $ "*** User packages involved in cabal failure: " + $logInfo $ "User packages involved in cabal failure: " <> (LT.toStrict $ LT.intercalate ", " $ parseConflictingPkgs msg) let pkgs = parseConflictingPkgs msg @@ -403,10 +403,7 @@ solveResolverSpec stackYaml cabalDirs return $ Right (srcs, external) Left x -> do - $logInfo $ "Failed to arrive at a workable build plan using " - <> resolverName resolver <> " resolver." - -- TODO get the list of conflicting packages from cabal and return - -- it here. + $logInfo $ "*** Failed to arrive at a workable build plan." return $ Left x getResolverConstraints @@ -481,9 +478,10 @@ cabalPackagesCheck , HasTerminal env) => [Path Abs File] -> String - -> String - -> m (Map PackageName (Path Abs Dir, C.GenericPackageDescription)) -cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do + -> Maybe String + -> m ( Map PackageName (Path Abs File, C.GenericPackageDescription) + , [Path Abs File]) +cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do when (null cabalfps) $ error noPkgMsg @@ -491,23 +489,30 @@ cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do $logInfo $ "Using 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 $ Map.fromList - $ zipWith (\dir gpd -> ((gpdPackageName gpd),(dir, gpd))) - (map parent cabalfps) - gpds + let dupTails = concat $ map tail (dupGroups cabalfps) + when (dupTails /= []) $ do + dups <- mapM (mapM makeRel) (dupGroups cabalfps) + $logWarn $ T.pack $ + "Following packages have duplicate names:\n" + <> intercalate "\n" (map formatGroup dups) + <> "\n" + case dupErrMsg of + Nothing -> $logWarn $ T.pack $ + "*** Only the first one among packages with \ + \duplicate names will be used." + Just msg -> error msg + + let uniquefps = cabalfps \\ dupTails + (warnings, gpds) <- fmap unzip (mapM readPackageUnresolved uniquefps) + zipWithM_ (mapM_ . printCabalFileWarning) uniquefps warnings + return (Map.fromList + $ zipWith (\dir gpd -> ((gpdPackageName gpd),(dir, gpd))) + uniquefps gpds + , dupTails) where - groups = filter ((> 1) . length) . groupSortOn (FP.takeFileName) - dupGroups = (map formatGroup) . groups + dupGroups = filter ((> 1) . length) + . groupSortOn (FP.takeFileName . toFilePath) makeRel :: (MonadIO m) => Path Abs File -> m FilePath makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath @@ -564,7 +569,7 @@ solveExtraDeps modStackYaml = do -- TODO when solver supports --ignore-subdirs option pass that as the -- second argument here. reportMissingCabalFiles cabalfps True - bundle <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter + (bundle, _) <- cabalPackagesCheck cabalfps noPkgMsg (Just dupPkgFooter) let gpds = Map.elems $ fmap snd bundle oldFlags = bcFlags bconfig From 91bb0bb771172f9ec5a2a32d18ec3e8382ae7793 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 17 Jan 2016 15:18:06 +0530 Subject: [PATCH 11/25] stack init: add --omit-packages CLI option Remove the overloading of --force option and use it exclusively for overwriting an existing config. Use a separate --omit-packages option for excluding conflicting or incompatible packages from generated config. See #1621 --- src/Stack/Init.hs | 17 +++++++++-------- src/Stack/Options.hs | 8 +++++--- src/Stack/Types/Config.hs | 11 +++++++---- 3 files changed, 21 insertions(+), 15 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index c92ed70a7f..686943575a 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -289,7 +289,7 @@ getDefaultResolver stackYaml initOpts bundle = let gpds = Map.elems (fmap snd bundle) (s, r) <- selectBestSnapshot gpds snaps case r of - (BuildPlanCheckFail _ _ _) | not (forceOverwrite initOpts) + (BuildPlanCheckFail _ _ _) | not (omitPackages initOpts) -> throwM (NoMatchingSnapshot snaps) _ -> return $ ResolverSnapshot s @@ -367,7 +367,7 @@ checkBundleResolver stackYaml initOpts bundle resolver = do solve f | otherwise -> throwM $ ResolverPartial resolver (show result) (BuildPlanCheckFail _ e _) - | (forceOverwrite initOpts) -> do + | (omitPackages initOpts) -> do $logWarn $ "*** Resolver compiler mismatch: " <> resolverName resolver $logWarn $ indent $ T.pack $ show result @@ -387,7 +387,7 @@ checkBundleResolver stackYaml initOpts bundle resolver = do Right (src, ext) -> return $ Right (fmap snd (Map.union src ext), fmap fst ext) Left packages - | forceOverwrite initOpts, srcpkgs /= []-> do + | omitPackages initOpts, srcpkgs /= []-> do pkg <- findOneIndependent srcpkgs flags return $ Left [pkg] | otherwise -> throwM (SolverGiveUp giveUpMsg) @@ -409,13 +409,12 @@ checkBundleResolver stackYaml initOpts bundle resolver = do return $ head (filter isIndependent packages) 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" + [ " - Use '--omit-packages to exclude conflicting package(s).\n" + , " - Tweak the generated " + , toFilePath stackDotYaml <> " and then run 'stack solver':\n" , " - Add any missing remote packages.\n" , " - Add extra dependencies to guide solver.\n" + , " - Update external packages with 'stack update' and try again.\n" ] needSolver _ (InitOpts {useSolver = True}) = True @@ -462,6 +461,8 @@ data InitOpts = InitOpts -- ^ Use solver , useSolver :: Bool -- ^ Preferred snapshots + , omitPackages :: Bool + -- ^ Exclude conflicting or incompatible packages , forceOverwrite :: Bool -- ^ Overwrite existing files , includeSubDirs :: Bool diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 4851771498..ae179e4e4e 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -670,13 +670,15 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts initOptsParser :: Parser InitOpts initOptsParser = - InitOpts <$> method <*> solver <*> overwrite <*> fmap not ignoreSubDirs + InitOpts <$> method <*> solver <*> omitPackages + <*> 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 an existing stack.yaml or \ - \creating a stack.yaml with incomplete config.") + help "Force overwriting an existing stack.yaml") + omitPackages = switch (long "omit-packages" <> + help "Exlcude conflicting or incompatible packages") solver = switch (long "solver" <> help "Use a dependency solver to determine extra dependencies") diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 0ee37113f7..688d1623a5 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1127,17 +1127,20 @@ instance Show ConfigException where , unlines $ map (\name -> " - " <> T.unpack (renderSnapName name)) names , "\nYou can try the following options:\n" - , " - Use '--force' to ignore mismatching package(s).\n" + , " - Use '--omit-packages to exclude mismatching package(s).\n" , " - Use '--resolver' to specify a matching snapshot/resolver\n" ] show (ResolverMismatch resolver errDesc) = concat - [ "Selected resolver '" + [ "Resolver '" , T.unpack (resolverName resolver) - , "' does not have a matching compiler to build your package(s).\n" + , "' does not have a matching compiler to build some or all of your " + , "package(s).\n" , errDesc + , "\nHowever, you can try '--omit-packages to exclude mismatching " + , "package(s)." ] show (ResolverPartial resolver errDesc) = concat - [ "Selected resolver '" + [ "Resolver '" , T.unpack (resolverName resolver) , "' does not have all the packages to match your requirements.\n" , unlines $ fmap (" " <>) (lines errDesc) From 592cdb002cf8d1b1012d075ccad16b9a8e060c91 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 17 Jan 2016 23:41:43 +0530 Subject: [PATCH 12/25] Choose a resolver which builds max user packages When all resolver compilers are incompatible with some user packages then choose the one which can build maximum number of packages rather then the one with least number of compiler incompatibility errors. --- src/Stack/BuildPlan.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index fada987341..006431bb80 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -661,7 +661,8 @@ instance Ord BuildPlanCheck where compare (Map.size e1) (Map.size e2) (BuildPlanCheckFail _ e1 _) `compare` (BuildPlanCheckFail _ e2 _) = - compare (Map.size e1) (Map.size e2) + let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e)) + in compare (numUserPkgs e1) (numUserPkgs e2) (BuildPlanCheckOk _) `compare` (BuildPlanCheckOk _) = EQ (BuildPlanCheckOk _) `compare` (BuildPlanCheckPartial _ _) = GT @@ -674,7 +675,8 @@ instance Eq BuildPlanCheck where (BuildPlanCheckPartial _ e1) == (BuildPlanCheckPartial _ e2) = (Map.size e1) == (Map.size e2) (BuildPlanCheckFail _ e1 _) == (BuildPlanCheckFail _ e2 _) = - (Map.size e1) == (Map.size e2) + let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e)) + in numUserPkgs e1 == numUserPkgs e2 _ == _ = False From 5d7b66dde289ea7cd5131aca54e2355b41982f60 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 18 Jan 2016 01:43:04 +0530 Subject: [PATCH 13/25] init: try all major lts snapshot versions Remove the affinity to existing in-use snapshots. Try latest major lts, then latest nightly and then all other major lts versions in the most recent first order. Fixes #1628 --- src/Stack/Init.hs | 75 ++++++++++++++------------------------------ src/Stack/Options.hs | 13 ++------ 2 files changed, 25 insertions(+), 63 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 686943575a..086a84e59f 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -5,13 +5,12 @@ module Stack.Init ( initProject , InitOpts (..) - , SnapPref (..) , Method (..) ) where import Control.Exception (assert) -import Control.Exception.Enclosed (catchAny, handleIO) -import Control.Monad (liftM, when) +import Control.Exception.Enclosed (catchAny) +import Control.Monad (when) import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class import Control.Monad.Logger @@ -23,11 +22,11 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F -import Data.List (intersect, sortBy) +import Data.List (intersect) import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromJust, mapMaybe) +import Data.Maybe (fromJust) import Data.Monoid import qualified Data.Text as T import qualified Data.Yaml as Yaml @@ -41,8 +40,7 @@ import Stack.Solver import Stack.Types import Stack.Types.Internal ( HasTerminal, HasReExec , HasLogLevel) -import System.Directory ( getDirectoryContents - , makeRelativeToCurrentDirectory) +import System.Directory (makeRelativeToCurrentDirectory) import Stack.Config ( getSnapshots , makeConcreteResolver) @@ -236,9 +234,9 @@ renderStackYaml p ignoredPackages dupPackages = | otherwise = assert False $ B.byteString $ Yaml.encode o getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m) - => m (Maybe Snapshots) + => m Snapshots getSnapshots' = - liftM Just getSnapshots `catchAny` \e -> do + getSnapshots `catchAny` \e -> do $logError $ "Unable to download snapshot list, and therefore could " <> "not generate a stack.yaml file automatically" @@ -253,7 +251,7 @@ getSnapshots' = $logError " http://docs.haskellstack.org/en/stable/yaml_configuration.html" $logError "" $logError $ "Exception was: " <> T.pack (show e) - return Nothing + error "" -- | Get the default resolver value getDefaultResolver @@ -278,15 +276,12 @@ getDefaultResolver stackYaml initOpts bundle = >>= getWorkingResolverPlan stackYaml initOpts bundle where -- TODO support selecting best across regular and custom snapshots - getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref + getResolver (MethodAutoSelect) = selectSnapResolver getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver - selectSnapResolver snapPref = do - msnaps <- getSnapshots' - snaps <- maybe (error "No snapshots to select from.") - (getRecommendedSnapshots snapPref) - msnaps + selectSnapResolver = do let gpds = Map.elems (fmap snd bundle) + snaps <- getSnapshots' >>= getRecommendedSnapshots (s, r) <- selectBestSnapshot gpds snaps case r of (BuildPlanCheckFail _ _ _) | not (omitPackages initOpts) @@ -422,39 +417,17 @@ checkBundleResolver stackYaml initOpts bundle resolver = do needSolver _ _ = False getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) - => SnapPref - -> Snapshots + => Snapshots -> m [SnapName] -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. - -- TODO Include all major compiler versions available - existing <- - liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $ - snapshotsDir >>= - liftIO . handleIO (const $ return []) - . getDirectoryContents . toFilePath - let isLTS LTS{} = True - isLTS Nightly{} = False - isNightly Nightly{} = True - isNightly LTS{} = False - - names = nubOrd $ concat - [ take 2 $ filter isLTS existing - , take 2 $ filter isNightly existing - , map (uncurry LTS) - (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots) - , [Nightly $ snapshotsNightly snapshots] - ] - - namesLTS = filter isLTS names - namesNightly = filter isNightly names - - case pref of - PrefNone -> return names - PrefLTS -> return $ namesLTS ++ namesNightly - PrefNightly -> return $ namesNightly ++ namesLTS +getRecommendedSnapshots snapshots = do + -- in order - Latest LTS, Latest Nightly, all LTS most recent first + return $ nubOrd $ concat + [ map (uncurry LTS) + (take 1 $ reverse $ IntMap.toList $ snapshotsLts snapshots) + , [Nightly $ snapshotsNightly snapshots] + , map (uncurry LTS) + (drop 1 $ reverse $ IntMap.toList $ snapshotsLts snapshots) + ] data InitOpts = InitOpts { ioMethod :: !Method @@ -462,14 +435,12 @@ data InitOpts = InitOpts , useSolver :: Bool -- ^ Preferred snapshots , omitPackages :: Bool - -- ^ Exclude conflicting or incompatible packages + -- ^ Exclude conflicting or incompatible user packages , forceOverwrite :: Bool -- ^ Overwrite existing files , includeSubDirs :: Bool -- ^ If True, include all .cabal files found in any sub directories } -data SnapPref = PrefNone | PrefLTS | PrefNightly - -- | Method of initializing -data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver +data Method = MethodAutoSelect | MethodResolver AbstractResolver diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index ae179e4e4e..a792a64d49 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -678,21 +678,12 @@ initOptsParser = overwrite = switch (long "force" <> help "Force overwriting an existing stack.yaml") omitPackages = switch (long "omit-packages" <> - help "Exlcude conflicting or incompatible packages") + help "Exclude conflicting or incompatible user packages") solver = switch (long "solver" <> help "Use a dependency solver to determine extra dependencies") method = (MethodResolver <$> resolver) - <|> (MethodSnapshot <$> snapPref) - - snapPref = - flag' PrefLTS - (long "prefer-lts" <> - help "Prefer LTS snapshots over Nightly snapshots") <|> - flag' PrefNightly - (long "prefer-nightly" <> - help "Prefer Nightly snapshots over LTS snapshots") <|> - pure PrefNone + <|> (pure MethodAutoSelect) resolver = option readAbstractResolver (long "resolver" <> From f569a16a29abc90552f3aba5f7b3697492f41a2c Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 18 Jan 2016 02:35:08 +0530 Subject: [PATCH 14/25] init: use global --resolver option stack init now uses the global --resolver option instead of its own implementation of the same. This changes the CLI behavior: you will have to use `stack --resolver lts-4.1 init` instead of `stack init --resolver lts-4.1` Fixes #1588 --- src/Stack/Init.hs | 22 ++++++++-------------- src/Stack/Options.hs | 10 +--------- src/main/Main.hs | 5 ++--- 3 files changed, 11 insertions(+), 26 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 086a84e59f..e636dbb1ce 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -5,7 +5,6 @@ module Stack.Init ( initProject , InitOpts (..) - , Method (..) ) where import Control.Exception (assert) @@ -52,8 +51,9 @@ initProject , HasTerminal env) => Path Abs Dir -> InitOpts + -> Maybe AbstractResolver -> m () -initProject currDir initOpts = do +initProject currDir initOpts mresolver = do let dest = currDir stackDotYaml dest' = toFilePath dest @@ -71,7 +71,8 @@ initProject currDir initOpts = do cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir (bundle, dupPkgs) <- cabalPackagesCheck cabalfps noPkgMsg Nothing - (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts bundle + (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts + mresolver bundle let ignored = Map.difference bundle rbundle dupPkgMsg @@ -261,6 +262,7 @@ getDefaultResolver , HasTerminal env) => Path Abs File -- ^ stack.yaml -> InitOpts + -> Maybe AbstractResolver -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description -> m ( Resolver @@ -271,14 +273,11 @@ getDefaultResolver -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered) -getDefaultResolver stackYaml initOpts bundle = - getResolver (ioMethod initOpts) +getDefaultResolver stackYaml initOpts mresolver bundle = + maybe selectSnapResolver makeConcreteResolver mresolver >>= getWorkingResolverPlan stackYaml initOpts bundle where -- TODO support selecting best across regular and custom snapshots - getResolver (MethodAutoSelect) = selectSnapResolver - getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver - selectSnapResolver = do let gpds = Map.elems (fmap snd bundle) snaps <- getSnapshots' >>= getRecommendedSnapshots @@ -430,10 +429,8 @@ getRecommendedSnapshots snapshots = do ] data InitOpts = InitOpts - { ioMethod :: !Method + { useSolver :: Bool -- ^ Use solver - , useSolver :: Bool - -- ^ Preferred snapshots , omitPackages :: Bool -- ^ Exclude conflicting or incompatible user packages , forceOverwrite :: Bool @@ -441,6 +438,3 @@ data InitOpts = InitOpts , includeSubDirs :: Bool -- ^ If True, include all .cabal files found in any sub directories } - --- | Method of initializing -data Method = MethodAutoSelect | MethodResolver AbstractResolver diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index a792a64d49..dc35707a7f 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -670,7 +670,7 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts initOptsParser :: Parser InitOpts initOptsParser = - InitOpts <$> method <*> solver <*> omitPackages + InitOpts <$> solver <*> omitPackages <*> overwrite <*> fmap not ignoreSubDirs where ignoreSubDirs = switch (long "ignore-subdirs" <> @@ -682,14 +682,6 @@ initOptsParser = solver = switch (long "solver" <> help "Use a dependency solver to determine extra dependencies") - method = (MethodResolver <$> resolver) - <|> (pure MethodAutoSelect) - - resolver = option readAbstractResolver - (long "resolver" <> - metavar "RESOLVER" <> - help "Use the specified resolver") - -- | Parser for a logging level. logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel) logLevelOptsParser hide defLogLevel = diff --git a/src/main/Main.hs b/src/main/Main.hs index d00a57e1e6..a7e57ffba8 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1183,15 +1183,14 @@ withMiniConfigAndLock go inner = initCmd :: InitOpts -> GlobalOpts -> IO () initCmd initOpts go = do pwd <- getWorkingDir - withMiniConfigAndLock go (initProject pwd initOpts) + withMiniConfigAndLock go (initProject pwd initOpts (globalResolver go)) -- | Create a project directory structure and initialize the stack config. newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO () newCmd (newOpts,initOpts) go@GlobalOpts{..} = do withMiniConfigAndLock go $ do dir <- new newOpts - initProject dir initOpts - + initProject dir initOpts globalResolver -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO () From b6e0cb416ad26079e56a1d67ebed32cada6a9aa9 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 18 Jan 2016 07:34:48 +0530 Subject: [PATCH 15/25] Use simpler syntax in pattern matching --- src/Stack/BuildPlan.hs | 30 +++++++++++++++--------------- src/Stack/Init.hs | 6 +++--- src/Stack/Solver.hs | 14 +++++++------- 3 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 006431bb80..e5c56a8da3 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -657,31 +657,31 @@ data BuildPlanCheck = -- Greater means a better plan instance Ord BuildPlanCheck where - (BuildPlanCheckPartial _ e1) `compare` (BuildPlanCheckPartial _ e2) = + BuildPlanCheckPartial _ e1 `compare` BuildPlanCheckPartial _ e2 = compare (Map.size e1) (Map.size e2) - (BuildPlanCheckFail _ e1 _) `compare` (BuildPlanCheckFail _ e2 _) = + BuildPlanCheckFail _ e1 _ `compare` BuildPlanCheckFail _ e2 _ = let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e)) in compare (numUserPkgs e1) (numUserPkgs e2) - (BuildPlanCheckOk _) `compare` (BuildPlanCheckOk _) = EQ - (BuildPlanCheckOk _) `compare` (BuildPlanCheckPartial _ _) = GT - (BuildPlanCheckOk _) `compare` (BuildPlanCheckFail _ _ _) = GT - (BuildPlanCheckPartial _ _) `compare` (BuildPlanCheckFail _ _ _) = GT + BuildPlanCheckOk {} `compare` BuildPlanCheckOk {} = EQ + BuildPlanCheckOk {} `compare` BuildPlanCheckPartial {} = GT + BuildPlanCheckOk {} `compare` BuildPlanCheckFail {} = GT + BuildPlanCheckPartial {} `compare` BuildPlanCheckFail {} = GT _ `compare` _ = LT instance Eq BuildPlanCheck where - (BuildPlanCheckOk _) == (BuildPlanCheckOk _) = True - (BuildPlanCheckPartial _ e1) == (BuildPlanCheckPartial _ e2) = - (Map.size e1) == (Map.size e2) - (BuildPlanCheckFail _ e1 _) == (BuildPlanCheckFail _ e2 _) = + BuildPlanCheckOk {} == BuildPlanCheckOk {} = True + BuildPlanCheckPartial _ e1 == BuildPlanCheckPartial _ e2 = + Map.size e1 == Map.size e2 + BuildPlanCheckFail _ e1 _ == BuildPlanCheckFail _ e2 _ = let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e)) in numUserPkgs e1 == numUserPkgs e2 _ == _ = False instance Show BuildPlanCheck where - show (BuildPlanCheckOk _) = "" + show BuildPlanCheckOk {} = "" show (BuildPlanCheckPartial f e) = T.unpack $ showDepErrors f e show (BuildPlanCheckFail f e c) = T.unpack $ showCompilerErrors f e c @@ -744,7 +744,7 @@ selectBestSnapshot gpds snaps = do reportResult result snap let new = (snap, result) case result of - BuildPlanCheckOk _ -> return new + BuildPlanCheckOk {} -> return new _ -> case bestYet of Nothing -> loop (Just new) rest Just old -> loop (Just (betterSnap old new)) rest @@ -753,15 +753,15 @@ selectBestSnapshot gpds snaps = do | r1 <= r2 = (s1, r1) | otherwise = (s2, r2) - reportResult (BuildPlanCheckOk _) snap = do + reportResult BuildPlanCheckOk {} snap = do $logInfo $ "* Matches " <> renderSnapName snap $logInfo "" - reportResult r@(BuildPlanCheckPartial _ _) snap = do + reportResult r@BuildPlanCheckPartial {} snap = do $logWarn $ "* Partially matches " <> renderSnapName snap $logWarn $ indent $ T.pack $ show r - reportResult r@(BuildPlanCheckFail _ _ _) snap = do + reportResult r@BuildPlanCheckFail {} snap = do $logWarn $ "* Rejected " <> renderSnapName snap $logWarn $ indent $ T.pack $ show r diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index e636dbb1ce..0ac1ac956d 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -283,7 +283,7 @@ getDefaultResolver stackYaml initOpts mresolver bundle = snaps <- getSnapshots' >>= getRecommendedSnapshots (s, r) <- selectBestSnapshot gpds snaps case r of - (BuildPlanCheckFail _ _ _) | not (omitPackages initOpts) + BuildPlanCheckFail {} | not (omitPackages initOpts) -> throwM (NoMatchingSnapshot snaps) _ -> return $ ResolverSnapshot s @@ -353,14 +353,14 @@ checkBundleResolver stackYaml initOpts bundle resolver = do result <- checkResolverSpec gpds Nothing resolver case result of BuildPlanCheckOk f -> return $ Right (f, Map.empty) - (BuildPlanCheckPartial f _) + BuildPlanCheckPartial f _ | needSolver resolver initOpts -> do $logWarn $ "*** Resolver " <> resolverName resolver <> " will need external packages: " $logWarn $ indent $ T.pack $ show result solve f | otherwise -> throwM $ ResolverPartial resolver (show result) - (BuildPlanCheckFail _ e _) + BuildPlanCheckFail _ e _ | (omitPackages initOpts) -> do $logWarn $ "*** Resolver compiler mismatch: " <> resolverName resolver diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 0b9e259b2e..9b01368b52 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -416,15 +416,15 @@ getResolverConstraints -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool)) getResolverConstraints stackYaml resolver - | (ResolverSnapshot snapName) <- resolver = do + | ResolverSnapshot snapName <- resolver = do mbp <- loadMiniBuildPlan snapName return (mbpCompilerVersion mbp, mbpConstraints mbp) - | (ResolverCustom _ url) <- resolver = do + | ResolverCustom _ url <- resolver = do -- FIXME instead of passing the stackYaml dir we should maintain -- the file URL in the custom resolver always relative to stackYaml. mbp <- parseCustomMiniBuildPlan stackYaml url return (mbpCompilerVersion mbp, mbpConstraints mbp) - | (ResolverCompiler compiler) <- resolver = + | ResolverCompiler compiler <- resolver = return (compiler, Map.empty) | otherwise = error "Not reached" where @@ -447,9 +447,9 @@ checkResolverSpec checkResolverSpec gpds flags resolver = do case resolver of ResolverSnapshot name -> checkSnapBuildPlan gpds flags name - ResolverCompiler _ -> return $ BuildPlanCheckPartial Map.empty Map.empty + ResolverCompiler {} -> return $ BuildPlanCheckPartial Map.empty Map.empty -- TODO support custom resolver for stack init - ResolverCustom _ _ -> return $ BuildPlanCheckPartial Map.empty Map.empty + ResolverCustom {} -> return $ BuildPlanCheckPartial Map.empty Map.empty findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File] findCabalFiles recurse dir = @@ -586,13 +586,13 @@ solveExtraDeps modStackYaml = do resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just ((mergeConstraints oldSrcs flags), Map.empty) - BuildPlanCheckPartial _ _ -> do + BuildPlanCheckPartial {} -> do eres <- solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, extraConstraints) -- TODO Solver should also use the init code to ignore incompatible -- packages return $ either (const Nothing) Just eres - (BuildPlanCheckFail _ _ _) -> + BuildPlanCheckFail {} -> throwM $ ResolverMismatch resolver (show resolverResult) (srcs, edeps) <- case resultSpecs of From 9bf8dcaeba2bddef31c1c2548bcddc882ddbaefd Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 01:26:35 +0530 Subject: [PATCH 16/25] init: fix duplicate package detection Detect duplicates based on the cabal package name instead of the file name. --- src/Stack/Solver.hs | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 9b01368b52..ed632033ec 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -23,8 +23,10 @@ import Control.Monad.Trans.Control import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarnings) import qualified Data.ByteString as S import Data.Either +import Data.Function (on) import qualified Data.HashMap.Strict as HashMap -import Data.List ((\\), isSuffixOf, intercalate) +import Data.List ( (\\), isSuffixOf, intercalate + , minimumBy) import Data.List.Extra (groupSortOn) import Data.Map (Map) import qualified Data.Map as Map @@ -489,30 +491,35 @@ cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do $logInfo $ "Using cabal packages:" $logInfo $ T.pack (formatGroup relpaths) - let dupTails = concat $ map tail (dupGroups cabalfps) - when (dupTails /= []) $ do - dups <- mapM (mapM makeRel) (dupGroups cabalfps) + (warnings, gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) + zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings + + let packages = zip cabalfps gpds + dupGroups = filter ((> 1) . length) + . groupSortOn (gpdPackageName . snd) + dupAll = concat $ dupGroups packages + + -- Among duplicates prefer to include the ones in upper level dirs + pathlen = length . FP.splitPath . toFilePath . fst + getmin = minimumBy (compare `on` pathlen) + dupSelected = map getmin (dupGroups packages) + dupIgnored = dupAll \\ dupSelected + unique = packages \\ dupIgnored + + when (dupIgnored /= []) $ do + dups <- mapM (mapM (makeRel . fst)) (dupGroups packages) $logWarn $ T.pack $ - "Following packages have duplicate names:\n" + "Following packages have duplicate package names:\n" <> intercalate "\n" (map formatGroup dups) - <> "\n" case dupErrMsg of Nothing -> $logWarn $ T.pack $ - "*** Only the first one among packages with \ - \duplicate names will be used." + "Packages with duplicate names will be ignored.\n" + <> "Packages in upper level directories will be preferred.\n" Just msg -> error msg - let uniquefps = cabalfps \\ dupTails - (warnings, gpds) <- fmap unzip (mapM readPackageUnresolved uniquefps) - zipWithM_ (mapM_ . printCabalFileWarning) uniquefps warnings return (Map.fromList - $ zipWith (\dir gpd -> ((gpdPackageName gpd),(dir, gpd))) - uniquefps gpds - , dupTails) - - where - dupGroups = filter ((> 1) . length) - . groupSortOn (FP.takeFileName . toFilePath) + $ map (\(file, gpd) -> ((gpdPackageName gpd),(file, gpd))) unique + , map fst dupIgnored) makeRel :: (MonadIO m) => Path Abs File -> m FilePath makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath From 1d2343c25b6f1c145be520ed177640f463e28c6f Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 02:17:00 +0530 Subject: [PATCH 17/25] init: error out if packages do not have a name If the cabal file does not have a name assigned to a package then display an error and exit. Otherwise empty names will cause strange errors later on. Also added code to dislay cabal error output when we cannot parse it. --- src/Stack/Solver.hs | 52 +++++++++++++++++++++++++++------------------ 1 file changed, 31 insertions(+), 21 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index ed632033ec..45d481076b 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -30,7 +30,7 @@ import Data.List ( (\\), isSuffixOf, intercalate import Data.List.Extra (groupSortOn) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes, isNothing) +import Data.Maybe (catMaybes, isNothing, mapMaybe) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set @@ -116,43 +116,43 @@ cabalSolver menv cabalfps constraintType >>= either parseCabalErrors parseCabalOutput where - errCheck = LT.isInfixOf "Could not resolve dependencies" + errCheck = T.isInfixOf "Could not resolve dependencies" parseCabalErrors err = do - let errExit = error "Could not parse cabal-install errors" - msg = decodeUtf8With lenientDecode err + let errExit e = error $ "Could not parse cabal-install errors:\n" + ++ (T.unpack e) + msg = LT.toStrict $ decodeUtf8With lenientDecode err if errCheck msg then do $logInfo "Attempt failed." $logInfo "\n>>>> Cabal errors begin" - $logInfo $ LT.toStrict msg - <> "<<<< Cabal errors end\n" - $logInfo $ "User packages involved in cabal failure: " - <> (LT.toStrict $ LT.intercalate ", " - $ parseConflictingPkgs msg) + $logInfo $ msg <> "<<<< Cabal errors end\n" let pkgs = parseConflictingPkgs msg - mPkgNames = map (C.simpleParse . T.unpack . LT.toStrict) pkgs + mPkgNames = map (C.simpleParse . T.unpack) pkgs pkgNames = map (fromCabalPackageName . C.pkgName) (catMaybes mPkgNames) - when (any isNothing mPkgNames) $ + when (any isNothing mPkgNames) $ do $logInfo $ "*** Only some package names could be parsed: " <> (T.pack (intercalate ", " (map show pkgNames))) + error $ T.unpack $ + "*** User packages involved in cabal failure: " + <> (T.intercalate ", " $ parseConflictingPkgs msg) if pkgNames /= [] then do return $ Left pkgNames - else errExit - else errExit + else errExit msg + else errExit msg parseConflictingPkgs msg = - let ls = dropWhile (not . errCheck) $ LT.lines msg - select s = ((LT.isPrefixOf "trying:" s) - || (LT.isPrefixOf "next goal:" s)) - && (LT.isSuffixOf "(user goal)" s) + let ls = dropWhile (not . errCheck) $ T.lines msg + select s = ((T.isPrefixOf "trying:" s) + || (T.isPrefixOf "next goal:" s)) + && (T.isSuffixOf "(user goal)" s) pkgName = (take 1) - . LT.words - . (LT.drop 1) - . (LT.dropWhile (/= ':')) + . T.words + . (T.drop 1) + . (T.dropWhile (/= ':')) in concat $ map pkgName (filter select ls) parseCabalOutput bs = do @@ -495,7 +495,17 @@ cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings let packages = zip cabalfps gpds - dupGroups = filter ((> 1) . length) + getEmptyNamePkg (fp, gpd) + | ((show . gpdPackageName) gpd) == "" = Just fp + | otherwise = Nothing + emptyNamePkgs = mapMaybe getEmptyNamePkg packages + + when (emptyNamePkgs /= []) $ do + rels <- mapM makeRel emptyNamePkgs + error $ "Please assign a name to the following package(s):\n" + <> (formatGroup rels) + + let dupGroups = filter ((> 1) . length) . groupSortOn (gpdPackageName . snd) dupAll = concat $ dupGroups packages From 0c14ec49e461d33f762c22e33255a7e6bbf2785c Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 02:22:49 +0530 Subject: [PATCH 18/25] Solver: choose to reject packages in deeper dirs Packages in upper level directories are likely to be more important and therefore try to pick those when there is a conflict in packages. --- src/Stack/Init.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 0ac1ac956d..55a7ad5392 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -18,10 +18,11 @@ import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as BC +import Data.Function (on) import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F -import Data.List (intersect) +import Data.List (intersect, maximumBy) import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map @@ -42,6 +43,7 @@ import Stack.Types.Internal ( HasTerminal, HasReExec import System.Directory (makeRelativeToCurrentDirectory) import Stack.Config ( getSnapshots , makeConcreteResolver) +import qualified System.FilePath as FP -- | Generate stack.yaml initProject @@ -135,7 +137,7 @@ initProject currDir initOpts mresolver = do indent t = T.unlines $ fmap (" " <>) (T.lines t) $logInfo $ "Initialising configuration using resolver: " <> resolverName r - $logInfo $ "Total number of packages considered: " + $logInfo $ "Total number of user packages considered: " <> (T.pack $ show $ (Map.size bundle + length dupPkgs)) when (dupPkgs /= []) $ do @@ -400,7 +402,13 @@ checkBundleResolver stackYaml initOpts bundle resolver = do (getFlags pkg) allDeps = concat $ map (Map.keys . deps) packages isIndependent pkg = not $ pkg `elem` allDeps - return $ head (filter isIndependent packages) + + -- prefer to reject packages in deeper directories + path pkg = fst (fromJust (Map.lookup pkg bundle)) + pathlen = length . FP.splitPath . toFilePath . path + maxPathlen = maximumBy (compare `on` pathlen) + + return $ maxPathlen (filter isIndependent packages) giveUpMsg = concat [ " - Use '--omit-packages to exclude conflicting package(s).\n" From 8a415d1223682b73c196acf126e99ab46d63be44 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 07:27:12 +0530 Subject: [PATCH 19/25] Update stack init documentation in the user guide Lot of things changed with the recent changes in stack init. --- doc/GUIDE.md | 292 ++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 205 insertions(+), 87 deletions(-) diff --git a/doc/GUIDE.md b/doc/GUIDE.md index d460ed06c1..336ca36f07 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -630,146 +630,265 @@ using [Yesod](http://www.yesodweb.com/). To get the code, we'll use the `stack unpack` command: ``` -michael@d30748af6d3d:~$ stack unpack yackage-0.8.0 -yackage-0.8.0: download -Unpacked yackage-0.8.0 to /home/michael/yackage-0.8.0/ -michael@d30748af6d3d:~$ cd yackage-0.8.0/ +cueball:~$ stack unpack yackage-0.8.0 +Unpacked yackage-0.8.0 to /var/home/harendra/yackage-0.8.0/ +cueball:~$ cd yackage-0.8.0/ ``` +### stack init This new directory does not have a stack.yaml file, so we need to make one first. We could do it by hand, but let's be lazy instead with the `stack init` command: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack init -Writing default config file to: /home/michael/yackage-0.8.0/stack.yaml -Basing on cabal files: -- /home/michael/yackage-0.8.0/yackage.cabal +cueball:~/yackage-0.8.0$ stack init +Using cabal packages: +- yackage.cabal -Checking against build plan lts-3.2 -Selected resolver: lts-3.2 -Wrote project config to: /home/michael/yackage-0.8.0/stack.yaml -michael@d30748af6d3d:~/yackage-0.8.0$ cat stack.yaml -flags: - yackage: - upload: true -packages: -- '.' -extra-deps: [] -resolver: lts-3.2 +Selecting the best among 6 snapshots... + +* Matches lts-4.1 + +Selected resolver: lts-4.1 +Initialising configuration using resolver: lts-4.1 +Total number of user packages considered: 1 +Writing configuration to file: stack.yaml +All done. ``` stack init does quite a few things for you behind the scenes: -* Creates a list of snapshots that would be good candidates. - * The basic algorithm here is to prefer options in this order: - * Snapshots for which you've already built some packages (to - increase sharing of binary package databases, as we'll discuss later) - * Recent snapshots - * LTS - * These preferences can be tweaked with command line flags (see `stack init - --help`). * Finds all of the .cabal files in your current directory and subdirectories (unless you use `--ignore-subdirs`) and determines the packages and versions they require -* Finds a combination of snapshot and package flags that allows everything to - compile +* Finds the best combination of snapshot and package flags that allows everything to + compile with minimum external dependencies +* It tries to look for the best matching snapshot from latest LTS, latest + nightly, other LTS versions in that order Assuming it finds a match, it will write your stack.yaml file, and everything -will work. Given that LTS Haskell and Stackage Nightly have ~1400 of the most -common Haskell packages, this will often be enough. However, let's simulate a -failure by adding acme-missiles to our build-depends and re-initing: +will work. + +#### External Dependencies + +Given that LTS Haskell and Stackage Nightly have ~1400 of the most common +Haskell packages, this will often be enough to build most packages. However, +at times, you may find that not all dependencies required may be available in +the stackage snapshots. + +Let's simulate an unsatisfied dependency by adding acme-missiles to our +build-depends and re-initing: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack init --force -Writing default config file to: /home/michael/yackage-0.8.0/stack.yaml -Basing on cabal files: -- /home/michael/yackage-0.8.0/yackage.cabal +cueball:~/yackage-0.8.0$ stack init --force +Using cabal packages: +- yackage.cabal -Checking against build plan lts-3.2 +Selecting the best among 6 snapshots... -* Build plan did not match your requirements: +* Partially matches lts-4.1 acme-missiles not found - - yackage requires -any + - yackage requires -any + - yackage flags: upload = True -Checking against build plan lts-3.1 - -* Build plan did not match your requirements: +* Partially matches nightly-2016-01-16 acme-missiles not found - - yackage requires -any + - yackage requires -any + - yackage flags: upload = True +* Partially matches lts-3.22 + acme-missiles not found + - yackage requires -any + - yackage flags: upload = True -Checking against build plan nightly-2015-08-26 +. +. +. -* Build plan did not match your requirements: +Selected resolver: lts-4.1 +Resolver 'lts-4.1' does not have all the packages to match your requirements. acme-missiles not found - - yackage requires -any + - yackage requires -any + - yackage flags: upload = True +However, you can try '--solver' to use external packages. +``` -Checking against build plan lts-2.22 +stack has tested six different snapshots, and in every case discovered that +acme-missiles is not available. In the end it suggested that you use the +`--solver` command line switch if you want to use packages outside stackage. So +let's give it a try: -* Build plan did not match your requirements: - acme-missiles not found - - yackage requires -any - warp version 3.0.13.1 found - - yackage requires >=3.1 +``` +cueball:~/yackage-0.8.0$ stack init --force --solver +Using cabal packages: +- yackage.cabal + +Selecting the best among 6 snapshots... +* Partially matches lts-4.1 + acme-missiles not found + - yackage requires -any + - yackage flags: upload = True -There was no snapshot found that matched the package bounds in your .cabal files. -Please choose one of the following commands to get started. +. +. +. - stack init --resolver lts-3.2 - stack init --resolver lts-3.1 - stack init --resolver nightly-2015-08-26 - stack init --resolver lts-2.22 +Selected resolver: lts-4.1 +*** Resolver lts-4.1 will need external packages: + acme-missiles not found + - yackage requires -any + - yackage flags: upload = True -You'll then need to add some extra-deps. See the -[stack.yaml documentation](yaml_configuration.html#extra-deps). +Using resolver: lts-4.1 +Using compiler: ghc-7.10.3 +Asking cabal to calculate a build plan... +Trying with packages from lts-4.1 as hard constraints... +Successfully determined a build plan with 3 external dependencies. +Initialising configuration using resolver: lts-4.1 +Total number of user packages considered: 1 +Warning! 3 external dependencies were added. +Overwriting existing configuration file: stack.yaml +All done. +``` -You can also try falling back to a dependency solver with: +As you can verify by viewing stack.yaml, three external dependencies were added +by stack init: - stack init --solver ``` +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: +- acme-missiles-0.3 +- text-1.2.2.0 +- yaml-0.8.15.2 +``` + +Of course, you could have added the external dependencies by manually editing +stack.yaml but stack init does the hard work for you. + +#### Excluded Packages -stack has tested four different snapshots, and in every case discovered that -acme-missiles is not available. Also, when testing lts-2.22, it found that the -warp version provided was too old for yackage. So, what do we do? +Sometimes multiple packages in your project may have conflicting requirements. +In that case `stack init` will fail, so what do you do? -The recommended approach is: pick a resolver, and fix the problem. Again, -following the advice mentioned above, default to LTS if you don't have a -preference. In this case, the newest LTS listed is lts-3.2. Let's pick that. -stack has told us the correct command to do this. We'll just remove our old -stack.yaml first and then run it: +You could manually create stack.yaml by omitting some packages to resolve the +conflict. Alternatively you can ask `stack init` to do that for you by +specifying `--omit-packages` flag on the command line. Let's see how that +works. + +To simulate a conflict we will use acme-missiles-0.3 in yackage and we will +also copy yackage.cabal to another directory and change the name of the file +and package to yackage-test. In this new package we will use acme-missiles-0.2 +instead. Let's see what happens when we run solver: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ rm stack.yaml -michael@d30748af6d3d:~/yackage-0.8.0$ stack init --resolver lts-3.2 -Writing default config file to: /home/michael/yackage-0.8.0/stack.yaml -Basing on cabal files: -- /home/michael/yackage-0.8.0/yackage.cabal +cueball:~/yackage-0.8.0$ stack init --force --solver --omit-packages +Using cabal packages: +- yackage.cabal +- example/yackage-test.cabal -Checking against build plan lts-3.2 +Selecting the best among 6 snapshots... -* Build plan did not match your requirements: +* Partially matches lts-4.2 + acme-missiles not found + - yackage requires ==0.3 + - yackage-test requires ==0.2 + - yackage flags: upload = True + - yackage-test flags: upload = True +. +. +. + +*** Failed to arrive at a workable build plan. +*** Ignoring package: yackage-test +*** Resolver lts-4.2 will need external packages: acme-missiles not found - - yackage requires -any + - yackage requires ==0.3 + - yackage flags: upload = True +Using resolver: lts-4.2 +Using compiler: ghc-7.10.3 +Asking cabal to calculate a build plan... +Trying with packages from lts-4.2 as hard constraints... +Successfully determined a build plan with 3 external dependencies. +Initialising configuration using resolver: lts-4.2 +Total number of user packages considered: 2 +Warning! Ignoring 1 packages due to dependency conflicts: + - "example/yackage-test.cabal" -Selected resolver: lts-3.2 -Wrote project config to: /home/michael/yackage-0.8.0/stack.yaml +Warning! 3 external dependencies were added. +Overwriting existing configuration file: stack.yaml +All done. ``` -As you may guess, `stack build` will now fail due to the missing acme-missiles. -Toward the end of the error message, it says the familiar: +Looking at `stack.yaml`, you will see that the excluded packages have been +commented out: ``` -Recommended action: try adding the following to your extra-deps in /home/michael/yackage-0.8.0/stack.yaml -- acme-missiles-0.3 +# Local packages, usually specified by relative directory name +packages: +- '.' +# The following packages have been ignored due to incompatibility with the resolver compiler or dependency conflicts with other packages +#- example/ +``` + +In case wrong packages are excluded you can uncomment the right one and comment +the other one. + +Packages may get excluded due to confilcting requirements among user packages +or due to conflicting requiements between a user package and the resolver +compiler. If all of the packages have a conflict with the compiler then all of +them may get commented out. + +When packages are commented out you will see a warning every time you run a +command which needs the config file. The warning can be disabled by editing the +config file and removing it. + +#### Using a specific resolver + +Sometimes you may want to use a specific resolver for your project instead of +`stack init` picking one for you. You can do that by using `stack init +--resolver `. + +You can also init with a compiler resolver if you do not want to use a +snapshot. That will result in all of your project's dependencies being put +under the `extra-deps` section. + +#### Miscellaneous and diagnostics + +_Duplicate package names_: If multiple packages under the directory tree have +same name, stack init will report those and automatically ignore one of them. + +_Ignore subdirectories_: By default stack init searches all the subdirectories +for .cabal files. If you do not want that then you can use `--ignore-subdirs` +command line switch. + +_Cabal warnings_: stack init will show warnings if there were issues in reading +a cabal package file. You may want to pay attention to the warnings as +sometimes they may result in incomprehensible errors later on during dependency +solving. + +_Packages with no names_: If the `Name` field in a cabal file is empty or not +present then stack init will refuse to continue. + +_Cabal install errors_: stack init uses `cabal-install` to determine external +dependencies. When cabal-install encounters errors, cabal errors are displayed +as is by stack init for diagnostics. + +_User warnings_: When packages are excluded or external dependencies added +stack will show warnings every time configuration file is loaded. You can +suppress the warnings by editing the config file and removing the warnings from +it. You may see something like this: + ``` +cueball:~/yackage-0.8.0$ stack build +Warning: Some packages were found to be incompatible with the resolver and have been left commented out in the packages section. +Warning: Specified resolver could not satisfy all dependencies. Some external packages have been added as dependencies. +You can suppress this message by removing it from stack.yaml -If you're following along at home, try making the necessary stack.yaml -modification to get things building. +``` ### Alternative solution: dependency solving @@ -848,7 +967,6 @@ Asking cabal to calculate a build plan, please wait Selected resolver: ghc-7.10 Wrote project config to: /home/michael/yackage-0.8.0/stack.yaml ``` - ## Different databases Time to take a short break from hands-on examples and discuss a little From b4f8fc4e7e7279754f93a74cdeedd6959471a59d Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 07:46:26 +0530 Subject: [PATCH 20/25] Update stack solver user guide doc --- doc/GUIDE.md | 194 +++++++++++++++++++++++++++++++++++---------------- 1 file changed, 133 insertions(+), 61 deletions(-) diff --git a/doc/GUIDE.md b/doc/GUIDE.md index 336ca36f07..8e86acd592 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -674,7 +674,7 @@ will work. Given that LTS Haskell and Stackage Nightly have ~1400 of the most common Haskell packages, this will often be enough to build most packages. However, at times, you may find that not all dependencies required may be available in -the stackage snapshots. +the Stackage snapshots. Let's simulate an unsatisfied dependency by adding acme-missiles to our build-depends and re-initing: @@ -716,7 +716,7 @@ However, you can try '--solver' to use external packages. stack has tested six different snapshots, and in every case discovered that acme-missiles is not available. In the end it suggested that you use the -`--solver` command line switch if you want to use packages outside stackage. So +`--solver` command line switch if you want to use packages outside Stackage. So let's give it a try: @@ -837,8 +837,8 @@ packages: In case wrong packages are excluded you can uncomment the right one and comment the other one. -Packages may get excluded due to confilcting requirements among user packages -or due to conflicting requiements between a user package and the resolver +Packages may get excluded due to conflicting requirements among user packages +or due to conflicting requirements between a user package and the resolver compiler. If all of the packages have a conflict with the compiler then all of them may get commented out. @@ -889,84 +889,156 @@ Warning: Specified resolver could not satisfy all dependencies. Some external pa You can suppress this message by removing it from stack.yaml ``` +### stack solver -### Alternative solution: dependency solving +While `stack init` is used to create stack configuration file from existing +cabal files, `stack solver` can be used to fine tune or fix an existing stack +configuration file. -There's another solution to consider for missing dependencies. At the end -of the previous error message, it said: +`stack solver` uses the existing file as a constraint. For example it will +use only those packages specified in the existing config file or use existing +external dependencies as constraints to figure out other dependencies. + +Let's try `stack solver` to verify the config that we generated earlier with +`stack init`: ``` -You may also want to try the 'stack solver' command -``` +cueball:~/yackage-0.8.0$ stack solver +Using configuration file: stack.yaml +The following packages are missing from the config: +- example/yackage-test.cabal -This approach uses a full-blown dependency solver to look at all upstream -package versions available and compare them to your snapshot selection and -version ranges in your .cabal file. In order to use this feature, you'll need -the cabal executable available. Let's build that with: +Using cabal packages: +- yackage.cabal -``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack build cabal-install -random-1.1: download -mtl-2.2.1: download -network-2.6.2.1: download -old-locale-1.0.0.7: download -random-1.1: configure -random-1.1: build -# ... -cabal-install-1.22.6.0: download -cabal-install-1.22.6.0: configure -cabal-install-1.22.6.0: build -cabal-install-1.22.6.0: install -Completed all 10 actions. +Using resolver: lts-4.2 +Using compiler: ghc-7.10.3 +Asking cabal to calculate a build plan... +Trying with packages from lts-4.2 and 3 external packages as hard constraints... +Successfully determined a build plan with 3 external dependencies. +No changes needed to stack.yaml ``` -Now we can use `stack solver`: +It says there are no changes needed to your config. Notice that it also reports +`example/yackage-test.cabal` as missing from the config. It was purposely +omitted by `stack init` to resolve a conflict. -``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack solver -This command is not guaranteed to give you a perfect build plan -It's possible that even with the changes generated below, you will still need to do some manual tweaking -Asking cabal to calculate a build plan, please wait -extra-deps: -- acme-missiles-0.3 -``` +Sometimes `stack init` may not be able to give you a perfect configuration. In +that case, you can tweak the configuration file as per your requirements and then +run `stack solver`, it will check the file and suggest or apply any fixes +needed. -And if we're exceptionally lazy, we can ask stack to modify our stack.yaml file -for us: +For example, if `stack init` ignored certain packages due to name conflicts or +dependency conflicts, the choice that `stack init` made may not be the correct +one. In that case you can revert the choice and use solver to fix things. + +Let's try commenting out `.` and uncommenting `examples/` in our previously +generated `stack.yaml` and then run `stack solver`: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack solver --modify-stack-yaml -This command is not guaranteed to give you a perfect build plan -It's possible that even with the changes generated below, you will still need to do some manual tweaking -Asking cabal to calculate a build plan, please wait -extra-deps: -- acme-missiles-0.3 -Updated /home/michael/yackage-0.8.0/stack.yaml +cueball:~/yackage-0.8.0$ stack solver + +Using configuration file: stack.yaml +The following packages are missing from the config: +- yackage.cabal + +Using cabal packages: +- example/yackage-test.cabal + +. +. +. + +Retrying with packages from lts-4.2 and 3 external packages as preferences... +Successfully determined a build plan with 5 external dependencies. + +The following changes will be made to stack.yaml: +* Resolver is lts-4.2 +* Dependencies to be added + extra-deps: + - acme-missiles-0.2 + - email-validate-2.2.0 + - tar-0.5.0.1 + +* Dependencies to be deleted + extra-deps: + - acme-missiles-0.3 + +To automatically update stack.yaml, rerun with '--update-config' ``` -With that change, `stack build` will now run. +Due to the change that we made, solver suggested some new dependencies. +By default it does not make changes to the config. As it suggested you can use +`--update-config` to make changes to the config. NOTE: You should probably back up your stack.yaml before doing this, such as committing to Git/Mercurial/Darcs. -There's one final approach to mention: skipping the snapshot entirely and just -using dependency solving. You can do this with the `--solver` flag to `init`. -This is not a commonly used workflow with stack, as you end up with a large -number of extra-deps and no guarantee that the packages will compile together. -For those interested, however, the option is available. You need to make sure -you have both the ghc and cabal commands on your PATH. An easy way to do this -is to use the `stack exec` command: +Sometimes, you may want to use specific versions of certain packages for your +project. To do that you can fix those versions by specifying them in the +extra-deps section and then use `stack solver` to figure out whether it is +feasible to use those or what other dependencies are needed as a result. -``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack exec -- stack init --solver --force -Writing default config file to: /home/michael/yackage-0.8.0/stack.yaml -Basing on cabal files: -- /home/michael/yackage-0.8.0/yackage.cabal +If you want to change the resolver for your project, you can run `stack solver +--resolver ` and it will figure out the changes needed for you. + +Let's see what happens if we change the resolver to lts-2.22: -Asking cabal to calculate a build plan, please wait -Selected resolver: ghc-7.10 -Wrote project config to: /home/michael/yackage-0.8.0/stack.yaml ``` +cueball:~/yackage-0.8.0$ stack solver --resolver lts-2.22 +Using configuration file: stack.yaml +The following packages are missing from the config: +- yackage.cabal + +Using cabal packages: +- example/yackage-test.cabal + +Using resolver: lts-2.22 +Using compiler: ghc-7.8.4 + +. +. +. + +Retrying with packages from lts-2.22 and 3 external packages as preferences... +Successfully determined a build plan with 19 external dependencies. + +The following changes will be made to stack.yaml: +* Resolver is lts-2.22 +* Flags to be added + flags: + - old-locale: true + +* Dependencies to be added + extra-deps: + - acme-missiles-0.2 + - aeson-0.10.0.0 + - aeson-compat-0.3.0.0 + - attoparsec-0.13.0.1 + - conduit-extra-1.1.9.2 + - email-validate-2.2.0 + - hex-0.1.2 + - http-api-data-0.2.2 + - http2-1.1.0 + - persistent-2.2.4 + - persistent-template-2.1.5 + - primitive-0.6.1.0 + - tar-0.5.0.1 + - unix-time-0.3.6 + - vector-0.11.0.0 + - wai-extra-3.0.14 + - warp-3.1.3.1 + +* Dependencies to be deleted + extra-deps: + - acme-missiles-0.3 + +To automatically update stack.yaml, rerun with '--update-config' +``` + +As you can see, it automatically suggested changes in `extra-deps` due to the +change of resolver. + ## Different databases Time to take a short break from hands-on examples and discuss a little From ddd39608999ac25ab59e6613af735cf86911297c Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 07:49:09 +0530 Subject: [PATCH 21/25] Add user-message in yaml configuration user doc --- doc/yaml_configuration.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 4c8659d9a9..72ec1df390 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -128,6 +128,28 @@ You can also specify `entrypoints`. By default all your executables are placed in `/usr/local/bin`, but you can specify a list using `executables` to only add some. +### user-message + +A user-message is inserted by `stack init` when it omits packages or adds +external dependencies. For example: + +```yaml +user-message: ! 'Warning: Some packages were found to be incompatible with the resolver + and have been left commented out in the packages section. + + Warning: Specified resolver could not satisfy all dependencies. Some external packages + have been added as dependencies. + + You can suppress this message by removing it from stack.yaml + +' +``` + +This messages is displayed every time the config is loaded by stack and serves +as a reminder for the user to review the configuration and make any changes if +needed. The user can delete this message if the generated configuration is +acceptable. + ## Non-project config Non-project config options may go in the global config (`/etc/stack/config.yaml`) or the user config (`~/.stack/config.yaml`). From 0149ba5803f4ca641424562157230effa8684b82 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 08:23:01 +0530 Subject: [PATCH 22/25] Add --install-ghc in stack init doc guide --- doc/GUIDE.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/GUIDE.md b/doc/GUIDE.md index 8e86acd592..2f5e453ae4 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -856,6 +856,11 @@ You can also init with a compiler resolver if you do not want to use a snapshot. That will result in all of your project's dependencies being put under the `extra-deps` section. +#### Installing the compiler + +You can install the required compiler if not already installed by using the +`--install-ghc` flag with the `stack init` command. + #### Miscellaneous and diagnostics _Duplicate package names_: If multiple packages under the directory tree have From 63c7f48f6b6e7387e7ffedf5bd480114d37aff2e Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 09:30:05 +0530 Subject: [PATCH 23/25] init: check pkg name and .cabal file name match Since stack does not allow package name to mismatch with the .cabal file name stack init should also not allow that. This commit disallows the mismatch. --- src/Stack/Solver.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 45d481076b..35b76fd479 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -494,15 +494,23 @@ cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do (warnings, gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings + -- package name cannot be empty or missing otherwise + -- it will result in cabal solver failure. + -- stack requires packages name to match the cabal file name + -- Just the latter check is enough to cover both the cases + let packages = zip cabalfps gpds - getEmptyNamePkg (fp, gpd) - | ((show . gpdPackageName) gpd) == "" = Just fp + getNameMismatchPkg (fp, gpd) + | (show . gpdPackageName) gpd /= (FP.takeBaseName . toFilePath) fp + = Just fp | otherwise = Nothing - emptyNamePkgs = mapMaybe getEmptyNamePkg packages + nameMismatchPkgs = mapMaybe getNameMismatchPkg packages - when (emptyNamePkgs /= []) $ do - rels <- mapM makeRel emptyNamePkgs - error $ "Please assign a name to the following package(s):\n" + when (nameMismatchPkgs /= []) $ do + rels <- mapM makeRel nameMismatchPkgs + error $ "Package name as defined in the .cabal file must match the \ + \.cabal file name.\n\ + \Please fix the following packages and try again:\n" <> (formatGroup rels) let dupGroups = filter ((> 1) . length) From da82ce9f538ee540056004bb5cb0156c5d4d0373 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 10:00:15 +0530 Subject: [PATCH 24/25] init: allow global --resolver in subcommand Now that there is no local --resolver option for stack init we can allow the global option to be used in subcommand context. This was disabled by the fix for #1531. I have reverted the init specific fix for that but kept the overall mechanism for any future use. --- src/Stack/Options.hs | 11 +++++------ src/main/Main.hs | 4 +--- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index dc35707a7f..d272cc8adc 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -68,9 +68,12 @@ data BuildCommand deriving (Eq) -- | Allows adjust global options depending on their context +-- Note: This was being used to remove ambibuity between the local and global +-- implementation of stack init --resolver option. Now that stack init has no +-- local --resolver this is not being used anymore but the code is kept for any +-- similar future use cases. data GlobalOptsContext = OuterGlobalOpts -- ^ Global options before subcommand name - | InitCmdGlobalOpts -- ^ Global options following 'stack init' | OtherCmdGlobalOpts -- ^ Global options following any other subcommand deriving (Show, Eq) @@ -637,11 +640,7 @@ globalOptsParser kind defLogLevel = optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*> logLevelOptsParser hide0 defLogLevel <*> configOptsParser hide0 <*> - (if kind == InitCmdGlobalOpts - -- The 'stack init' command has its own '--resolver' option, and having a global - -- one causes ambiguity, so disable it. - then pure Nothing - else optional (abstractResolverOptsParser hide0)) <*> + optional (abstractResolverOptsParser hide0) <*> optional (compilerOptsParser hide0) <*> maybeBoolFlags "terminal" diff --git a/src/main/Main.hs b/src/main/Main.hs index a7e57ffba8..010100853f 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -235,11 +235,9 @@ commandLineHandler progName isInterpreter = complicatedOptions "List the templates available for `stack new'." templatesCmd (pure ()) - addCommand "init" + addCommand' "init" "Initialize a stack project based on one or more cabal packages" - globalFooter initCmd - (globalOpts InitCmdGlobalOpts) initOptsParser addCommand' "solver" "Use a dependency solver to try and determine missing extra-deps" From 4842d8895c2130c5621fe402004690aae020ab0d Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 19 Jan 2016 11:36:04 +0530 Subject: [PATCH 25/25] Add and fix haddocks for stack init and solver --- src/Stack/Init.hs | 4 ++-- src/Stack/Solver.hs | 46 +++++++++++++++++++++++++++++++++------------ 2 files changed, 36 insertions(+), 14 deletions(-) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 55a7ad5392..e8c69ccced 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -438,11 +438,11 @@ getRecommendedSnapshots snapshots = do data InitOpts = InitOpts { useSolver :: Bool - -- ^ Use solver + -- ^ Use solver to determine required external dependencies , omitPackages :: Bool -- ^ Exclude conflicting or incompatible user packages , forceOverwrite :: Bool - -- ^ Overwrite existing files + -- ^ Overwrite existing stack.yaml , includeSubDirs :: Bool -- ^ If True, include all .cabal files found in any sub directories } diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 35b76fd479..eb383d0bd9 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -310,6 +310,9 @@ setupCabalEnv compiler = do \This is most likely a bug." return menv +-- | Merge two separate maps, one defining constraints on package versions and +-- the other defining package flagmap, into a single map of version and flagmap +-- tuples. mergeConstraints :: Map PackageName v -> Map PackageName (Map p f) @@ -331,6 +334,17 @@ diffConstraints (v, f) (v', f') | (v == v') && (f == f') = Nothing | otherwise = Just (v, f) +-- | Given a resolver, user package constraints (versions and flags) and extra +-- dependency constraints determine what extra dependencies are required +-- outside the resolver snapshot and the specified extra dependencies. + +-- First it tries by using the snapshot and the input extra dependencies +-- as hard constraints, if no solution is arrived at by using hard +-- constraints it then tries using them as soft constraints or preferences. + +-- It returns either conflicting packages when no solution is arrived at +-- or the solution in terms of src package flag settings and extra +-- dependencies. solveResolverSpec :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasGHCVariant env @@ -408,6 +422,9 @@ solveResolverSpec stackYaml cabalDirs $logInfo $ "*** Failed to arrive at a workable build plan." return $ Left x +-- | Given a resolver (snpashot, compiler or custom resolver) +-- return the compiler version, package versions and packages flags +-- for that resolver. getResolverConstraints :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasGHCVariant env @@ -433,11 +450,12 @@ getResolverConstraints stackYaml resolver mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi) mbpConstraints mbp = fmap mpiConstraints (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. +-- | Given a bundle of user packages, flag constraints on those packages and a +-- resolver, determine if the resolver fully, partially or fails to satisfy the +-- dependencies of the user packages. +-- If the package flags are passed as 'Nothing' then flags are chosen +-- automatically. checkResolverSpec :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env @@ -453,6 +471,8 @@ checkResolverSpec gpds flags resolver = do -- TODO support custom resolver for stack init ResolverCustom {} -> return $ BuildPlanCheckPartial Map.empty Map.empty +-- | Finds all files with a .cabal extension under a given directory. +-- Subdirectories can be included depending on the @recurse@ parameter. findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File] findCabalFiles recurse dir = liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir)) @@ -470,9 +490,13 @@ 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. +-- | Perform some basic checks on a list of cabal files to be used for creating +-- stack config. It checks for duplicate package names, package name and +-- cabal file name mismatch and reports any issues related to those. + +-- If no error occurs it returns filepath and @GenericPackageDescription@s +-- pairs as well as any filenames for duplicate packages not included in the +-- pairs. cabalPackagesCheck :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasGHCVariant env @@ -556,17 +580,15 @@ reportMissingCabalFiles cabalfps includeSubdirs = 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 --- 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. +-- | Verify the combination of resolver, package flags and extra +-- dependencies in an existing stack.yaml and suggest changes in flags or +-- extra dependencies so that the specified packages can be compiled. solveExtraDeps :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasEnvConfig env, HasGHCVariant env