diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -240,7 +240,7 @@ [ PackageConstraintInstalled pkgname | all (/=PackageName "base") (depResolverTargets params) , pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp" - , "integer-simple", "template-haskell" ] + , "integer-simple" ] , isInstalled pkgname ] -- TODO: the top down resolver chokes on the base constraints -- below when there are no targets and thus no dep on base. diff --git a/Distribution/Client/Dependency/Modular/Builder.hs b/Distribution/Client/Dependency/Modular/Builder.hs --- a/Distribution/Client/Dependency/Modular/Builder.hs +++ b/Distribution/Client/Dependency/Modular/Builder.hs @@ -78,17 +78,21 @@ qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals gs = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps) - -- IMPORTANT AND SUBTLE: The order of the concatenation above is - -- important. Flags occur potentially multiple times: both via the - -- flag declaration ('qfdefs') and via dependencies ('qfdeps'). - -- We want the information from qfdeps if it's present, because that - -- includes dependencies between flags. We use qfdefs mainly so that - -- we are forced to make choices for flags that don't affect - -- dependencies at all. + -- NOTE: -- - -- When goals are actually extended in 'extendOpen', later additions - -- override earlier additions, so it's important that the - -- lower-quality templates without dependency information come first. + -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially + -- multiple times, both via the flag declaration and via dependencies. + -- The order is potentially important, because the occurrences via + -- dependencies may record flag-dependency information. After a number + -- of bugs involving computing this information incorrectly, however, + -- we're currently not using carefully computed inter-flag dependencies + -- anymore, but instead use 'simplifyVar' when computing conflict sets + -- to map all flags of one package to a single flag for conflict set + -- purposes, thereby treating them all as interdependent. + -- + -- If we ever move to a more clever algorithm again, then the line above + -- needs to be looked at very carefully, and probably be replaced by + -- more systematically computed flag dependency information. -- | Datatype that encodes what to build next data BuildType = diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs --- a/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/Distribution/Client/Dependency/Modular/Dependency.hs @@ -21,6 +21,16 @@ data Var qpn = P qpn | F (FN qpn) | S (SN qpn) deriving (Eq, Ord, Show) +-- | For computing conflict sets, we map flag choice vars to a +-- single flag choice. This means that all flag choices are treated +-- as interdependent. So if one flag of a package ends up in a +-- conflict set, then all flags are being treated as being part of +-- the conflict set. +simplifyVar :: Var qpn -> Var qpn +simplifyVar (P qpn) = P qpn +simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag")) +simplifyVar (S qsn) = S qsn + showVar :: Var QPN -> String showVar (P qpn) = showQPN qpn showVar (F qfn) = showQFN qfn @@ -175,7 +185,7 @@ goalReasonToVars :: GoalReason qpn -> ConflictSet qpn goalReasonToVars UserGoal = S.empty goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn) -goalReasonToVars (FDependency qfn _) = S.singleton (F qfn) +goalReasonToVars (FDependency qfn _) = S.singleton (simplifyVar (F qfn)) goalReasonToVars (SDependency qsn) = S.singleton (S qsn) goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn @@ -194,4 +204,4 @@ -- | Compute a conflic set from a goal. The conflict set contains the -- closure of goal reasons as well as the variable of the goal itself. toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn -toConflictSet (Goal g grs) = S.insert g (goalReasonChainToVars grs) +toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs) diff --git a/Distribution/Client/Dependency/Modular/Explore.hs b/Distribution/Client/Dependency/Modular/Explore.hs --- a/Distribution/Client/Dependency/Modular/Explore.hs +++ b/Distribution/Client/Dependency/Modular/Explore.hs @@ -66,9 +66,9 @@ combine _ [] c = (Just c, []) combine var ((k, ( d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $ case d of - Just e | not (var `S.member` e) -> (Just e, []) - | otherwise -> combine var xs (e `S.union` c) - Nothing -> (Nothing, snd $ combine var xs S.empty) + Just e | not (simplifyVar var `S.member` e) -> (Just e, []) + | otherwise -> combine var xs (e `S.union` c) + Nothing -> (Nothing, snd $ combine var xs S.empty) -- | Naive backtracking exploration of the search tree. This will yield correct -- assignments only once the tree itself is validated. diff --git a/Distribution/Client/Dependency/Modular/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs --- a/Distribution/Client/Dependency/Modular/Flag.hs +++ b/Distribution/Client/Dependency/Modular/Flag.hs @@ -25,6 +25,9 @@ unFlag :: Flag -> String unFlag (FlagName fn) = fn +mkFlag :: String -> Flag +mkFlag fn = FlagName fn + -- | Flag info. Default value, whether the flag is manual, and -- whether the flag is weak. Manual flags can only be set explicitly. -- Weak flags are typically deferred by the solver. diff --git a/Distribution/Client/Dependency/Modular/Solver.hs b/Distribution/Client/Dependency/Modular/Solver.hs --- a/Distribution/Client/Dependency/Modular/Solver.hs +++ b/Distribution/Client/Dependency/Modular/Solver.hs @@ -56,6 +56,5 @@ , PackageName "ghc-prim" , PackageName "integer-gmp" , PackageName "integer-simple" - , PackageName "template-haskell" ]) buildPhase = buildTree idx (independentGoals sc) userGoals diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -1051,8 +1051,8 @@ -- now cannot build, we mark as failing due to 'DependentFailed' -- which kind of means it was not their fault. - -- Print last 10 lines of the build log if something went wrong, and - -- 'Installed $PKGID' otherwise. + -- Print build log if something went wrong, and 'Installed $PKGID' + -- otherwise. printBuildResult :: PackageId -> BuildResult -> IO () printBuildResult pkgid buildResult = case buildResult of (Right _) -> notice verbosity $ "Installed " ++ display pkgid @@ -1063,17 +1063,11 @@ Nothing -> return () Just (mkLogFileName, _) -> do let logName = mkLogFileName pkgid - n = 10 - putStr $ "Last " ++ (show n) - ++ " lines of the build log ( " ++ logName ++ " ):\n" - printLastNLines logName n + putStr $ "Build log ( " ++ logName ++ " ):\n" + printFile logName - printLastNLines :: FilePath -> Int -> IO () - printLastNLines path n = do - lns <- fmap lines $ readFile path - let len = length lns - let toDrop = if (len > n && n > 0) then (len - n) else 0 - mapM_ putStrLn (drop toDrop lns) + printFile :: FilePath -> IO () + printFile path = readFile path >>= putStr -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ReadyPackage'. In particular the @@ -1196,7 +1190,7 @@ distDirPathTmp = absUnpackedPath (defaultDistPref ++ "-tmp") distDirPathNew = absUnpackedPath distPref distDirExists <- doesDirectoryExist distDirPath - when distDirExists $ do + when (distDirExists && distDirPath /= distDirPathNew) $ do -- NB: we need to handle the case when 'distDirPathNew' is a -- subdirectory of 'distDirPath' (e.g. 'dist/dist-sandbox-3688fbc2'). debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '" diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,5 +1,5 @@ Name: cabal-install -Version: 1.20.0.2 +Version: 1.20.0.3 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing