diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs index ea37af99a77..bf3493c2a2a 100644 --- a/Cabal-syntax/src/Distribution/Compat/Graph.hs +++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs @@ -100,10 +100,11 @@ import Distribution.Utils.Structured (Structure (..), Structured (..)) import qualified Data.Array as Array import qualified Data.Foldable as Foldable import qualified Data.Graph as G +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Tree as Tree -import qualified Distribution.Compat.Prelude as Prelude +import GHC.Stack (HasCallStack) -- | A graph of nodes @a@. The nodes are expected to have instance -- of class 'IsNode'. @@ -114,7 +115,7 @@ data Graph a = Graph , graphAdjoint :: G.Graph , graphVertexToNode :: G.Vertex -> a , graphKeyToVertex :: Key a -> Maybe G.Vertex - , graphBroken :: [(a, [Key a])] + , graphBroken :: [(a, NonEmpty (Key a))] } -- NB: Not a Functor! (or Traversable), because you need @@ -284,7 +285,7 @@ cycles g = [vs | CyclicSCC vs <- stronglyConnComp g] -- | /O(1)/. Return a list of nodes paired with their broken -- neighbors (i.e., neighbor keys which are not in the graph). -- Requires amortized construction of graph. -broken :: Graph a -> [(a, [Key a])] +broken :: Graph a -> [(a, NonEmpty (Key a))] broken g = graphBroken g -- | Lookup the immediate neighbors from a key in the graph. @@ -343,7 +344,7 @@ revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g) -- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@ -- instead. The values of the map are assumed to already -- be in WHNF. -fromMap :: IsNode a => Map (Key a) a -> Graph a +fromMap :: forall a. (IsNode a, Eq (Key a)) => Map (Key a) a -> Graph a fromMap m = Graph { graphMap = m @@ -352,17 +353,26 @@ fromMap m = , graphAdjoint = G.transposeG g , graphVertexToNode = vertex_to_node , graphKeyToVertex = key_to_vertex - , graphBroken = broke + , graphBroken = + map (\ns'' -> (fst (NE.head ns''), NE.map snd ns'')) $ + NE.groupWith (nodeKey . fst) $ + brokenEdges' } where - try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k) + brokenEdges' :: [(a, Key a)] + brokenEdges' = concat brokenEdges + brokenEdges :: [[(a, Key a)]] (brokenEdges, edges) = - unzip $ - [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) + unzip + [ partitionEithers + [ case key_to_vertex n' of + Just v -> Right v + Nothing -> Left (n, n') + | n' <- nodeNeighbors n + ] | n <- ns ] - broke = filter (not . Prelude.null . snd) (zip ns brokenEdges) g = Array.listArray bounds edges @@ -377,7 +387,7 @@ fromMap m = bounds = (0, Map.size m - 1) -- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. -fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a +fromDistinctList :: HasCallStack => (IsNode a, Show (Key a)) => [a] -> Graph a fromDistinctList = fromMap . Map.fromListWith (\_ -> duplicateError) diff --git a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs index aef3db817c6..6ce25d2a323 100644 --- a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs +++ b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs @@ -22,6 +22,7 @@ import Distribution.Types.ComponentRequestedSpec import Distribution.Utils.Generic import Distribution.Pretty (pretty) +import GHC.Stack (HasCallStack) import Text.PrettyPrint ------------------------------------------------------------------------------ @@ -50,7 +51,8 @@ dispComponentsWithDeps graph = -- | Create a 'Graph' of 'Component', or report a cycle if there is a -- problem. mkComponentsGraph - :: ComponentRequestedSpec + :: HasCallStack + => ComponentRequestedSpec -> PackageDescription -> Either [ComponentName] ComponentsGraph mkComponentsGraph enabled pkg_descr = diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index 55d1ae03254..611537a7828 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -54,6 +54,7 @@ import Data.Either import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Pretty +import GHC.Stack (HasCallStack) import Text.PrettyPrint ------------------------------------------------------------------------------ @@ -61,7 +62,8 @@ import Text.PrettyPrint ------------------------------------------------------------------------------ configureComponentLocalBuildInfos - :: Verbosity + :: HasCallStack + => Verbosity -> Bool -- use_external_internal_deps -> ComponentRequestedSpec -> Bool -- deterministic @@ -206,7 +208,8 @@ configureComponentLocalBuildInfos ------------------------------------------------------------------------------ toComponentLocalBuildInfos - :: Compiler + :: HasCallStack + => Compiler -> InstalledPackageIndex -- FULL set -> [ConfiguredPromisedComponent] -> PackageDescription @@ -232,12 +235,12 @@ toComponentLocalBuildInfos -- since we will pay for the ALL installed packages even if -- they are not related to what we are building. This was true -- in the old configure code. - external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent) external_graph = Graph.fromDistinctList . map Left $ PackageIndex.allPackages installedPackageSet - internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent) internal_graph = Graph.fromDistinctList . map Right @@ -280,14 +283,14 @@ toComponentLocalBuildInfos [ "installed package " ++ prettyShow (packageId pkg) ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) + ++ intercalate ", " (map prettyShow $ toList deps) | (Left pkg, deps) <- broken ] ++ unlines [ "planned package " ++ prettyShow (packageId pkg) ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) + ++ intercalate ", " (map prettyShow $ toList deps) | (Right pkg, deps) <- broken ] diff --git a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs index 9fd78352b7c..93da4de37c3 100644 --- a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs @@ -94,7 +94,7 @@ dispConfiguredComponent cc = -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known. The primary --- work this does is handling implicit @backpack-include@ fields. +-- work this does is handling implicit @mixin@ fields. mkConfiguredComponent :: PackageDescription -> ComponentId @@ -121,7 +121,7 @@ mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do } -- Any @build-depends@ which is not explicitly mentioned in - -- @backpack-include@ is converted into an "implicit" include. + -- @mixin@ is converted into an "implicit" include. let used_explicitly = Set.fromList (map ci_id explicit_includes) implicit_includes = map diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 79ab53f364a..2ba7e22e73a 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -95,7 +95,6 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check hiding (doesFileExist, listDirectory) import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.PrettyPrint import Distribution.Simple.BuildTarget import Distribution.Simple.BuildToolDepends import Distribution.Simple.BuildWay @@ -196,6 +195,7 @@ import Text.PrettyPrint import qualified Data.Maybe as M import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NES +import GHC.Stack (HasCallStack) type UseExternalInternalDeps = Bool @@ -1146,9 +1146,10 @@ configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform pa , extraCoverageFor = [] } - debug verbosity $ - "Finalized package description:\n" - ++ showPackageDescription pkg_descr2 + -- FIXME: Printing the package description loops indefinitely. + -- debug verbosity $ + -- "Finalized package description:\n" + -- ++ showPackageDescription pkg_descr2 return (lbc, pbd) @@ -1393,7 +1394,8 @@ finalCheckPackage CantFindForeignLibraries unsupportedFLibs configureComponents - :: VerbosityHandles + :: HasCallStack + => VerbosityHandles -> LBC.LocalBuildConfig -> LBC.PackageBuildDescr -> InstalledPackageIndex diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 68e6d0be374..5f26028139d 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -238,7 +238,13 @@ configureCompiler verbosity hcPath conf0 = do -- In this example, @AbiTag@ is "inplace". compilerAbiTag :: AbiTag compilerAbiTag = - maybe NoAbiTag (AbiTag . dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId)) projectUnitId + case projectUnitId of + Nothing -> NoAbiTag + Just "" -> NoAbiTag + Just unitId -> + case dropWhile (== '-') $ stripCommonPrefix (prettyShow compilerId) unitId of + "" -> NoAbiTag + tag -> AbiTag tag wiredInUnitIds = do ghcInternalUnitId <- Map.lookup "ghc-internal Unit Id" ghcInfoMap @@ -312,14 +318,8 @@ compilerProgramDb verbosity comp progdb1 hcPkgPath = do ghcProg = fromJust $ lookupProgram ghcProgram progdb1 ghcVersion = compilerVersion comp - -- configure gcc, ld, ar etc... based on the paths stored - -- in the GHC settings file - progdb3 = - Internal.configureToolchain - (ghcVersionImplInfo ghcVersion) - ghcProg - (compilerProperties comp) - progdb2 + -- configure gcc, ld, ar etc... based on the paths stored in the GHC settings file + progdb3 <- Internal.configureToolchain verbosity (ghcVersionImplInfo ghcVersion) ghcProg (compilerProperties comp) progdb2 -- This is slightly tricky, we have to configure ghc first, then we use the -- location of ghc to help find ghc-pkg in the case that the user did not diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index f32b0e34eb3..bb9c9e949c1 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -100,37 +100,47 @@ targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo -- | Adjust the way we find and configure gcc and ld configureToolchain - :: GhcImplInfo + :: Verbosity + -> GhcImplInfo -> ConfiguredProgram -> Map String String -> ProgramDb - -> ProgramDb -configureToolchain _implInfo ghcProg ghcInfo = - addKnownProgram - gccProgram - { programFindLocation = findProg gccProgramName extraGccPath - , programPostConf = configureGcc - } - . addKnownProgram - gppProgram - { programFindLocation = findProg gppProgramName extraGppPath - , programPostConf = configureGpp - } - . addKnownProgram - ldProgram - { programFindLocation = findProg ldProgramName extraLdPath - , programPostConf = \v cp -> - -- Call any existing configuration first and then add any new configuration - configureLd v =<< programPostConf ldProgram v cp - } - . addKnownProgram - arProgram - { programFindLocation = findProg arProgramName extraArPath - } - . addKnownProgram - stripProgram - { programFindLocation = findProg stripProgramName extraStripPath + -> IO ProgramDb +configureToolchain verbosity _implInfo ghcProg ghcInfo db = do + -- this is a bit of a hack. We have a dependency of ld on gcc. + -- ld needs to compiler a c program, to check an ld feature. + -- we _could_ use ghc as a c frontend, but we do not pass all + -- db stack appropriately, and thus we can run into situations + -- where GHC will fail if it's stricter in it's wired-in-unit + -- selction and has the wrong db stack. However we don't need + -- ghc to compile a _test_ c program. So we configure `gcc` + -- first and then use `gcc` (the generic c compiler in cabal + -- terminology) to compile the test program. + let gccProgram' = gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc } + let db' = flip addKnownProgram db $ gccProgram' + (gccProg, db'') <- requireProgram verbosity gccProgram' db' + return $ + flip addKnownPrograms db'' $ + [ gppProgram + { programFindLocation = findProg gppProgramName extraGppPath + , programPostConf = configureGpp + } + , ldProgram + { programFindLocation = findProg ldProgramName extraLdPath + , programPostConf = \v cp -> + -- Call any existing configuration first and then add any new configuration + configureLd gccProg v =<< programPostConf ldProgram v cp + } + , arProgram + { programFindLocation = findProg arProgramName extraArPath + } + , stripProgram + { programFindLocation = findProg stripProgramName extraStripPath + } + ] where compilerDir, base_dir, mingwBinDir :: FilePath compilerDir = takeDirectory (programPath ghcProg) @@ -228,27 +238,26 @@ configureToolchain _implInfo ghcProg ghcInfo = ++ cxxFlags } - configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd v ldProg = do - ldProg' <- configureLd' v ldProg + configureLd :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd gccProg v ldProg = do + ldProg' <- configureLd' gccProg v ldProg return ldProg' { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags } -- we need to find out if ld supports the -x flag - configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd' verbosity ldProg = do + configureLd' :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd' gccProg v ldProg = do ldx <- withTempFile ".c" $ \testcfile testchnd -> withTempFile ".o" $ \testofile testohnd -> do hPutStrLn testchnd "int foo() { return 0; }" hClose testchnd hClose testohnd runProgram - verbosity - ghcProg - [ "-hide-all-packages" - , "-c" + v + gccProg + [ "-c" , testcfile , "-o" , testofile diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index 929b3dd6372..be1c3ccebfb 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -68,6 +68,7 @@ module Distribution.Simple.Program.Db , updateUnconfiguredProgs , updateConfiguredProgs , updatePathProgDb + , programDbSignature ) where import Distribution.Compat.Prelude @@ -604,3 +605,17 @@ requireProgramVersion verbosity prog range programDb = join $ either (dieWithException verbosity) return `fmap` lookupProgramVersion verbosity prog range programDb + +-- | Select the bits of a 'ProgramDb' to monitor for value changes. +-- Use 'programsMonitorFiles' for the files to monitor. +programDbSignature :: ProgramDb -> [ConfiguredProgram] +programDbSignature progdb = + [ prog + { programMonitorFiles = [] + , programOverrideEnv = + filter + ((/= "PATH") . fst) + (programOverrideEnv prog) + } + | prog <- configuredPrograms progdb + ] diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs index 35aa64687a2..c1e92a8b959 100644 --- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs +++ b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs @@ -19,7 +19,7 @@ import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding) import Prelude () import Distribution.Compat.Prelude -import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx) +import Distribution.Simple.Utils (TempFileOptions, withTempFileEx) import Distribution.Utils.Path import Distribution.Verbosity @@ -34,7 +34,7 @@ withResponseFile -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a -withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = +withResponseFile _verbosity tmpFileOpts fileNameTemplate encoding arguments f = withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do let responseFileName = getSymbolicPath responsePath traverse_ (hSetEncoding hf) encoding @@ -43,9 +43,6 @@ withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = map escapeResponseFileArg arguments hPutStr hf responseContents hClose hf - debug verbosity $ responseFileName ++ " contents: <<<" - debug verbosity responseContents - debug verbosity $ ">>> " ++ responseFileName f responseFileName -- Support a gcc-like response file syntax. Each separate diff --git a/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/Cabal/src/Distribution/Types/LocalBuildInfo.hs index f525d397aba..24ebebbbd6f 100644 --- a/Cabal/src/Distribution/Types/LocalBuildInfo.hs +++ b/Cabal/src/Distribution/Types/LocalBuildInfo.hs @@ -132,6 +132,7 @@ import qualified Data.Map as Map import Distribution.Compat.Graph (Graph) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack (HasCallStack) import qualified System.FilePath as FilePath (takeDirectory) -- | Data cached after configuration step. See also @@ -417,7 +418,7 @@ withAllTargetsInBuildOrder' pkg_descr lbi f = -- the order they need to be built. -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. -neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] +neededTargetsInBuildOrder' :: HasCallStack => PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] neededTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uids = case Graph.closure compsGraph uids of Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 5f3ada889bf..f2631d77100 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -4,10 +4,13 @@ module Distribution.Utils.LogProgress ( LogProgress , runLogProgress + , runLogProgress' , warnProgress , infoProgress , dieProgress , addProgressCtx + , eitherToLogProgress + , ErrMsg ) where import Distribution.Compat.Prelude @@ -71,6 +74,16 @@ runLogProgress verbosity (LogProgress m) = fail_fn doc = do dieNoWrap verbosity (render doc) +-- | Run 'LogProgress' ignoring all traces. +runLogProgress' :: LogProgress a -> Either ErrMsg a +runLogProgress' (LogProgress m) = foldProgress (\_ x -> x) Left Right (m env) + where + env = + LogEnv + { le_verbosity = mkVerbosity defaultVerbosityHandles silent + , le_context = [] + } + -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> @@ -100,3 +113,7 @@ formatMsg ctx doc = doc $$ vcat ctx addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a addProgressCtx s (LogProgress m) = LogProgress $ \env -> m env{le_context = s : le_context env} + +eitherToLogProgress :: Either Doc a -> LogProgress a +eitherToLogProgress (Left err) = dieProgress err +eitherToLogProgress (Right a) = return a diff --git a/cabal-install-solver/cabal-install-solver.cabal b/cabal-install-solver/cabal-install-solver.cabal index 5d5eaa37e5a..c769c22b506 100644 --- a/cabal-install-solver/cabal-install-solver.cabal +++ b/cabal-install-solver/cabal-install-solver.cabal @@ -95,7 +95,9 @@ library Distribution.Solver.Types.SolverId Distribution.Solver.Types.SolverPackage Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Stage Distribution.Solver.Types.SummarizedMessage + Distribution.Solver.Types.Toolchain Distribution.Solver.Types.Variable build-depends: diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index edcca8e764d..fae7f4e9def 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -22,7 +22,7 @@ import Distribution.Compat.Graph import Distribution.Compiler ( CompilerInfo ) import Distribution.Solver.Modular.Assignment - ( Assignment, toCPs ) + ( Assignment(..), toCPs ) import Distribution.Solver.Modular.ConfiguredConversion ( convCP ) import qualified Distribution.Solver.Modular.ConflictSet as CS @@ -39,6 +39,8 @@ import Distribution.Solver.Modular.IndexConversion ( convPIs ) import Distribution.Solver.Modular.Log ( SolverFailure(..), displayLogMessages ) +import Distribution.Solver.Modular.Message + ( renderSummarizedMessage ) import Distribution.Solver.Modular.Package ( PN ) import Distribution.Solver.Modular.RetryLog @@ -65,36 +67,36 @@ import Distribution.Solver.Types.Progress ( Progress(..), foldProgress ) import Distribution.Solver.Types.SummarizedMessage ( SummarizedMessage(StringMsg) ) -import Distribution.Solver.Types.Variable ( Variable(..) ) -import Distribution.System - ( Platform(..) ) +import Distribution.Solver.Types.Variable + ( Variable(..) ) +import Distribution.Solver.Types.Toolchain + import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Simple.Utils ( ordNubBy ) -import Distribution.Verbosity -import Distribution.Solver.Modular.Message ( renderSummarizedMessage ) +import Distribution.Verbosity ( VerbosityLevel (..) ) -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc -modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = - uncurry postprocess <$> -- convert install plan - solve' sc cinfo idx pkgConfigDB pprefs gcs pns - where +modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do + (assignment, revdepmap) <- solve' sc cinfo pkgConfigDbs idx pprefs gcs pns + + -- Results have to be converted into an install plan. 'convCP' removes + -- package qualifiers, which means that linked packages become duplicates + -- and can be removed. + return $ ordNubBy nodeKey $ map (convCP iidx sidx) (toCPs assignment revdepmap) + where + cinfo = fst <$> toolchains + -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx + idx = convPIs toolchains gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx -- Constraints have to be converted into a finite map indexed by PN. gcs = M.fromListWith (++) (map pair pcs) where pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) - -- Results have to be converted into an install plan. 'convCP' removes - -- package qualifiers, which means that linked packages become duplicates - -- and can be removed. - postprocess a rdm = ordNubBy nodeKey $ - map (convCP iidx sidx) (toCPs a rdm) - -- Helper function to extract the PN from a constraint. pcName :: PackageConstraint -> PN pcName (PackageConstraint scope _) = scopeToPackageName scope @@ -133,21 +135,21 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns -- complete, i.e., it shows the whole chain of dependencies from the user -- targets to the conflicting packages. solve' :: SolverConfig - -> CompilerInfo + -> Staged CompilerInfo + -> Staged (Maybe PkgConfigDb) -> Index - -> Maybe PkgConfigDb -> (PN -> PackagePreferences) -> Map PN [LabeledPackageConstraint] -> Set PN -> Progress SummarizedMessage String (Assignment, RevDepMap) -solve' sc cinfo idx pkgConfigDB pprefs gcs pns = +solve' sc cinfo pkgConfigDb idx pprefs gcs pns = toProgress $ retry (runSolver printFullLog sc) createErrorMsg where runSolver :: Bool -> SolverConfig -> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap) runSolver keepLog sc' = displayLogMessages keepLog $ - solve sc' cinfo idx pkgConfigDB pprefs gcs pns + solve sc' cinfo pkgConfigDb idx pprefs gcs pns createErrorMsg :: SolverFailure -> RetryLog SummarizedMessage String (Assignment, RevDepMap) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index d12feaf7b1d..c9f1ac521c7 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - +{-# LANGUAGE NamedFieldPuns #-} module Distribution.Solver.Modular.Builder ( buildTree , splits -- for testing @@ -37,7 +36,8 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Settings (IndependentGoals (..)) +import qualified Distribution.Solver.Types.Stage as Stage -- | All state needed to build and link the search tree. It has a type variable -- because the linking phase doesn't need to know about the state used to build @@ -64,41 +64,48 @@ type LinkingState = M.Map (PN, I) [PackagePath] -- We also adjust the map of overall goals, and keep track of the -- reverse dependencies of each of the goals. extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState -extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs +extendOpen qpn deps buildState@(BS { rdeps = rdeps0, open = goals0 }) = go rdeps0 goals0 deps where go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState - go g o [] = s { rdeps = g, open = o } - go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = - go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs - -- Note: for 'Flagged' goals, we always insert, so later additions win. - -- This is important, because in general, if a goal is inserted twice, - -- the later addition will have better dependency information. - go g o ((Stanza sn@(SN qpn _) t) : ngs) = - go g (StanzaGoal sn t (flagGR qpn) : o) ngs - go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs) - | qpn == qpn' = - -- We currently only add a self-dependency to the graph if it is - -- between a package and its setup script. The edge creates a cycle - -- and causes the solver to backtrack and choose a different - -- instance for the setup script. We may need to track other - -- self-dependencies once we implement component-based solving. + go rdeps goals [] = + buildState { rdeps = rdeps, open = goals } + + go rdeps goals ((Flagged fn@(FN qpn' _) fInfo t f) : fdeps) = + go rdeps (FlagGoal fn fInfo t f (flagGR qpn') : goals) fdeps + + -- Note: for 'Flagged' goals, we always insert, so later additions win. + -- This is important, because in general, if a goal is inserted twice, + -- the later addition will have better dependency information. + go rdeps goals ((Stanza sn@(SN qpn' _) t) : fdeps) = + go rdeps (StanzaGoal sn t (flagGR qpn') : goals) fdeps + + go rdeps goals ((Simple (LDep dr (Dep (PkgComponent qpn' _) _)) c) : fdeps) + | qpn' == qpn = + -- We currently only add a self-dependency to the graph if it is + -- between a package and its setup script. The edge creates a cycle + -- and causes the solver to backtrack and choose a different + -- instance for the setup script. We may need to track other + -- self-dependencies once we implement component-based solving. case c of - ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs - _ -> go g o ngs - | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs - | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs - -- code above is correct; insert/adjust have different arg order - go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs + ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn)) qpn' rdeps) goals fdeps + _ -> go rdeps goals fdeps + | qpn' `M.member` rdeps = + go (M.adjust (addIfAbsent (c, qpn)) qpn' rdeps) goals fdeps + | otherwise = + -- Note: insert/adjust have different arg order + go (M.insert qpn' [(c, qpn)] rdeps) (PkgGoal qpn' (DependencyGoal dr) : goals) fdeps + + go rdeps o ((Simple (LDep _dr (Ext _ext )) _c) : goals) = go rdeps o goals + go rdeps o ((Simple (LDep _dr (Lang _lang)) _c) : goals) = go rdeps o goals + go rdeps o ((Simple (LDep _dr (Pkg _pn _vr)) _c) : goals) = go rdeps o goals addIfAbsent :: Eq a => a -> [a] -> [a] addIfAbsent x xs = if x `elem` xs then xs else x : xs - -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by - -- its containing package. - flagGR :: qpn -> GoalReason qpn - flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) +-- GoalReason for a flag or stanza. Each flag/stanza is introduced only by +-- its containing package. +flagGR :: qpn -> GoalReason qpn +flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. @@ -107,7 +114,7 @@ scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s where -- Qualify all package names - qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps + qfdeps = qualifyDeps qpn fdeps -- Introduce all package flags qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals @@ -129,12 +136,14 @@ build = ana go go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) go s = addLinking (linkingState s) $ addChildren (buildState s) +-- | Add children to the tree based on the current build state. addChildren :: BuildState -> TreeF () QGoalReason BuildState -- If we have a choice between many goals, we just record the choice in -- the tree. We select each open goal in turn, and before we descend, remove -- it from the queue of open goals. addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) + -- No goals left. We have done. | L.null gs = DoneF rdm () | otherwise = GoalChoiceF rdm $ P.fromList $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) @@ -142,40 +151,42 @@ addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) -- If we have already picked a goal, then the choice depends on the kind -- of goal. --- --- For a package, we look up the instances available in the global info, --- and then handle each instance in turn. -addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = - case M.lookup pn idx of - Nothing -> FailF - (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) - UnknownPackage - Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> - ([], POption i Nothing, bs { next = Instance qpn info })) - (M.toList pis))) - -- TODO: data structure conversion is rather ugly here - --- For a flag, we create only two subtrees, and we create them in the order --- that is indicated by the flag default. -addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = - FChoiceF qfn rdm gr weak m b (W.fromList - [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), - ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) - where - trivial = L.null t && L.null f - weak = WeakOrTrivial $ unWeakOrTrivial w || trivial - --- For a stanza, we also create only two subtrees. The order is initially --- False, True. This can be changed later by constraints (force enabling --- the stanza by replacing the False branch with failure) or preferences --- (try enabling the stanza if possible by moving the True branch first). - -addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = - SChoiceF qsn rdm gr trivial (W.fromList - [([0], False, bs { next = Goals }), - ([1], True, (extendOpen qpn t bs) { next = Goals })]) - where - trivial = WeakOrTrivial (L.null t) +addChildren bs@(BS { rdeps, index, next = OneGoal goal }) = + case goal of + PkgGoal qpn@(Q (PackagePath s _) pn) gr -> + -- For a package goal, we look up the instances available in the global + -- info, and then handle each instance in turn. + case M.lookup pn index of + Nothing -> FailF + (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) + UnknownPackage + Just pis -> PChoiceF qpn rdeps gr $ W.fromList + [ ([], POption i Nothing, bs { next = Instance qpn info }) + | (i@(I s' _ver _loc), info) <- M.toList pis + -- Only instances belonging to the same stage are allowed. + , s == s' + ] + -- For a flag, we create only two subtrees, and we create them in the order + -- that is indicated by the flag default. + FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr -> + FChoiceF qfn rdeps gr weak m b $ W.fromList + [ ([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }) + , ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals }) + ] + where + trivial = L.null t && L.null f + weak = WeakOrTrivial $ unWeakOrTrivial w || trivial + -- For a stanza, we also create only two subtrees. The order is initially + -- False, True. This can be changed later by constraints (force enabling + -- the stanza by replacing the False branch with failure) or preferences + -- (try enabling the stanza if possible by moving the True branch first). + StanzaGoal qsn@(SN qpn _) t gr -> + SChoiceF qsn rdeps gr trivial $ W.fromList + [ ([0], False, bs { next = Goals }) + , ([1], True, (extendOpen qpn t bs) { next = Goals }) + ] + where + trivial = WeakOrTrivial (L.null t) -- For a particular instance, we change the state: we update the scope, -- and furthermore we update the set of goals. @@ -250,22 +261,22 @@ alreadyLinked = error "addLinking called on tree that already contains linked no -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there. buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason -buildTree idx (IndependentGoals ind) igs = +buildTree idx (IndependentGoals _ind) igs = build Linker { buildState = BS { index = idx - , rdeps = M.fromList (L.map (, []) qpns) - , open = L.map topLevelGoal qpns + , rdeps = M.fromList [(qpn, []) | qpn <- qpns] + , open = [ PkgGoal qpn UserGoal | qpn <- qpns ] , next = Goals , qualifyOptions = defaultQualifyOptions idx } , linkingState = M.empty } where - topLevelGoal qpn = PkgGoal qpn UserGoal + -- The package names are interpreted as top-level goals in the host stage. + path = PackagePath Stage.Host QualToplevel + qpns = [ Q path pn | pn <- igs ] - qpns | ind = L.map makeIndependent igs - | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs {------------------------------------------------------------------------------- Goals diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs index 0e2e8ad5baa..af78f678712 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -6,8 +6,6 @@ import Data.Maybe import Prelude hiding (pi) import Data.Either (partitionEithers) -import Distribution.Package (UnitId, packageId) - import qualified Distribution.Simple.PackageIndex as SI import Distribution.Solver.Modular.Configured @@ -21,43 +19,47 @@ import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage (Staged (..)) -- | Converts from the solver specific result @CP QPN@ into -- a 'ResolverPackage', which can then be converted into -- the install plan. -convCP :: SI.InstalledPackageIndex -> +convCP :: Staged SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> CP QPN -> ResolverPackage loc convCP iidx sidx (CP qpi fa es ds) = - case convPI qpi of - Left pi -> PreExisting $ + case qpi of + -- Installed + (PI qpn (I s _ (Inst pi))) -> + PreExisting $ InstSolverPackage { - instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, + instSolverStage = s, + instSolverQPN = qpn, + instSolverPkgIPI = fromMaybe (error "convCP: lookupUnitId failed") $ SI.lookupUnitId (getStage iidx s) pi, instSolverPkgLibDeps = fmap fst ds', instSolverPkgExeDeps = fmap snd ds' } - Right pi -> Configured $ + -- "In repo" i.e. a source package + (PI qpn@(Q _path pn) (I s v (InRepo _pn))) -> + let pi = PackageIdentifier pn v in + Configured $ SolverPackage { - solverPkgSource = srcpkg, + solverPkgStage = s, + solverPkgQPN = qpn, + solverPkgSource = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi, solverPkgFlags = fa, solverPkgStanzas = es, solverPkgLibDeps = fmap fst ds', solverPkgExeDeps = fmap snd ds' } - where - srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi where ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) ds' = fmap (partitionEithers . map convConfId) ds -convPI :: PI QPN -> Either UnitId PackageId -convPI (PI _ (I _ (Inst pi))) = Left pi -convPI pi = Right (packageId (either id id (convConfId pi))) - convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} -convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = +convConfId (PI (Q (PackagePath _stage q) pn) (I stage v loc)) = case loc of - Inst pi -> Left (PreExistingId sourceId pi) + Inst pi -> Left (PreExistingId stage sourceId pi) _otherwise | QualExe _ pn' <- q -- NB: the dependencies of the executable are also @@ -66,7 +68,7 @@ convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = -- at the actual thing. Fortunately for us, I was -- silly and didn't allow arbitrarily nested build-tools -- dependencies, so a shallow check works. - , pn == pn' -> Right (PlannedId sourceId) - | otherwise -> Left (PlannedId sourceId) + , pn == pn' -> Right (PlannedId stage sourceId) + | otherwise -> Left (PlannedId stage sourceId) where sourceId = PackageIdentifier pn v diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs index e156912133b..4ddf93a9a38 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs @@ -15,6 +15,7 @@ import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Solver.Types.PackagePath +import GHC.Stack (HasCallStack) -- | Find and reject any nodes with cyclic dependencies detectCyclesPhase :: Tree d c -> Tree d c @@ -51,7 +52,7 @@ detectCyclesPhase = go -- all decisions that could potentially break the cycle. -- -- TODO: The conflict set should also contain flag and stanza variables. -findCycles :: QPN -> RevDepMap -> Maybe ConflictSet +findCycles :: HasCallStack => QPN -> RevDepMap -> Maybe ConflictSet findCycles pkg rdm = -- This function has two parts: a faster cycle check that is called at every -- step and a slower calculation of the conflict set. @@ -115,6 +116,6 @@ instance G.IsNode RevDepMapNode where nodeKey (RevDepMapNode qpn _) = qpn nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns -revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode +revDepMapToGraph :: HasCallStack => RevDepMap -> G.Graph RevDepMapNode revDepMapToGraph rdm = G.fromDistinctList [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index fff2dacde4e..1a3783fe6ba 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -58,6 +58,7 @@ import Distribution.Solver.Types.PackagePath import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnqualComponentName +import Distribution.Solver.Types.Stage {------------------------------------------------------------------------------- Constrained instances @@ -85,14 +86,37 @@ type FlaggedDeps qpn = [FlaggedDep qpn] -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. -data FlaggedDep qpn = - -- | Dependencies which are conditional on a flag choice. - Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) - -- | Dependencies which are conditional on whether or not a stanza +-- +-- Note: this is a recursive data structure representing a tree of dependencies. +-- +-- Note 2: why LDep contains its own DependencyReason? I am thinking it should +-- be external to this type. Basically you traverse the tree and the flag and +-- stanza choices are the DepedencyReason? +data FlaggedDep qpn + = -- | Dependencies which are conditional on a flag choice. + Flagged + (FN qpn) + -- ^ The qualified flag name. + FInfo + -- ^ The flag information. + (FlaggedDeps qpn) + -- ^ Extra dependencies when the flag is true. + (FlaggedDeps qpn) + -- ^ Extra dependencies when the flag is false. + | -- | Dependencies which are conditional on whether or not a stanza. -- (e.g., a test suite or benchmark) is enabled. - | Stanza (SN qpn) (TrueFlaggedDeps qpn) - -- | Dependencies which are always enabled, for the component 'comp'. - | Simple (LDep qpn) Component + Stanza + (SN qpn) + -- ^ The qualified stanza name. + (FlaggedDeps qpn) + -- ^ Extra dependencies when stanza is enabled. + | -- | Dependencies which are always enabled. + Simple + (LDep qpn) + -- ^ The dependency. + Component + -- ^ The component of `qpn` introducing the dependency. + deriving Show -- | Conservatively flatten out flagged dependencies -- @@ -105,43 +129,65 @@ flattenFlaggedDeps = concatMap aux aux (Stanza _ t) = flattenFlaggedDeps t aux (Simple d c) = [(d, c)] -type TrueFlaggedDeps qpn = FlaggedDeps qpn -type FalseFlaggedDeps qpn = FlaggedDeps qpn - -- | A 'Dep' labeled with the reason it was introduced. -- -- 'LDep' intentionally has no 'Functor' instance because the type variable -- is used both to record the dependencies as well as who's doing the -- depending; having a 'Functor' instance makes bugs where we don't distinguish -- these two far too likely. (By rights 'LDep' ought to have two type variables.) -data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) +data LDep qpn + = LDep + (DependencyReason qpn) + -- ^ The reason the dependency was introduced. + (Dep qpn) + -- ^ The dependency itself. + deriving Show -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as -- dependencies on language extensions. -data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component - | Ext Extension -- ^ dependency on a language extension - | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package - deriving Functor +data Dep qpn + = -- | dependency on a package component + Dep (PkgComponent qpn) CI + | -- | dependency on a language extension + Ext Extension + | -- | dependency on a language version + Lang Language + | -- | dependency on a pkg-config package + Pkg PkgconfigName PkgconfigVersionRange + deriving (Functor, Show) -- | An exposed component within a package. This type is used to represent -- build-depends and build-tool-depends dependencies. -data PkgComponent qpn = PkgComponent qpn ExposedComponent +data PkgComponent qpn + = PkgComponent + qpn + -- ^ The qualified name of the package. + ExposedComponent + -- ^ The component exposed by the package. deriving (Eq, Ord, Functor, Show) -- | A component that can be depended upon by another package, i.e., a library -- or an executable. -data ExposedComponent = +data ExposedComponent + = -- | A library component ExposedLib LibraryName - | ExposedExe UnqualComponentName + | -- | An executable component + ExposedExe UnqualComponentName deriving (Eq, Ord, Show) -- | The reason that a dependency is active. It identifies the package and any -- flag and stanza choices that introduced the dependency. It contains -- everything needed for creating ConflictSets or describing conflicts in solver -- log messages. -data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza) +data DependencyReason qpn + = DependencyReason + qpn + -- ^ The qualified name of the dependent package. + (Map Flag FlagValue) + -- ^ The flag choices that introduced the dependency. + (S.Set Stanza) + -- ^ The stanza choices that introduced the dependency. deriving (Functor, Eq, Show) -- | Print the reason that a dependency was introduced. @@ -174,8 +220,8 @@ data QualifyOptions = QO { -- -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. -qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN -qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go +qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN +qualifyDeps (Q pp@(PackagePath s q) pn) = go where go :: FlaggedDeps PN -> FlaggedDeps QPN go = map go1 @@ -197,37 +243,20 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) goD :: Dep PN -> Component -> Dep QPN - goD (Ext ext) _ = Ext ext - goD (Lang lang) _ = Lang lang - goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = - Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci - goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp - | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci - | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci - | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci - - -- If P has a setup dependency on Q, and Q has a regular dependency on R, then - -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup - -- dependency on R. We do not do this for the base qualifier however. - -- - -- The inherited qualifier is only used for regular dependencies; for setup - -- and base dependencies we override the existing qualifier. See #3160 for - -- a detailed discussion. - inheritedQ :: Qualifier - inheritedQ = case q of - QualSetup _ -> q - QualExe _ _ -> q - QualToplevel -> q - QualBase _ -> QualToplevel - - -- Should we qualify this goal with the 'Base' package path? - qBase :: PN -> Bool - qBase dep = qoBaseShim && unPackageName dep == "base" - - -- Should we qualify this goal with the 'Setup' package path? - qSetup :: Component -> Bool - qSetup comp = qoSetupIndependent && comp == ComponentSetup + goD (Ext ext) _ = Ext ext + goD (Lang lang) _ = Lang lang + goD (Pkg pkn vr) _ = Pkg pkn vr + + -- In case of executable and setup dependencies, we need to qualify the dependency + -- with the previsous stage (e.g. Host -> Build). + goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _component = + Dep (Q (PackagePath (prevStage s) (QualExe pn qpn)) <$> dep) ci + + goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) ComponentSetup = + Dep (Q (PackagePath (prevStage s) (QualSetup pn)) <$> dep) ci + + goD (Dep dep@(PkgComponent _qpn _) ci) _component = + Dep (Q (PackagePath s q) <$> dep) ci -- | Remove qualifiers from set of dependencies -- diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs index aa3d361a562..5aa9b52c14e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -268,9 +268,9 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx -- Skipping it is an optimization. If false, it returns a new conflict set -- to be merged with the previous one. couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet - couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = + couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I _stage v _) _) conflicts = let (PInfo deps _ _ _) = idx M.! pn M.! i - qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps + qdeps = qualifyDeps currentQPN deps couldBeResolved :: CS.Conflict -> Maybe ConflictSet couldBeResolved CS.OtherConflict = Nothing diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs index 2f28d12de85..b0b576205ef 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -32,10 +32,15 @@ type Index = Map PN (Map I PInfo) -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps PN) - (Map ExposedComponent ComponentInfo) - FlagInfo - (Maybe FailReason) +data PInfo = PInfo + (FlaggedDeps PN) + -- ^ The package dependencies, whether they are conditional on a flag, a + -- stanza or always active. + (Map ExposedComponent ComponentInfo) + -- ^ Info associated with each library and executable component. + FlagInfo + -- + (Maybe FailReason) -- | Info associated with each library and executable in a package instance. data ComponentInfo = ComponentInfo { @@ -64,7 +69,7 @@ defaultQualifyOptions idx = QO { | -- Find all versions of base .. Just is <- [M.lookup base idx] -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is + , (I _ _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is -- .. and flatten all their dependencies .. , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps ] diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs index f150235631f..4844909123c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -34,6 +34,7 @@ import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage (Stage(..), Staged(..), stages) import Distribution.Solver.Modular.Dependency as D import Distribution.Solver.Modular.Flag as F @@ -56,24 +57,31 @@ import qualified Distribution.Types.BuildInfo.Lens as L -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. -convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> ShadowPkgs -> StrongFlags -> SolveExecutables - -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) - -> Index -convPIs os arch comp constraints sip strfl solveExes iidx sidx = +convPIs + :: Staged (CompilerInfo, Platform) + -> Map PN [LabeledPackageConstraint] + -> ShadowPkgs + -> StrongFlags + -> SolveExecutables + -> Staged SI.InstalledPackageIndex + -> CI.PackageIndex (SourcePackage loc) + -> Index +convPIs toolchains' constraints sip strfl solveExes iidx sidx = mkIndex $ - convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx + convIPI' sip iidx ++ convSPI' toolchains' constraints strfl solveExes sidx -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. -convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] -convIPI' (ShadowPkgs sip) idx = +convIPI' :: ShadowPkgs -> Staged SI.InstalledPackageIndex -> [(PN, I, PInfo)] +convIPI' (ShadowPkgs sip) sipi = -- apply shadowing whenever there are multiple installed packages with -- the same version - [ maybeShadow (convIP idx pkg) + [ maybeShadow (convIP stage idx pkg) -- IMPORTANT to get internal libraries. See -- Note [Index conversion with internal libraries] - | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx + | stage <- stages + , let idx = getStage sipi stage + , (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] where @@ -83,16 +91,16 @@ convIPI' (ShadowPkgs sip) idx = shadow x = x -- | Extract/recover the package ID from an installed package info, and convert it to a solver's I. -convId :: IPI.InstalledPackageInfo -> (PN, I) -convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) +convId :: Stage -> IPI.InstalledPackageInfo -> (PN, I) +convId stage ipi = (pn, I stage ver $ Inst $ IPI.installedUnitId ipi) where MungedPackageId mpn ver = mungedId ipi -- HACK. See Note [Index conversion with internal libraries] pn = encodeCompatPackageName mpn -- | Convert a single installed package into the solver-specific format. -convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) -convIP idx ipi = - case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of +convIP :: Stage -> SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) +convIP stage idx ipi = + case traverse (convIPId stage (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) Right fds -> (pn, i, PInfo fds components M.empty Nothing) where @@ -104,7 +112,7 @@ convIP idx ipi = , compIsBuildable = IsBuildable True } - (pn, i) = convId ipi + (pn, i) = convId stage ipi -- 'sourceLibName' is unreliable, but for now we only really use this for -- primary libs anyways @@ -144,41 +152,54 @@ convIP idx ipi = -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored. -convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) -convIPId dr comp idx ipid = +convIPId :: Stage -> DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) +convIPId stage dr comp idx ipid = case SI.lookupUnitId idx ipid of Nothing -> Left ipid - Just ipi -> let (pn, i) = convId ipi - name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. + Just ipi -> let (pn, i) = convId stage ipi + name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables - -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] -convSPI' os arch cinfo constraints strfl solveExes = - L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages +-- NOTE: The package description of source package can depent on the platform +-- and compiler version. Here we decide to convert a single source package +-- into multiple index entries, one for each stage, where the conditionals are +-- resolved. This choice might incour in high memory consumption and it might +-- be worth looking for a different approach. +convSPI' + :: Staged (CompilerInfo, Platform) + -> Map PN [LabeledPackageConstraint] + -> StrongFlags + -> SolveExecutables + -> CI.PackageIndex (SourcePackage loc) + -> [(PN, I, PInfo)] +convSPI' toolchains constraints strfl solveExes sidx = + concat $ + [ map (convSP stage os arch cinfo constraints strfl solveExes) (CI.allPackages sidx) + | stage <- stages + , let (cinfo, Platform arch os) = getStage toolchains stage + ] -- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] +convSP :: Stage -> OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) -convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = - let i = I pv InRepo +convSP stage os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = + let i = I stage pv (InRepo pn) pkgConstraints = fromMaybe [] $ M.lookup pn constraints - in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) + in (pn, i, convGPD stage os arch cinfo pkgConstraints strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we -- want to keep the condition tree, but simplify much of the test. -- | Convert a generic package description to a solver-specific 'PInfo'. -convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] +convGPD :: Stage -> OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription -> PInfo -convGPD os arch cinfo constraints strfl solveExes pn +convGPD stage os arch cinfo constraints strfl solveExes pn (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags @@ -236,7 +257,7 @@ convGPD os arch cinfo constraints strfl solveExes pn , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False } - testCondition = testConditionForComponent os arch cinfo constraints + testCondition = testConditionForComponent stage os arch cinfo constraints isPrivate LibraryVisibilityPrivate = True isPrivate LibraryVisibilityPublic = False @@ -249,24 +270,27 @@ convGPD os arch cinfo constraints strfl solveExes pn -- before dependency solving. Additionally, this function only considers flags -- that are set by unqualified flag constraints, and it doesn't check the -- intra-package dependencies of a component. -testConditionForComponent :: OS +testConditionForComponent :: Stage + -> OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> (a -> Bool) -> CondTree ConfVar a -> Maybe Bool -testConditionForComponent os arch cinfo constraints p tree = +testConditionForComponent stage os arch cinfo constraints p tree = case go $ extractCondition p tree of Lit True -> Just True Lit False -> Just False _ -> Nothing where + -- TODO: fix for stage flagAssignment :: [(FlagName, Bool)] flagAssignment = mconcat [ unFlagAssignment fa - | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) - <- L.map unlabelPackageConstraint constraints] + | PackageConstraint (ConstraintScope stage' (ScopeAnyQualifier _)) (PackagePropertyFlags fa) + <- L.map unlabelPackageConstraint constraints + , maybe True (== stage) stage'] -- Simplify the condition, using the current environment. Most of this -- function was copied from convBranch and diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs index e14c0751de4..f99c34a64d1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs @@ -101,7 +101,7 @@ validateLinking index = (`runReader` initVS) . go goP qpn@(Q _pp pn) opt@(POption i _) r = do vs <- ask let PInfo deps _ _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + qdeps = qualifyDeps qpn deps newSaved = M.insert qpn qdeps (vsSaved vs) case execUpdateState (pickPOption qpn opt qdeps) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) @@ -274,9 +274,8 @@ linkDeps target = \deps -> do (Simple (LDep _ (Pkg _ _)) _, _) -> return () requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) - requalify deps = do - vs <- get - return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) + requalify deps = + return $ qualifyDeps target (unqualifyDeps deps) pickFlag :: QFN -> Bool -> UpdateState () pickFlag qfn b = do diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index 5dbcce9194c..d378c732821 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -34,7 +34,7 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.MessageUtils ( showUnsupportedExtension, showUnsupportedLanguage ) import Distribution.Solver.Modular.Package - ( PI(PI), showI, showPI ) + ( showI ) import Distribution.Solver.Modular.Tree ( FailReason(..), POption(..), ConflictingDep(..) ) import Distribution.Solver.Modular.Version @@ -262,8 +262,8 @@ data MergedPackageConflict = MergedPackageConflict { showOption :: QPN -> POption -> String showOption qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of - Nothing -> showPI (PI qpn i) -- Consistent with prior to POption - Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) + Nothing -> showQPN qpn ++ " == " ++ showI i + Just pp' -> "to reuse " ++ showQPN (Q pp' pn) ++ " for " ++ showQPN qpn -- | Shows a mixed list of instances and versions in a human-friendly way, -- abbreviated. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index 876ac2d790c..922020b745b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -11,7 +11,6 @@ module Distribution.Solver.Modular.Package , QPV , instI , instUid - , makeIndependent , primaryPP , setupPP , showI @@ -27,6 +26,7 @@ import Distribution.Pretty (prettyShow) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Stage (Stage, showStage) -- | A package name. type PN = PackageName @@ -49,22 +49,17 @@ type PId = UnitId -- package instance via its 'PId'. -- -- TODO: More information is needed about the repo. -data Loc = Inst PId | InRepo +data Loc = Inst PId | InRepo PackageName deriving (Eq, Ord, Show) -- | Instance. A version number and a location. -data I = I Ver Loc +data I = I Stage Ver Loc deriving (Eq, Ord, Show) -- | String representation of an instance. showI :: I -> String -showI (I v InRepo) = showVer v -showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid - where - extractPackageAbiHash xs = - case first reverse $ break (=='-') $ reverse (prettyShow xs) of - (ys, []) -> ys - (ys, _) -> '-' : ys +showI (I s v (InRepo pn)) = intercalate ":" [showStage s, "source", prettyShow (PackageIdentifier pn v)] +showI (I s _v (Inst uid)) = intercalate ":" [showStage s, "installed", prettyShow uid] -- | Package instance. A package name and an instance. data PI qpn = PI qpn I @@ -75,11 +70,11 @@ showPI :: PI QPN -> String showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i instI :: I -> Bool -instI (I _ (Inst _)) = True +instI (I _ _ (Inst _)) = True instI _ = False instUid :: UnitId -> I -> Bool -instUid uid (I _ (Inst uid')) = uid == uid' +instUid uid (I _ _ (Inst uid')) = uid == uid' instUid _ _ = False -- | Is the package in the primary group of packages. This is used to @@ -105,7 +100,3 @@ setupPP :: PackagePath -> Bool setupPP (PackagePath _ns (QualSetup _)) = True setupPP (PackagePath _ns _) = False --- | Qualify a target package with its own name so that its dependencies are not --- required to be consistent with other targets. -makeIndependent :: PN -> QPN -makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs index e33eb09524f..9dad77e15f3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -72,7 +72,7 @@ addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c addWeight f = addWeights [f] version :: POption -> Ver -version (POption (I v _) _) = v +version (POption (I _ v _) _) = v -- | Prefer to link packages whenever possible. preferLinked :: EndoTreeTrav d c @@ -139,7 +139,7 @@ preferPackagePreferences pcs = -- Prefer installed packages over non-installed packages. installed :: POption -> Weight - installed (POption (I _ (Inst _)) _) = 0 + installed (POption (I _ _ (Inst _)) _) = 0 installed _ = 1 -- | Traversal that tries to establish package stanza enable\/disable @@ -184,7 +184,7 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s else r where go :: I -> PackageProperty -> Tree d c - go (I v _) (PackagePropertyVersion vr) + go (I _ v _) (PackagePropertyVersion vr) | checkVR vr v = r | otherwise = Fail c (GlobalConstraintVersion vr src) go _ PackagePropertyInstalled @@ -341,10 +341,10 @@ avoidReinstalls p = go | otherwise = PChoiceF qpn rdm gr cs where disableReinstalls = - let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] + let installed = [ v | (_, POption (I _ v (Inst _)) _, _) <- W.toList cs ] in W.mapWithKey (notReinstall installed) cs - notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = + notReinstall vs (POption (I _ v (InRepo _pn)) _) _ | v `elem` vs = Fail (varToConflictSet (P qpn)) CannotReinstall notReinstall _ _ x = x @@ -423,9 +423,9 @@ deferSetupExeChoices = go go x = x noSetupOrExe :: Goal QPN -> Bool - noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False - noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False - noSetupOrExe _ = True + noSetupOrExe (Goal (P (Q (PackagePath _ (QualSetup _)) _)) _) = False + noSetupOrExe (Goal (P (Q (PackagePath _ (QualExe _ _)) _)) _) = False + noSetupOrExe _ = True -- | Transformation that tries to avoid making weak flag choices early. -- Weak flags are trivial flags (not influencing dependencies) or such diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs index d16fb37af37..71e7611fbac 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -44,11 +44,12 @@ import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.PSQ as PSQ import Distribution.Simple.Setup (BooleanFlag(..)) +import Distribution.Solver.Types.Stage (Staged, Stage(..)) #ifdef DEBUG_TRACETREE import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W -import qualified Distribution.Deprecated.Text as T +import Distribution.Solver.Modular.Version (showVer) import Debug.Trace.Tree (gtraceJson) import Debug.Trace.Tree.Simple @@ -89,14 +90,14 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool -- before exploration. -- solve :: SolverConfig -- ^ solver parameters - -> CompilerInfo + -> Staged CompilerInfo + -> Staged (Maybe PkgConfigDb) -> Index -- ^ all available packages as an index - -> Maybe PkgConfigDb -- ^ available pkg-config pkgs -> (PN -> PackagePreferences) -- ^ preferences -> M.Map PN [LabeledPackageConstraint] -- ^ global constraints -> S.Set PN -- ^ global goals -> RetryLog Message SolverFailure (Assignment, RevDepMap) -solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = +solve sc cinfo pkgConfigDB idx userPrefs userConstraints userGoals = explorePhase . traceTree "cycles.json" id . detectCycles . @@ -137,7 +138,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = P.enforceManualFlags userConstraints validationCata = P.enforceSingleInstanceRestriction . validateLinking idx . - validateTree cinfo idx pkgConfigDB + validateTree cinfo pkgConfigDB idx prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . (case onlyConstrained sc of OnlyConstrainedAll -> @@ -203,7 +204,7 @@ instance GSimpleTree (Tree d c) where -- Show package choice goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) - goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) + goP _ (POption (I _stage ver _loc) Nothing) subtree = (showVer ver, go subtree) goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) -- Show flag or stanza choice @@ -250,5 +251,5 @@ _removeGR = trav go dummy = DependencyGoal $ DependencyReason - (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + (Q (PackagePath Host QualToplevel) (mkPackageName "$")) M.empty S.empty diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs index aeda39f6b3f..169b33de499 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -49,19 +49,52 @@ type Weight = Double -- -- TODO: The weight type should be changed from [Double] to Double to avoid -- giving too much weight to preferences that are applied later. -data Tree d c = - -- | Choose a version for a package (or choose to link) - PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) +-- +-- Note: this the tree *of possible choices*, which is used to explore all +-- possible solutions to a given problem. It does not describe a single solution. +data Tree d c + = -- | Choose a version for a package (or choose to link) + PChoice + QPN + -- ^ The package to choose an instance for + RevDepMap + -- ^ The reverse dependency map (FIXME ?) + c + -- ^ Additional data for the choice node + (WeightedPSQ [Weight] POption (Tree d c)) + -- ^ Weighted list of possible options (`POption`) paired with the subsequent search tree. - -- | Choose a value for a flag - -- - -- The Bool is the default value. - | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) + | -- | Choose a value for a flag. + FChoice + QFN + -- ^ The flag to choose a value for. + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + c + -- ^ Additional data for the choice node. + WeakOrTrivial + -- ^ Whether the choice should be deferred. + FlagType + -- ^ Whether the flag is manual or automatic. + Bool + -- ^ The flag default value + (WeightedPSQ [Weight] Bool (Tree d c)) + -- ^ Weighted list of possible options paired with the subsequent search tree. - -- | Choose whether or not to enable a stanza - | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + | -- | Choose whether or not to enable a stanza. + SChoice + QSN + -- ^ The stanza to choose to enable or disable. + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + c + -- ^ Additional data for the choice node. + WeakOrTrivial + -- ^ Whether the choice should be deferred. + (WeightedPSQ [Weight] Bool (Tree d c)) + -- ^ Weighted list of possible options paired with the subsequent search tree. - -- | Choose which choice to make next + | -- | Choose which choice to make next -- -- Invariants: -- @@ -72,13 +105,25 @@ data Tree d c = -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason -- recorded on that 'GoalChoice' node. - | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) + GoalChoice + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + (PSQ (Goal QPN) (Tree d c)) + -- ^ Priority search queue associating a goal with the search tree. - -- | We're done -- we found a solution! - | Done RevDepMap d + | -- | We're done -- we found a solution! + Done + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + d + -- ^ The solution. - -- | We failed to find a solution in this path through the tree - | Fail ConflictSet FailReason + | -- | We failed to find a solution in this path through the tree + Fail + ConflictSet + -- ^ The conflict set. + FailReason + -- ^ The reason for failure. -- | A package option is a package instance with an optional linking annotation -- @@ -96,7 +141,12 @@ data Tree d c = -- dependencies must also be the exact same). -- -- See for details. -data POption = POption I (Maybe PackagePath) +data POption + = POption + I + -- ^ The choosen package instance. + (Maybe PackagePath) + -- ^ The package this choice is linked to (if any). deriving (Eq, Show) data FailReason = UnsupportedExtension Extension @@ -133,7 +183,14 @@ data FailReason = UnsupportedExtension Extension deriving (Eq, Show) -- | Information about a dependency involved in a conflict, for error messages. -data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI +data ConflictingDep + = ConflictingDep + (DependencyReason QPN) + -- ^ The reason for the dependency. + (PkgComponent QPN) + -- ^ The component of the package that caused the conflict. + CI + -- ^ The constrained instance. deriving (Eq, Show) -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs index ed01234bdba..f0c0566d6a1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -35,6 +35,7 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange +import Distribution.Solver.Types.Stage (Staged (..), Stage (..)) -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints @@ -88,9 +89,9 @@ import Distribution.Types.PkgconfigVersionRange -- | The state needed during validation. data ValidateState = VS { - supportedExt :: Extension -> Bool, - supportedLang :: Language -> Bool, - presentPkgs :: Maybe (PkgconfigName -> PkgconfigVersionRange -> Bool), + supportedExt :: Stage -> Extension -> Bool, + supportedLang :: Stage -> Language -> Bool, + presentPkgs :: Stage -> Maybe (PkgconfigName -> PkgconfigVersionRange -> Bool), index :: Index, -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, @@ -191,7 +192,7 @@ validate = go -- What to do for package nodes ... goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) - goP qpn@(Q _pp pn) (POption i _) r = do + goP qpn@(Q (PackagePath _stage _) pn) (POption i _mpp) r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -200,17 +201,17 @@ validate = go svd <- asks saved -- obtain saved dependencies aComps <- asks availableComponents rComps <- asks requiredComponents - qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice + let I stage _vr _loc = i let (PInfo deps comps _ mfr) = idx ! pn ! i -- qualify the deps in the current scope - let qdeps = qualifyDeps qo qpn deps + let qdeps = qualifyDeps qpn deps -- the new active constraints are given by the instance we have chosen, -- plus the dependency information we have for that instance let newactives = extractAllDeps pfa psa qdeps -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported pkgPresent newactives - =<< extendWithPackageChoice (PI qpn i) ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives + =<< extendWithPackageChoice (PI qpn i) ppa -- In case we continue, we save the scoped dependencies let nsvd = M.insert qpn qdeps svd case mfr of @@ -235,7 +236,7 @@ validate = go -- What to do for flag nodes ... goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goF qfn@(FN qpn _f) b r = do + goF qfn@(FN qpn@(Q (PackagePath stage _) _) _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -257,7 +258,7 @@ validate = go let newactives = extractNewDeps (F qfn) b npfa psa qdeps mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> @@ -265,7 +266,7 @@ validate = go -- What to do for stanza nodes (similar to flag nodes) ... goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goS qsn@(SN qpn _f) b r = do + goS qsn@(SN qpn@(Q (PackagePath stage _) _) _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -287,7 +288,7 @@ validate = go let newactives = extractNewDeps (S qsn) b pfa npsa qdeps mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> @@ -331,7 +332,14 @@ checkComponentsInNewPackage required qpn providedComps = -- | We try to extract as many concrete dependencies from the given flagged -- dependencies as possible. We make use of all the flag knowledge we have -- already acquired. -extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractAllDeps + :: FAssignment + -- ^ current flag assignments + -> SAssignment + -- ^ current stanza assignments + -> FlaggedDeps QPN + -- ^ conditional dependencies + -> [LDep QPN] extractAllDeps fa sa deps = do d <- deps case d of @@ -348,7 +356,19 @@ extractAllDeps fa sa deps = do -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call -- 'extractAllDeps' for everything underneath. -extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractNewDeps + :: Var QPN + -- ^ the variable (package, flag or stanza) + -> Bool + -- ^ the variable value + -> FAssignment + -- ^ current flag assignments + -> SAssignment + -- ^ current stanza assignments + -> FlaggedDeps QPN + -- ^ conditional dependencies + -> [LDep QPN] + -- ^ dependencies with a reason extractNewDeps v b fa sa = go where go :: FlaggedDeps QPN -> [LDep QPN] @@ -452,14 +472,14 @@ merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) +merge (MergedDepFixed comp1 vs1 i@(I _ v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i | otherwise = Left ( createConflictSetForVersionConflict p v vs1 vr vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) = +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I _ v _))) = go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... where go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep @@ -563,15 +583,13 @@ extendRequiredComponents eqpn available = foldM extendSingle -- | Interface. -validateTree :: CompilerInfo -> Index -> Maybe PkgConfigDb -> Tree d c -> Tree d c -validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { - supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported - (\ es -> let s = S.fromList es in (`S.member` s)) - (compilerInfoExtensions cinfo) - , supportedLang = maybe (const True) - (flip L.elem) -- use list lookup because language list is small and no Ord instance - (compilerInfoLanguages cinfo) - , presentPkgs = pkgConfigPkgIsPresent <$> pkgConfigDb +validateTree :: Staged CompilerInfo -> Staged (Maybe PkgConfigDb) -> Index -> Tree d c -> Tree d c +validateTree cinfo pkgConfigDb idx t = runValidate (validate t) VS + { -- if compiler has no list of extensions, we assume everything is supported + supportedExt = maybe (const True) (flip S.member) . getStage extSet + , -- if compiler has no list of extensions, we assume everything is supported + supportedLang = maybe (const True) (flip S.member) . getStage langSet + , presentPkgs = fmap pkgConfigPkgIsPresent . getStage pkgConfigDb , index = idx , saved = M.empty , pa = PA M.empty M.empty M.empty @@ -579,3 +597,9 @@ validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { , requiredComponents = M.empty , qualifyOptions = defaultQualifyOptions idx } + where + extSet :: Staged (Maybe (S.Set Extension)) + extSet = fmap (fmap S.fromList . compilerInfoExtensions) cinfo + + langSet :: Staged (Maybe (S.Set Language)) + langSet = fmap (fmap S.fromList . compilerInfoLanguages) cinfo diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs index e551aa2916b..4355a797cd6 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs @@ -36,11 +36,12 @@ module Distribution.Solver.Types.ComponentDeps ( , setupDeps , select , components + , null ) where import Prelude () import Distribution.Types.UnqualComponentName -import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) +import Distribution.Solver.Compat.Prelude hiding (null, empty, toList, zip) import qualified Data.Map as Map @@ -132,6 +133,9 @@ insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps aux Nothing = Just a aux (Just a') = Just $ a `mappend` a' +null :: ComponentDeps a -> Bool +null = Map.null . unComponentDeps + -- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' -- as the neutral element when a 'Component' is present only in one. zip diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index 4244a080064..25cc04c393b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -60,6 +60,9 @@ data ConstraintSource = -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion + + -- | TODO + | ConstraintHideInstalledPackagesSpecificBySourcePackageId deriving (Show, Eq, Generic) instance Binary ConstraintSource @@ -95,3 +98,5 @@ instance Pretty ConstraintSource where text "minimum version of Cabal used by Setup.hs" ConstraintSetupCabalMaxVersion -> text "maximum version of Cabal used by Setup.hs" + ConstraintHideInstalledPackagesSpecificBySourcePackageId -> + text "HideInstalledPackagesSpecificBySourcePackageId" diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 956a4e14849..d58dfe49af3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -15,7 +15,10 @@ import Distribution.Solver.Types.Progress ( Progress ) import Distribution.Solver.Types.ResolverPackage ( ResolverPackage ) -import Distribution.Solver.Types.SourcePackage ( SourcePackage ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage ) +import Distribution.Solver.Types.Stage + ( Staged ) import Distribution.Solver.Types.SummarizedMessage ( SummarizedMessage(..) ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) @@ -31,11 +34,10 @@ import Distribution.System ( Platform ) -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. -- -type DependencyResolver loc = Platform - -> CompilerInfo - -> InstalledPackageIndex +type DependencyResolver loc = Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> PackageIndex (SourcePackage loc) - -> Maybe PkgConfigDb -> (PackageName -> PackagePreferences) -> [LabeledPackageConstraint] -> Set PackageName diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs index 871a0dd15a9..b2358bca348 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs @@ -8,7 +8,9 @@ import Prelude () import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.PackagePath (QPN) import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.Stage (Stage) import Distribution.Types.MungedPackageId import Distribution.Types.PackageId import Distribution.Types.MungedPackageName @@ -17,6 +19,8 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) -- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver. data InstSolverPackage = InstSolverPackage { + instSolverStage :: Stage, + instSolverQPN :: QPN, instSolverPkgIPI :: InstalledPackageInfo, instSolverPkgLibDeps :: ComponentDeps [SolverId], instSolverPkgExeDeps :: ComponentDeps [SolverId] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index 9b5db378b6a..4a7856c877a 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -7,6 +7,7 @@ -- module Distribution.Solver.Types.PackageConstraint ( ConstraintScope(..), + ConstraintQualifier(..), scopeToplevel, scopeToPackageName, constraintScopeMatches, @@ -29,11 +30,21 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import qualified Text.PrettyPrint as Disp +import Distribution.Solver.Types.Toolchain (Stage (..)) -- | Determines to what packages and in what contexts a -- constraint applies. -data ConstraintScope +data ConstraintScope = + ConstraintScope + -- | The stage at which the constraint applies, if any. + -- If Nothing, the constraint applies to all stages. + (Maybe Stage) + -- | The qualifier that determines the scope of the constraint. + ConstraintQualifier + deriving (Eq, Show) + +data ConstraintQualifier -- | A scope that applies when the given package is used as a build target. -- In other words, the scope applies iff a goal has a top-level qualifier -- and its namespace matches the given package name. A namespace is @@ -46,44 +57,57 @@ data ConstraintScope = ScopeTarget PackageName -- | The package with the specified name and qualifier. | ScopeQualified Qualifier PackageName - -- | The package with the specified name when it has a - -- setup qualifier. + -- | The package with the specified name when it has a setup qualifier. | ScopeAnySetupQualifier PackageName - -- | The package with the specified name regardless of - -- qualifier. + -- | The package with the specified name when it has an exe qualifier. + | ScopeAnyExeQualifier PackageName + -- | The package with the specified name regardless of qualifier. | ScopeAnyQualifier PackageName deriving (Eq, Show) -- | Constructor for a common use case: the constraint applies to -- the package with the specified name when that package is a --- top-level dependency in the default namespace. +-- top-level dependency in the host stage. scopeToplevel :: PackageName -> ConstraintScope -scopeToplevel = ScopeQualified QualToplevel +scopeToplevel = ConstraintScope (Just Host) . ScopeQualified QualToplevel -- | Returns the package name associated with a constraint scope. scopeToPackageName :: ConstraintScope -> PackageName -scopeToPackageName (ScopeTarget pn) = pn -scopeToPackageName (ScopeQualified _ pn) = pn -scopeToPackageName (ScopeAnySetupQualifier pn) = pn -scopeToPackageName (ScopeAnyQualifier pn) = pn +scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnyExeQualifier pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool -constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = - let namespaceMatches DefaultNamespace = True - namespaceMatches (Independent namespacePn) = pn == namespacePn - in namespaceMatches ns && q == QualToplevel && pn == pn' -constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = - q == q' && pn == pn' -constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = - let setup (PackagePath _ (QualSetup _)) = True - setup _ = False - in setup pp && pn == pn' -constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' +constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' q) pn') = + maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn' + +constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool +constraintQualifierMatches (ScopeTarget pn) QualToplevel pn' = pn == pn' +constraintQualifierMatches (ScopeTarget _) (QualSetup _) _ = False +constraintQualifierMatches (ScopeTarget _) (QualExe _ _) _ = False +constraintQualifierMatches (ScopeTarget _) (QualBase _) _ = False +constraintQualifierMatches (ScopeQualified q pn) q' pn' = q == q' && pn == pn' +constraintQualifierMatches (ScopeAnySetupQualifier _) QualToplevel _ = False +constraintQualifierMatches (ScopeAnySetupQualifier _) (QualExe _ _) _ = False +constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = pn == pn' +constraintQualifierMatches (ScopeAnySetupQualifier _) (QualBase _) _ = False +constraintQualifierMatches (ScopeAnyExeQualifier pn) (QualExe _ _) pn' = pn == pn' +constraintQualifierMatches (ScopeAnyExeQualifier _) QualToplevel _ = False +constraintQualifierMatches (ScopeAnyExeQualifier _) (QualSetup _) _compile = False +constraintQualifierMatches (ScopeAnyExeQualifier _) (QualBase _) _ = False +constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = pn == pn' instance Pretty ConstraintScope where + pretty (ConstraintScope mstage qualifier) = + maybe mempty pretty mstage <+> pretty qualifier + +instance Pretty ConstraintQualifier where pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn + pretty (ScopeAnyExeQualifier pn) = Disp.text "exe." <<>> pretty pn pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn -- | A package property is a logical predicate on packages. diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 4fc4df25f97..e752c0e6092 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} module Distribution.Solver.Types.PackagePath ( PackagePath(..) - , Namespace(..) , Qualifier(..) , dispQualifier , Qualified(..) @@ -12,31 +13,19 @@ module Distribution.Solver.Types.PackagePath import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageName) -import Distribution.Pretty (pretty, flatStyle) +import Distribution.Pretty (pretty, flatStyle, Pretty) import qualified Text.PrettyPrint as Disp +import Distribution.Solver.Types.Stage (Stage) --- | A package path consists of a namespace and a package path inside that --- namespace. -data PackagePath = PackagePath Namespace Qualifier - deriving (Eq, Ord, Show) +data PackagePath = PackagePath Stage Qualifier + deriving (Eq, Ord, Show, Generic) --- | Top-level namespace --- --- Package choices in different namespaces are considered completely independent --- by the solver. -data Namespace = - -- | The default namespace - DefaultNamespace - - -- | A namespace for a specific build target - | Independent PackageName - deriving (Eq, Ord, Show) - --- | Pretty-prints a namespace. The result is either empty or --- ends in a period, so it can be prepended onto a qualifier. -dispNamespace :: Namespace -> Disp.Doc -dispNamespace DefaultNamespace = Disp.empty -dispNamespace (Independent i) = pretty i <<>> Disp.text "." +instance Binary PackagePath +instance Structured PackagePath + +instance Pretty PackagePath where + pretty (PackagePath stage qualifier) = + pretty stage <<>> Disp.text ":" <<>> pretty qualifier -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = @@ -68,7 +57,17 @@ data Qualifier = -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) | QualExe PackageName PackageName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary Qualifier +instance Structured Qualifier + +instance Pretty Qualifier where + pretty QualToplevel = Disp.text "toplevel" + pretty (QualBase pn) = pretty pn <<>> Disp.text ":base" + pretty (QualSetup pn) = pretty pn <<>> Disp.text ":setup" + pretty (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> + pretty pn2 <<>> Disp.text ":exe" -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. @@ -79,23 +78,32 @@ data Qualifier = -- is the qualifier and @"base"@ is the actual dependency (which, for the -- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc -dispQualifier QualToplevel = Disp.empty -dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." -dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> - pretty pn2 <<>> Disp.text ":exe." -dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." +dispQualifier QualToplevel = mempty +dispQualifier (QualBase pn) = pretty pn <> Disp.text "." +dispQualifier (QualSetup pn) = pretty pn <> Disp.text ":setup." +dispQualifier (QualExe pn pn2) = + pretty pn + <> Disp.text ":" + <> pretty pn2 + <> Disp.text ":exe." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance (Binary a) => Binary (Qualified a) +instance (Structured a) => Structured (Qualified a) -- | Qualified package name. type QPN = Qualified PackageName +instance Pretty (Qualified PackageName) where + pretty (Q (PackagePath stage qual) pn) = + pretty stage <<>> Disp.colon <<>> dispQualifier qual <<>> pretty pn + -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc -dispQPN (Q (PackagePath ns qual) pn) = - dispNamespace ns <<>> dispQualifier qual <<>> pretty pn +dispQPN = pretty -- | String representation of a qualified package name. showQPN :: QPN -> String diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs index d7f9520866b..9458e7ee0b1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.ResolverPackage ( ResolverPackage(..) + , solverId + , solverQPN , resolverPackageLibDeps , resolverPackageExeDeps ) where @@ -12,6 +14,7 @@ import Prelude () import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.PackagePath (QPN) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Compat.Graph (IsNode(..)) @@ -35,6 +38,14 @@ instance Package (ResolverPackage loc) where packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg +solverId :: ResolverPackage loc -> SolverId +solverId (PreExisting ipkg) = PreExistingId (instSolverStage ipkg) (packageId ipkg) (installedUnitId ipkg) +solverId (Configured spkg) = PlannedId (solverPkgStage spkg) (packageId spkg) + +solverQPN :: ResolverPackage loc -> QPN +solverQPN (PreExisting ipkg) = instSolverQPN ipkg +solverQPN (Configured spkg) = solverPkgQPN spkg + resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg @@ -45,8 +56,8 @@ resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg instance IsNode (ResolverPackage loc) where type Key (ResolverPackage loc) = SolverId - nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) - nodeKey (Configured spkg) = PlannedId (packageId spkg) + nodeKey = solverId + -- Use dependencies for ALL components nodeNeighbors pkg = ordNub $ fold (resolverPackageLibDeps pkg) ++ diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs index d32ccc17e74..9afb8bf1338 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -9,14 +9,19 @@ import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageId, Package(..), UnitId) +import Distribution.Pretty (Pretty (..)) +import Distribution.Solver.Types.Stage (Stage) + +import Text.PrettyPrint (colon, punctuate, text) + -- | The solver can produce references to existing packages or -- packages we plan to install. Unlike 'ConfiguredId' we don't -- yet know the 'UnitId' for planned packages, because it's -- not the solver's job to compute them. -- -data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } - | PlannedId { solverSrcId :: PackageId } +data SolverId = PreExistingId { solverStage :: Stage, solverSrcId :: PackageId, solverInstId :: UnitId } + | PlannedId { solverStage :: Stage, solverSrcId :: PackageId } deriving (Eq, Ord, Generic) instance Binary SolverId @@ -27,3 +32,7 @@ instance Show SolverId where instance Package SolverId where packageId = solverSrcId + +instance Pretty SolverId where + pretty (PreExistingId stage pkg unitId) = mconcat $ punctuate colon $ [pretty stage, pretty pkg, text "installed", pretty unitId] + pretty (PlannedId stage pkg) = mconcat $ punctuate colon $ [pretty stage, pretty pkg, text "planned"] \ No newline at end of file diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs index 186f140aefe..f170542ac19 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs @@ -12,6 +12,8 @@ import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage ( Stage ) +import Distribution.Solver.Types.PackagePath ( QPN ) -- | A 'SolverPackage' is a package specified by the dependency solver. -- It will get elaborated into a 'ConfiguredPackage' or even an @@ -21,6 +23,8 @@ import Distribution.Solver.Types.SourcePackage -- but for symmetry we have the parameter. (Maybe it can be removed.) -- data SolverPackage loc = SolverPackage { + solverPkgStage :: Stage, + solverPkgQPN :: QPN, solverPkgSource :: SourcePackage loc, solverPkgFlags :: FlagAssignment, solverPkgStanzas :: OptionalStanzaSet, diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs new file mode 100644 index 00000000000..54880a0491b --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveTraversable #-} + +module Distribution.Solver.Types.Stage + ( Stage (..) + , showStage + , stages + , prevStage + , nextStage + , Staged (..) + , tabulate + , foldMapWithKey + , always + ) where + +import Prelude (Enum (..)) +import Distribution.Compat.Prelude +import qualified Distribution.Compat.CharParsing as P + +import Data.Maybe (fromJust) +import GHC.Stack + +import Distribution.Parsec (Parsec (..)) +import Distribution.Pretty (Pretty (..)) +import Distribution.Utils.Structured (Structured (..)) +import qualified Text.PrettyPrint as Disp + + +data Stage + = -- | -- The system where the build is running + Build + | -- | -- The system where the built artifacts will run + Host + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + +instance Binary Stage +instance Structured Stage +instance NFData Stage + +instance Pretty Stage where + pretty = Disp.text . showStage + +showStage :: Stage -> String +showStage Build = "build" +showStage Host = "host" + +instance Parsec Stage where + parsec = P.choice [ + Build <$ P.string "build", + Host <$ P.string "host" + ] + +stages :: [Stage] +stages = [minBound .. maxBound] + +prevStage :: Stage -> Stage +prevStage s | s == minBound = s + | otherwise = Prelude.pred s +nextStage :: Stage -> Stage +nextStage s | s == maxBound = s + | otherwise = Prelude.succ s + +-- TOOD: I think there is similar code for stanzas, compare. + +newtype Staged a = Staged + { getStage :: Stage -> a + } + deriving (Functor, Generic) + deriving Applicative via ((->) Stage) + +instance Eq a => Eq (Staged a) where + lhs == rhs = + all + (\stage -> getStage lhs stage == getStage rhs stage) + [minBound .. maxBound] + +instance Show a => Show (Staged a) where + showsPrec _ staged = + showList + [ (stage, getStage staged stage) + | stage <- [minBound .. maxBound] + ] + +instance Foldable Staged where + foldMap f (Staged gs) = foldMap (f . gs) [minBound..maxBound] + +instance Traversable Staged where + traverse f = fmap index . traverse (traverse f) . tabulate + +instance Binary a => Binary (Staged a) where + put staged = put (tabulate staged) + -- TODO this could be done better I think + get = index <$> get + +-- TODO: I have no idea if this is right +instance (Typeable a, Structured a) => Structured (Staged a) where + structure _ = structure (Proxy :: Proxy [(Stage, a)]) + +tabulate :: Staged a -> [(Stage, a)] +tabulate staged = + [ (stage, getStage staged stage) + | stage <- [minBound .. maxBound] + ] + +index :: HasCallStack => [(Stage, a)] -> Staged a +index t = Staged (\s -> fromJust (lookup s t)) + +foldMapWithKey :: Monoid m => (Stage -> a -> m) -> Staged a -> m +foldMapWithKey f = foldMap (uncurry f) . tabulate + +always :: a -> Staged a +always = Staged . const diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs new file mode 100644 index 00000000000..6ee663795f4 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Solver.Types.Toolchain + ( Toolchain (..) + , Toolchains + , Stage (..) + , Staged (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Compiler +import Distribution.Simple.Program.Db +import Distribution.Solver.Types.Stage (getStage, Stage (..), Staged (..)) +import Distribution.System + +--------------------------- +-- Toolchain +-- + +data Toolchain = Toolchain + { toolchainPlatform :: Platform + , toolchainCompiler :: Compiler + , toolchainProgramDb :: ProgramDb + -- NOTE: actually the solver does not care about package dbs, perhaps it's better + -- to have a separate Toolchain type for project planning. + , toolchainPackageDBs :: PackageDBStackCWD + } + deriving (Show, Generic) + +-- TODO: review this +instance Eq Toolchain where + lhs == rhs = + (((==) `on` toolchainPlatform) lhs rhs) + && (((==) `on` toolchainCompiler) lhs rhs) + && ((((==)) `on` (configuredPrograms . toolchainProgramDb)) lhs rhs) + +instance Binary Toolchain +instance Structured Toolchain + +type Toolchains = Staged Toolchain diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index eeae37f45d5..afc02f636ad 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -194,6 +194,7 @@ library Distribution.Client.ProjectPlanOutput Distribution.Client.ProjectPlanning Distribution.Client.ProjectPlanning.SetupPolicy + Distribution.Client.ProjectPlanning.Stage Distribution.Client.ProjectPlanning.Types Distribution.Client.RebuildMonad Distribution.Client.Reconfigure @@ -216,12 +217,14 @@ library Distribution.Client.TargetProblem Distribution.Client.TargetSelector Distribution.Client.Targets + Distribution.Client.Toolchain Distribution.Client.Types Distribution.Client.Types.AllowNewer Distribution.Client.Types.BuildResults Distribution.Client.Types.ConfiguredId Distribution.Client.Types.ConfiguredPackage Distribution.Client.Types.Credentials + Distribution.Client.Types.GenericReadyPackage Distribution.Client.Types.InstallMethod Distribution.Client.Types.OverwritePolicy Distribution.Client.Types.PackageLocation diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 34b65edcb5e..7079f2119b9 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -180,6 +180,7 @@ testProjectConfigShared = do assertConfigEquals expected config legacy (projectConfigShared . snd . condTreeData) where expected = ProjectConfigShared{..} + projectConfigToolchain = ProjectConfigToolchain{..} projectConfigDistDir = toFlag "something" projectConfigConfigFile = mempty -- cli only projectConfigProjectFileParser = mempty -- cli only @@ -189,9 +190,13 @@ testProjectConfigShared = do projectConfigHcFlavor = toFlag GHCJS projectConfigHcPath = toFlag "/some/path/to/compiler" projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg" + projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] + projectConfigBuildHcFlavor = toFlag GHCJS + projectConfigBuildHcPath = toFlag "/some/path/to/compiler" + projectConfigBuildHcPkg = toFlag "/some/path/to/ghc-pkg" + projectConfigBuildPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index" projectConfigInstallDirs = mempty -- tested below in testInstallDirs - projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] projectConfigRemoteRepos = mempty -- tested below in testRemoteRepos projectConfigLocalNoIndexRepos = mempty -- tested below in testLocalNoIndexRepos projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge, ActiveRepo (RepoName "my-repository") CombineStrategyOverride]) diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs index f9adc80432b..177b8263a1a 100644 --- a/cabal-install/src/Distribution/Client/CmdBench.hs +++ b/cabal-install/src/Distribution/Client/CmdBench.hs @@ -50,6 +50,9 @@ import Distribution.Simple.Utils , warn , wrapText ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( normal ) @@ -133,11 +136,13 @@ benchAction flags targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBench - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBench + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index 7314187b815..b8ca8a3dfd2 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | cabal-install CLI command: build module Distribution.Client.CmdBuild ( -- * The @build@ CLI and action @@ -26,6 +28,7 @@ import Distribution.Client.TargetProblem import qualified Data.Map as Map import Distribution.Client.Errors +import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.NixStyleOptions ( NixStyleFlags (..) , cfgVerbosity @@ -52,6 +55,7 @@ import Distribution.Simple.Utils ( dieWithException , wrapText ) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Verbosity ( normal ) @@ -161,18 +165,20 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags} targetStrings globalFla Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - targetAction - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + targetAction + targets + elaboratedPlan + elaboratedPlan'' <- if buildSettingOnlyDeps (buildSettings baseCtx) - then - either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies - (Map.keysSet targets) - elaboratedPlan' + then case pruneInstallPlanToDependencies (Map.keysSet targets) elaboratedPlan' of + Left err -> + reportCannotPruneDependencies verbosity err + Right elaboratedPlan'' -> + runLogProgress verbosity $ InstallPlan.new' elaboratedPlan'' else return elaboratedPlan' return (elaboratedPlan'', targets) diff --git a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs index 7eece5701f5..8f9bf63c1ba 100644 --- a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs @@ -501,7 +501,7 @@ renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = where -- throw away the details and just list the deps that are needed pkgids :: [PackageId] - pkgids = nub . map packageId . concatMap snd $ brokenPackages + pkgids = nub . map packageId . concatMap (NE.toList . snd) $ brokenPackages {- ++ "Syntax:\n" diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index f750e439341..ac5bdd5ab1b 100644 --- a/cabal-install/src/Distribution/Client/CmdExec.hs +++ b/cabal-install/src/Distribution/Client/CmdExec.hs @@ -1,6 +1,9 @@ ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} -- | -- Module : Distribution.Client.Exec @@ -56,7 +59,8 @@ import Distribution.Client.ProjectPlanning ) import qualified Distribution.Client.ProjectPlanning as Planning import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan + ( Toolchain (..) + , dataDirsEnvironmentForPlan ) import Distribution.Client.Setup ( GlobalFlags @@ -104,6 +108,7 @@ import Prelude () import qualified Data.Map as M import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Solver.Types.Stage execCommand :: CommandUI (NixStyleFlags ()) execCommand = @@ -152,6 +157,12 @@ execAction flags extraArgs globalFlags = do baseCtx (\plan -> return (plan, M.empty)) + let toolchains = pkgConfigToolchains (elaboratedShared buildCtx) + -- We need the compiler and platform to set up the environment. + compilers = toolchainCompiler <$> toolchains + platforms = toolchainPlatform <$> toolchains + progdbs = toolchainProgramDb <$> toolchains + -- We use the build status below to decide what libraries to include in the -- compiler environment, but we don't want to actually build anything. So we -- pass mempty to indicate that nothing happened and we just want the current @@ -166,7 +177,9 @@ execAction flags extraArgs globalFlags = do -- Some dependencies may have executables. Let's put those on the PATH. let extraPaths = pathAdditions baseCtx buildCtx - pkgProgs = pkgConfigCompilerProgs (elaboratedShared buildCtx) + -- NOTE: only build-stage dependencies make sense here + pkgProgs = getStage progdbs Build + -- extraEnvVars = dataDirsEnvironmentForPlan (distDirLayout baseCtx) @@ -181,7 +194,8 @@ execAction flags extraArgs globalFlags = do -- point at the file. -- In case ghc is too old to support environment files, -- we pass the same info as arguments - let compiler = pkgConfigCompiler $ elaboratedShared buildCtx + -- FIXME + let compiler = getStage compilers Host envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) case extraArgs of [] -> dieWithException verbosity SpecifyAnExecutable @@ -234,7 +248,9 @@ matchCompilerPath elaboratedShared program = programPath program `elem` (programPath <$> configuredCompilers) where - configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared + progdbs = toolchainProgramDb <$> pkgConfigToolchains elaboratedShared + -- FIXME + configuredCompilers = configuredPrograms (getStage progdbs Host) -- | Execute an action with a temporary .ghc.environment file reflecting the -- current environment. The action takes an environment containing the env diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index 2f4ddaac8b4..eb799324f7c 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -30,7 +30,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) , UserQualifier (..) ) import Distribution.Solver.Types.ConstraintSource diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index 6e47fcd6a9c..6188ef3d46a 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -18,7 +18,6 @@ import Control.Monad (mapM_) import Distribution.Client.Errors import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets) -import Distribution.Client.ProjectPlanning.Types import Distribution.Client.Types.ConfiguredId (confInstId) import Distribution.Client.Utils hiding (pvpize) import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId) @@ -28,6 +27,7 @@ import Distribution.Simple.Utils import Distribution.Version import Distribution.Client.Setup (GlobalFlags (..)) +import Distribution.Utils.LogProgress (runLogProgress) -- Project orchestration imports @@ -39,6 +39,7 @@ import Distribution.Client.ProjectFlags import Distribution.Client.ProjectOrchestration import Distribution.Client.ScriptUtils import Distribution.Client.TargetProblem +import qualified Distribution.Compat.Graph as Graph import Distribution.Simple.Command import Distribution.Types.Component import Distribution.Verbosity @@ -114,11 +115,12 @@ genBoundsAction flags targetStrings globalFlags = targetSelectors -- Step 3: Prune the install plan to the targets. - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan let -- Step 4a: Find the local packages from the install plan. These are the @@ -130,8 +132,8 @@ genBoundsAction flags targetStrings globalFlags = pkgVersionMap :: Map.Map ComponentId PackageIdentifier pkgVersionMap = Map.fromList (map (InstallPlan.foldPlanPackage externalVersion localVersion) (InstallPlan.toList elaboratedPlan')) - externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier) - externalVersion pkg = (installedComponentId pkg, packageId pkg) + externalVersion :: WithStage InstalledPackageInfo -> (ComponentId, PackageIdentifier) + externalVersion (WithStage _stage pkg) = (installedComponentId pkg, packageId pkg) localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier) localVersion pkg = (elabComponentId pkg, packageId pkg) @@ -139,7 +141,7 @@ genBoundsAction flags targetStrings globalFlags = let genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult] genBoundsActionForPkg pkg = -- Step 5: Match up the user specified targets with the local packages. - case Map.lookup (installedUnitId pkg) targets of + case Map.lookup (Graph.nodeKey pkg) targets of Nothing -> [] Just tgts -> map (\(tgt, _) -> getBoundsForComponent tgt pkg pkgVersionMap) tgts @@ -188,7 +190,8 @@ getBoundsForComponent tgt pkg pkgVersionMap = let componentDeps = elabLibDependencies pkg -- Match these up to package names, this is a list of Package name to versions. -- Now just match that up with what the user wrote in the build-depends section. - depsWithVersions = mapMaybe (\cid -> Map.lookup (confInstId $ fst cid) pkgVersionMap) componentDeps + -- FIXME: I am not quite sure how this is supposed to work + depsWithVersions = mapMaybe (\(WithStage _stage cid, _) -> Map.lookup (confInstId cid) pkgVersionMap) componentDeps isNeeded = hasElem needBounds . packageName in boundsResult (Just (filter isNeeded depsWithVersions)) where diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index f9be5763b3b..d741211f286 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -29,8 +30,12 @@ import Distribution.Client.ProjectConfig.Types , ProjectConfig (..) ) import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types ( ElaboratedSharedConfig (..) + , Stage (..) + , Staged (..) + , Toolchain (..) + , getStage ) import Distribution.Client.Setup ( GlobalFlags @@ -70,6 +75,7 @@ import Distribution.Verbosity ) import Distribution.Client.Errors +import Distribution.Utils.LogProgress (runLogProgress) import qualified System.Exit (exitSuccess) newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool} @@ -160,6 +166,7 @@ haddockAction relFlags targetStrings globalFlags = do projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}} | otherwise = projCtx + absProjectConfig <- mkConfigAbsolute relProjectConfig let baseCtx = relBaseCtx{projectConfig = absProjectConfig} @@ -183,15 +190,20 @@ haddockAction relFlags targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionHaddock - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionHaddock + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx + let toolchains = pkgConfigToolchains (elaboratedShared buildCtx) + + -- TODO progs <- reconfigurePrograms verbosity @@ -200,14 +212,19 @@ haddockAction relFlags targetStrings globalFlags = do -- we need to insert 'haddockProgram' before we reconfigure it, -- otherwise 'set . addKnownProgram haddockProgram - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx + -- TODO + . toolchainProgramDb + $ getStage toolchains Host + + let toolchains' = Staged $ \case + Host -> (getStage toolchains' Host){toolchainProgramDb = progs} + Build -> getStage toolchains' Build + let buildCtx' = buildCtx { elaboratedShared = (elaboratedShared buildCtx) - { pkgConfigCompilerProgs = progs + { pkgConfigToolchains = toolchains' } } diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index 247eb3e2bd4..c191171891e 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -35,11 +35,13 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan + , ElaboratedInstalledPackageInfo , ElaboratedSharedConfig (..) , TargetAction (..) - ) -import Distribution.Client.ProjectPlanning.Types - ( elabDistDirParams + , Toolchain (..) + , WithStage (..) + , elabDistDirParams + , getStage ) import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) @@ -71,18 +73,11 @@ import Distribution.Simple.Flag , pattern Flag , pattern NoFlag ) -import Distribution.Simple.Haddock (createHaddockIndex) + +-- import Distribution.Simple.Haddock (createHaddockIndex) import Distribution.Simple.InstallDirs ( toPathTemplate ) -import Distribution.Simple.Program.Builtin - ( haddockProgram - ) -import Distribution.Simple.Program.Db - ( addKnownProgram - , reconfigurePrograms - , requireProgramVersion - ) import Distribution.Simple.Setup ( HaddockFlags (..) , HaddockProjectFlags (..) @@ -103,8 +98,7 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su import Distribution.Types.PackageId (pkgName) import Distribution.Types.PackageName (unPackageName) import Distribution.Types.UnitId (unUnitId) -import Distribution.Types.Version (mkVersion) -import Distribution.Types.VersionRange (orLaterVersion) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Verbosity as Verbosity ( defaultVerbosityHandles , mkVerbosity @@ -156,11 +150,12 @@ haddockProjectAction flags _extraArgs globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan return (elaboratedPlan', targets) let elaboratedPlan :: ElaboratedInstallPlan @@ -169,27 +164,29 @@ haddockProjectAction flags _extraArgs globalFlags = do sharedConfig :: ElaboratedSharedConfig sharedConfig = elaboratedShared buildCtx - pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage] + pkgs :: [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage] pkgs = matchingPackages elaboratedPlan - progs <- - reconfigurePrograms - verbosity - (haddockProjectProgramPaths flags) - (haddockProjectProgramArgs flags) - -- we need to insert 'haddockProgram' before we reconfigure it, - -- otherwise 'set - . addKnownProgram haddockProgram - . pkgConfigCompilerProgs - $ sharedConfig - let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs} - - _ <- - requireProgramVersion - verbosity - haddockProgram - (orLaterVersion (mkVersion [2, 26, 1])) - progs + -- TODO + -- progs <- + -- reconfigurePrograms + -- verbosity + -- (haddockProjectProgramPaths flags) + -- (haddockProjectProgramArgs flags) + -- -- we need to insert 'haddockProgram' before we reconfigure it, + -- -- otherwise 'set + -- . addKnownProgram haddockProgram + -- . pkgConfigCompilerProgs + -- $ sharedConfig + -- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs} + let sharedConfig' = sharedConfig + + -- _ <- + -- requireProgramVersion + -- verbosity + -- haddockProgram + -- (orLaterVersion (mkVersion [2, 26, 1])) + -- progs -- -- Build project; we need to build dependencies. @@ -217,7 +214,7 @@ haddockProjectAction flags _extraArgs globalFlags = do packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg -> case pkg of - Left package | localStyle -> do + Left (WithStage _ package) | localStyle -> do let packageName = unPackageName (pkgName $ sourcePackageId package) destDir = outputDir packageName fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do @@ -304,10 +301,12 @@ haddockProjectAction flags _extraArgs globalFlags = do False -> do let pkg_descr = elabPkgDescription package unitId = unUnitId (elabUnitId package) + compilers = toolchainCompiler <$> pkgConfigToolchains sharedConfig' + compiler = getStage compilers (elabStage package) packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) - (pkgConfigCompiler sharedConfig') + compiler (elabUnitId package) -- TODO: use `InstallDirTemplates` docDir = packageDir "share" "doc" "html" @@ -327,8 +326,8 @@ haddockProjectAction flags _extraArgs globalFlags = do -- generate index, content, etc. -- - let (missingHaddocks, packageInfos') = partitionEithers packageInfos - unless (null missingHaddocks) $ do + let (missingHaddocks, _packageInfos') = partitionEithers packageInfos + when (not (null missingHaddocks)) $ do warn verbosity "missing haddocks for some packages from the store" -- Show the package list if `-v1` is passed; it's usually a long list. -- One needs to add `package` stantza in `cabal.project` file for @@ -336,28 +335,31 @@ haddockProjectAction flags _extraArgs globalFlags = do -- `documentation: True` in the global config). info verbosity (intercalate "\n" missingHaddocks) - let flags' = - flags - { haddockProjectDir = Flag outputDir - , haddockProjectInterfaces = - Flag - [ ( interfacePath - , Just url - , Just url - , visibility - ) - | (url, interfacePath, visibility) <- packageInfos' - ] - , haddockProjectUseUnicode = NoFlag - } - createHaddockIndex - verbosity - (pkgConfigCompilerProgs sharedConfig') - (pkgConfigCompiler sharedConfig') - (pkgConfigPlatform sharedConfig') - Nothing - flags' + warn verbosity "createHaddockIndex not implemented" where + -- let flags' = + -- flags + -- { haddockProjectDir = Flag outputDir + -- , haddockProjectInterfaces = + -- Flag + -- [ ( interfacePath + -- , Just url + -- , Just url + -- , visibility + -- ) + -- | (url, interfacePath, visibility) <- packageInfos' + -- ] + -- , haddockProjectUseUnicode = NoFlag + -- } + -- -- NOTE: this lives in Cabal + -- createHaddockIndex + -- verbosity + -- (toolchainProgramDb $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- (toolchainPlatform $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- Nothing + -- flags' + -- build all packages with appropriate haddock flags commonFlags = haddockProjectCommonFlags flags @@ -446,7 +448,7 @@ haddockProjectAction flags _extraArgs globalFlags = do matchingPackages :: ElaboratedInstallPlan - -> [Either InstalledPackageInfo ElaboratedConfiguredPackage] + -> [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage] matchingPackages = fmap (foldPlanPackage Left Right) . InstallPlan.toList diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 3884bb056e9..e06d51ca1e0 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -65,7 +65,8 @@ import Distribution.Client.NixStyleOptions , nixStyleOptions ) import Distribution.Client.ProjectConfig - ( ProjectPackageLocation (..) + ( ProjectConfigToolchain (..) + , ProjectPackageLocation (..) , fetchAndReadSourcePackages , projectConfigWithBuilderRepoContext , resolveBuildTimeSettings @@ -87,10 +88,10 @@ import Distribution.Client.ProjectConfig.Types ) import Distribution.Client.ProjectFlags (ProjectFlags (..)) import Distribution.Client.ProjectPlanning - ( storePackageInstallDirs' - ) -import Distribution.Client.ProjectPlanning.Types ( ElaboratedInstallPlan + , ElaboratedPlanPackage + , Stage (..) + , storePackageInstallDirs' ) import Distribution.Client.RebuildMonad ( runRebuild @@ -111,6 +112,7 @@ import Distribution.Client.Types import Distribution.Client.Types.OverwritePolicy ( OverwritePolicy (..) ) +import qualified Distribution.Compat.Graph as Graph import Distribution.Package ( Package (..) , PackageName @@ -213,6 +215,9 @@ import Distribution.Types.VersionRange import Distribution.Utils.Generic ( writeFileAtomic ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( lessVerbose , modifyVerbosityFlags @@ -410,12 +415,15 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project } , projectConfigShared = ProjectConfigShared - { projectConfigHcFlavor - , projectConfigHcPath - , projectConfigHcPkg + { projectConfigToolchain = + ProjectConfigToolchain + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigPackageDBs + } , projectConfigStoreDir , projectConfigProgPathExtra - , projectConfigPackageDBs } , projectConfigLocalPackages = PackageConfig @@ -468,7 +476,6 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project fetchAndReadSourcePackages verbosity distDirLayout - (Just compiler) (projectConfigShared config) (projectConfigBuildOnly config) [ProjectPackageRemoteTarball uri | uri <- uris] @@ -559,7 +566,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project traverseInstall action cfg@InstallCfg{verbosity = v, buildCtx, installClientFlags} = do let overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy installClientFlags actionOnExe <- action v overwritePolicy <$> prepareExeInstall cfg - traverse_ actionOnExe . Map.toList $ targetsMap buildCtx + traverse_ actionOnExe . Map.toList $ filterTargetsWithStage Host $ targetsMap buildCtx withProject :: Verbosity @@ -778,7 +785,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector localPkgs = sdistize <$> localPackages baseCtx - gatherTargets :: UnitId -> TargetSelector + gatherTargets :: Graph.Key ElaboratedPlanPackage -> TargetSelector gatherTargets targetId = TargetPackageNamed pkgName targetFilter where targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap @@ -823,7 +830,7 @@ partitionToKnownTargetsAndHackagePackages -> SourcePackageDb -> ElaboratedInstallPlan -> [TargetSelector] - -> IO (TargetsMap, [PackageName]) + -> IO (TargetsMapS, [PackageName]) partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do let mTargets = resolveTargetsFromSolver @@ -893,15 +900,18 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do Nothing targetSelectors - let prunedToTargetsElaboratedPlan = - pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + prunedToTargetsElaboratedPlan <- + runLogProgress verbosity $ + pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + prunedElaboratedPlan <- if buildSettingOnlyDeps (buildSettings baseCtx) - then - either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies - (Map.keysSet targets) - prunedToTargetsElaboratedPlan + then do + case pruneInstallPlanToDependencies (Map.keysSet targets) prunedToTargetsElaboratedPlan of + Left err -> + reportCannotPruneDependencies verbosity err + Right elaboratedPlan'' -> + runLogProgress verbosity $ InstallPlan.new' elaboratedPlan'' else return prunedToTargetsElaboratedPlan return (prunedElaboratedPlan, targets) @@ -999,7 +1009,7 @@ installLibraries ordNub $ globalEntries ++ envEntries - ++ entriesForLibraryComponents (targetsMap buildCtx) + ++ entriesForLibraryComponents (filterTargetsWithStage Host $ targetsMap buildCtx) contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) createDirectoryIfMissing True (takeDirectory envFile) writeFileAtomic envFile (BS.pack contents') diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 5e13515c960..31ac72dad98 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -48,7 +48,6 @@ import Distribution.Client.TargetProblem (TargetProblem (..)) import Distribution.Simple.BuildPaths (dllExtension, exeExtension) import Distribution.Simple.Command (CommandUI (..)) import Distribution.Simple.Utils (dieWithException, withOutputMarker, wrapText) -import Distribution.System (Platform) import Distribution.Types.ComponentName (showComponentName) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName) @@ -61,6 +60,7 @@ import Distribution.Client.Errors import qualified Distribution.Client.InstallPlan as IP import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Utils.LogProgress (runLogProgress) ------------------------------------------------------------------------------- -- Command @@ -128,11 +128,13 @@ listbinAction flags args globalFlags = do ) targets - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) (selectedUnitId, selectedComponent) <- @@ -204,8 +206,8 @@ listbinAction flags args globalFlags = do | s == selectedComponent -> [flib_file' s] _ -> [] - plat :: Platform - plat = pkgConfigPlatform elaboratedSharedConfig + Toolchain{toolchainPlatform = plat} = + getStage (pkgConfigToolchains elaboratedSharedConfig) (elabStage elab) -- here and in PlanOutput, -- use binDirectoryFor? @@ -225,7 +227,7 @@ listbinAction flags args globalFlags = do -- Target Problem: the very similar to CmdRun ------------------------------------------------------------------------------- -singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleComponentOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName) singleComponentOrElse action targetsMap = case Set.toList . distinctTargetComponents $ targetsMap of [(unitId, CExeName component)] -> return (unitId, component) @@ -317,7 +319,7 @@ data ListBinProblem | -- | A single 'TargetSelector' matches multiple targets TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets TargetsMap + TargetProblemMultipleTargets TargetsMapS | -- | The 'TargetSelector' refers to a component that is not an executable TargetProblemComponentNotRightKind PackageId ComponentName | -- | Asking to run an individual file or module is not supported @@ -334,7 +336,7 @@ matchesMultipleProblem selector targets = CustomTargetProblem $ TargetProblemMatchesMultiple selector targets -multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem +multipleTargetsProblem :: TargetsMapS -> TargetProblem ListBinProblem multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index 6307cc30c64..12aadd25634 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module : Distribution.Client.CmdPath @@ -76,6 +77,7 @@ import Distribution.Simple.Program import Distribution.Simple.Utils ( die' , dieWithException + , warn , withOutputMarker , wrapText ) @@ -245,17 +247,13 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF if not $ fromFlagOrDefault False (pathCompiler pathFlags) then pure Nothing else do - (compiler, _, progDb) <- - runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ - configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) - compilerProg <- requireCompilerProg verbosity compiler - (configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb - - let compilerInfo' = - mkCompilerInfo configuredCompilerProg compiler $ - cabalStoreDirLayout (cabalDirLayout baseCtx) - - pure $ Just compilerInfo' + let projectRoot = distProjectRootDirectory (distDirLayout baseCtx) + toolchains <- runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (projectConfig baseCtx) + warn verbosity "WIP: Assuming host toolchain, result might be wrong" + let Toolchain{..} = getStage toolchains Host + compilerProg <- requireCompilerProg verbosity toolchainCompiler + (configuredCompilerProg, _) <- requireProgram verbosity compilerProg toolchainProgramDb + pure $ Just $ mkCompilerInfo configuredCompilerProg toolchainCompiler (cabalStoreDirLayout $ cabalDirLayout baseCtx) paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do t <- getPathLocation verbosity baseCtx p diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 940237200ea..ac00434a8b8 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -26,7 +26,8 @@ import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L import Distribution.Client.CmdErrorMessages - ( Plural (..) + ( ComponentKind (..) + , Plural (..) , componentKind , renderComponentKind , renderListCommaAnd @@ -56,9 +57,13 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedInstallPlan , ElaboratedSharedConfig (..) + , Stage (..) + , WithStage + , getStage ) import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies + ( Toolchain (..) + , elabOrderExeDependencies , showElaboratedInstallPlan ) import Distribution.Client.ScriptUtils @@ -81,7 +86,7 @@ import Distribution.Client.TargetProblem ) import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) ) import Distribution.Client.Types ( PackageSpecifier (..) @@ -93,7 +98,6 @@ import Distribution.Compiler import Distribution.Package ( Package (..) , UnitId - , installedUnitId , mkPackageName , packageName ) @@ -158,6 +162,9 @@ import Distribution.Types.VersionRange import Distribution.Utils.Generic ( safeHead ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( lessVerbose , modifyVerbosityFlags @@ -185,11 +192,12 @@ import Distribution.Client.ReplFlags , topReplOptions ) import Distribution.Compat.Binary (decode) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Types.PackageName.Magic (fakePackageId) import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag) import Distribution.Simple.Program.Builtin (ghcProgram) import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Program.Types -import Distribution.Types.PackageName.Magic (fakePackageId) import System.Directory ( doesFileExist , getCurrentDirectory @@ -443,13 +451,14 @@ targetedRepl -- especially in the no-project case. withInstallPlan (modifyVerbosityFlags lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets' (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors - + let Toolchain{toolchainCompiler = compiler} = getStage (pkgConfigToolchains sharedConfig) Build + -- FIXME there is total confusion here about who is filtering for the stage + targets <- validatedTargets (projectConfigShared (projectConfig ctx)) compiler elaboratedPlan targetSelectors let - (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets - originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId - oci = OriginalComponentInfo unitId originalDeps - pkgId = maybe (error $ "cannot find " ++ prettyShow unitId) packageId (InstallPlan.lookup elaboratedPlan unitId) + (key, _uid) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets + originalDeps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan key + oci = OriginalComponentInfo key originalDeps + pkgId = fromMaybe (error $ "cannot find " ++ prettyShow key) $ packageId <$> InstallPlan.lookup elaboratedPlan key baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx' return (Just oci, baseCtx'') @@ -462,25 +471,23 @@ targetedRepl -- In addition, to avoid a *third* trip through the solver, we are -- replicating the second half of 'runProjectPreBuildPhase' by hand -- here. - (buildCtx, compiler, platform, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ + (buildCtx, compiler, progdb, platform, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ \elaboratedPlan elaboratedShared' -> do let ProjectBaseContext{..} = baseCtx'' + -- TODO: This mightr not make sense + Toolchain{..} = getStage (pkgConfigToolchains elaboratedShared') Host -- Recalculate with updated project. - targets <- validatedTargets' (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors + targets <- validatedTargets (projectConfigShared projectConfig) toolchainCompiler elaboratedPlan targetSelectors - let - elaboratedPlan' = - -- Guard against pruning with empty targets and failing an assertion - -- within pruneInstallPlanToTargets. - if null targets - then elaboratedPlan - else - pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + + let includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) pkgsBuildStatus <- rebuildTargetsDryRun @@ -504,13 +511,11 @@ targetedRepl , targetsMap = targets } - ElaboratedSharedConfig{pkgConfigCompiler = compiler, pkgConfigPlatform = platform} = elaboratedShared' - repl_flags = case originalComponent of Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci Nothing -> [] - return (buildCtx, compiler, platform, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) + return (buildCtx, toolchainCompiler, toolchainProgramDb, toolchainPlatform, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) -- Multi Repl implementation see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for -- a high-level overview about how everything fits together. @@ -545,7 +550,7 @@ targetedRepl -- HACK: Just combine together all env overrides, placing the most common things last -- ghc program with overridden PATH - (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) + (ghcProg, _) <- requireProgram verbosity ghcProgram progdb let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]} -- Find what the unit files are, and start a repl based on all the response @@ -598,19 +603,41 @@ targetedRepl buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes - where - projectRoot = distProjectRootDirectory $ distDirLayout ctx - distDir = distDirectory $ distDirLayout ctx + where + combine_search_paths paths = + foldl' go Map.empty paths + where + go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s) + go m _ = m + + projectRoot = distProjectRootDirectory $ distDirLayout ctx + distDir = distDirectory $ distDirLayout ctx + verbosity = cfgVerbosity normal flags + tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags + + -- FIXME: the compiler depends on the stage!! + validatedTargets ctx compiler elaboratedPlan targetSelectors = do + let multi_repl_enabled = multiReplDecision ctx compiler replFlags + -- Interpret the targets on the command line as repl targets + -- (as opposed to say build or haddock targets). + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargetsFromSolver + (selectPackageTargets multi_repl_enabled) + selectComponentTarget + elaboratedPlan' + Nothing + selectors - combine_search_paths paths = - foldl' go Map.empty paths - where - go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s) - go m _ = m + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $ + reportTargetProblems + verbosity + [multipleTargetsProblem multi_repl_enabled targets] - verbosity = cfgVerbosity normal flags - tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags - validatedTargets' = validatedTargets verbosity replFlags + return targets withCtx :: NixStyleFlags a -> [String] -> GlobalFlags -> TargetsAction [TargetSelector] b -> IO b withCtx flags targetStrings globalFlags = @@ -673,7 +700,7 @@ validatedTargets -> Compiler -> ElaboratedInstallPlan -> [TargetSelector] - -> IO TargetsMap + -> IO TargetsMapS validatedTargets verbosity replFlags ctx compiler elaboratedPlan targetSelectors = do let multi_repl_enabled = multiReplDecision ctx compiler replFlags -- Interpret the targets on the command line as repl targets (as opposed to @@ -702,8 +729,8 @@ minMultipleHomeUnitsVersion :: Version minMultipleHomeUnitsVersion = mkVersion [9, 4] data OriginalComponentInfo = OriginalComponentInfo - { ociUnitId :: UnitId - , ociOriginalDeps :: [UnitId] + { ociUnitId :: WithStage UnitId + , ociOriginalDeps :: [WithStage UnitId] } deriving (Show) @@ -738,18 +765,25 @@ addDepsToProjectTarget deps pkgId ctx = generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String] generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags where - exeDeps :: [UnitId] + exeDeps :: [WithStage UnitId] exeDeps = foldMap (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies) (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId]) - deps, deps', trans, trans' :: [UnitId] - flags :: [String] - deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId + deps :: [WithStage UnitId] + deps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan ociUnitId + + deps' :: [WithStage UnitId] deps' = deps \\ ociOriginalDeps - trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' + + trans :: [WithStage UnitId] + trans = Graph.nodeKey <$> InstallPlan.dependencyClosure elaboratedPlan deps' + + trans' :: [WithStage UnitId] trans' = trans \\ ociOriginalDeps + + flags :: [String] flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $ if includeTransitive then trans' else deps' @@ -894,7 +928,7 @@ selectComponentTarget = selectComponentTargetBasic data ReplProblem = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets MultiReplDecision TargetsMap + TargetProblemMultipleTargets MultiReplDecision TargetsMapS deriving (Eq, Show) -- | The various error conditions that can occur when matching a @@ -911,7 +945,7 @@ matchesMultipleProblem decision targetSelector targetsExesBuildable = multipleTargetsProblem :: MultiReplDecision - -> TargetsMap + -> TargetsMapS -> ReplTargetProblem multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 6de25f0d2e9..8d0be986894 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -54,6 +54,7 @@ import qualified Distribution.Client.ProjectOrchestration as Orchestration (targ import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan + , WithStage (..) , binDirectoryFor ) import Distribution.Client.ProjectPlanning.Types @@ -123,6 +124,7 @@ import Distribution.Types.UnqualComponentName ( UnqualComponentName , unUnqualComponentName ) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Utils.NubList ( fromNubList ) @@ -245,11 +247,13 @@ runAction flags targetAndArgs globalFlags = do ) targets - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) (selectedUnitId, selectedComponent) <- @@ -437,7 +441,7 @@ handleShebang :: FilePath -> [String] -> IO () handleShebang script args = runAction (commandDefaultFlags runCommand) (script : args) defaultGlobalFlags -singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleExeOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName) singleExeOrElse action targetsMap = case Set.toList . distinctTargetComponents $ targetsMap of [(unitId, CExeName component)] -> return (unitId, component) @@ -449,19 +453,20 @@ singleExeOrElse action targetsMap = -- 'ElaboratedConfiguredPackage's that match the specified -- 'UnitId'. matchingPackagesByUnitId - :: UnitId + :: WithStage UnitId -> ElaboratedInstallPlan -> [ElaboratedConfiguredPackage] -matchingPackagesByUnitId uid = - mapMaybe - ( foldPlanPackage - (const Nothing) - ( \x -> - if elabUnitId x == uid - then Just x - else Nothing - ) - ) +matchingPackagesByUnitId (WithStage s uid) = + catMaybes + . fmap + ( foldPlanPackage + (const Nothing) + ( \x -> + if elabUnitId x == uid && elabStage x == s + then Just x + else Nothing + ) + ) . toList -- | This defines what a 'TargetSelector' means for the @run@ command. @@ -546,7 +551,7 @@ data RunProblem | -- | A single 'TargetSelector' matches multiple targets TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets TargetsMap + TargetProblemMultipleTargets TargetsMapS | -- | The 'TargetSelector' refers to a component that is not an executable TargetProblemComponentNotExe PackageId ComponentName | -- | Asking to run an individual file or module is not supported @@ -563,7 +568,7 @@ matchesMultipleProblem selector targets = CustomTargetProblem $ TargetProblemMatchesMultiple selector targets -multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem +multipleTargetsProblem :: TargetsMapS -> TargetProblem RunProblem multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs index b5e332ceaeb..9d05bba076b 100644 --- a/cabal-install/src/Distribution/Client/CmdTarget.hs +++ b/cabal-install/src/Distribution/Client/CmdTarget.hs @@ -172,7 +172,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors localPackages Nothing targetStrings - targets :: TargetsMap <- + targets <- either (reportBuildTargetProblems verbosity) return $ resolveTargetsFromSolver selectPackageTargets @@ -196,7 +196,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a reportBuildTargetProblems verbosity = reportTargetProblems verbosity "target" -printTargetForms :: Verbosity -> [String] -> TargetsMap -> ElaboratedInstallPlan -> IO () +printTargetForms :: Verbosity -> [String] -> TargetsMapS -> ElaboratedInstallPlan -> IO () printTargetForms verbosity targetStrings targets elaboratedPlan = noticeDoc verbosity $ vcat @@ -222,7 +222,7 @@ printTargetForms verbosity targetStrings targets elaboratedPlan = sort $ catMaybes [ targetForm ct <$> pkg - | (u :: UnitId, xs) <- Map.toAscList targets + | (WithStage _ u, xs) <- Map.toAscList targets , let pkg = safeHead $ filter ((== u) . elabUnitId) localPkgs , (ct :: ComponentTarget, _) <- xs ] diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs index 14b4b8a8d7d..563cea4c64d 100644 --- a/cabal-install/src/Distribution/Client/CmdTest.hs +++ b/cabal-install/src/Distribution/Client/CmdTest.hs @@ -67,6 +67,7 @@ import Distribution.Verbosity import qualified System.Exit (exitSuccess) import Distribution.Client.Errors +import Distribution.Utils.LogProgress (runLogProgress) import GHC.Environment ( getFullArgs ) @@ -151,11 +152,13 @@ testAction flags@NixStyleFlags{..} targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionTest - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionTest + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index b42cfee9916..3a54dd3fbe8 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -578,6 +578,10 @@ instance Semigroup SavedConfig where combineMonoid savedConfigureExFlags configAllowOlder , configWriteGhcEnvironmentFilesPolicy = combine configWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = combine configBuildHcFlavor + , configBuildHcPath = combine configBuildHcPath + , configBuildHcPkg = combine configBuildHcPkg + , configBuildPackageDBs = lastNonEmpty configBuildPackageDBs } where combine = combine' savedConfigureExFlags diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 6cc4bfec285..5c77dff570e 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -53,7 +53,7 @@ import Distribution.Client.Targets , userToPackageConstraint ) import Distribution.Client.Types as Source - +import Distribution.Client.Types.ReadyPackage (ReadyPackage) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint @@ -68,6 +68,7 @@ import Distribution.Solver.Types.PkgConfigDb ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.SavedFlags (readCommandFlags, writeCommandFlags) import Distribution.Package @@ -463,14 +464,18 @@ planLocalPackage . setSolveExecutables (SolveExecutables False) . setSolverVerbosity (verbosityLevel verbosity) $ standardInstallPolicy - installedPkgIndex -- NB: We pass in an *empty* source package database, -- because cabal configure assumes that all dependencies -- have already been installed (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies platform (compilerInfo comp) pkgConfigDb resolverParams) + return $ + resolveDependencies + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) + resolverParams -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ReadyPackage'. In particular the diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 1244308b881..0af476a1534 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- - +{-# LANGUAGE LambdaCase #-} -- | -- Module : Distribution.Client.Dependency -- Copyright : (c) David Himmelstrup 2005, @@ -115,7 +115,8 @@ import qualified Distribution.PackageDescription.Configuration as PD import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Simple.Setup - ( asBool + ( BooleanFlag + , asBool ) import Distribution.Solver.Modular ( PruneAfterFirstSuccess (..) @@ -137,6 +138,8 @@ import Distribution.Types.DependencySatisfaction ) import Distribution.Verbosity ( VerbosityLevel (..) + , deafening + , normal ) import Distribution.Version @@ -160,6 +163,7 @@ import Distribution.Solver.Types.SolverPackage ( SolverPackage (SolverPackage) ) import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Toolchain import Distribution.Solver.Types.Variable import Control.Exception @@ -171,6 +175,8 @@ import Data.List ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Stack (HasCallStack) +import Text.PrettyPrint -- ------------------------------------------------------------ @@ -186,7 +192,7 @@ data DepResolverParams = DepResolverParams , depResolverConstraints :: [LabeledPackageConstraint] , depResolverPreferences :: [PackagePreference] , depResolverPreferenceDefault :: PackagesPreferenceDefault - , depResolverInstalledPkgIndex :: InstalledPackageIndex + , depResolverInstalledPkgIndex :: InstalledPackageIndex -> InstalledPackageIndex , depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage , depResolverReorderGoals :: ReorderGoals , depResolverCountConflicts :: CountConflicts @@ -215,47 +221,48 @@ data DepResolverParams = DepResolverParams showDepResolverParams :: DepResolverParams -> String showDepResolverParams p = - "targets: " - ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p)) - ++ "\nconstraints: " - ++ concatMap - (("\n " ++) . showLabeledConstraint) - (depResolverConstraints p) - ++ "\npreferences: " - ++ concatMap - (("\n " ++) . showPackagePreference) - (depResolverPreferences p) - ++ "\nstrategy: " - ++ show (depResolverPreferenceDefault p) - ++ "\nreorder goals: " - ++ show (asBool (depResolverReorderGoals p)) - ++ "\ncount conflicts: " - ++ show (asBool (depResolverCountConflicts p)) - ++ "\nfine grained conflicts: " - ++ show (asBool (depResolverFineGrainedConflicts p)) - ++ "\nminimize conflict set: " - ++ show (asBool (depResolverMinimizeConflictSet p)) - ++ "\nindependent goals: " - ++ show (asBool (depResolverIndependentGoals p)) - ++ "\navoid reinstalls: " - ++ show (asBool (depResolverAvoidReinstalls p)) - ++ "\nshadow packages: " - ++ show (asBool (depResolverShadowPkgs p)) - ++ "\nstrong flags: " - ++ show (asBool (depResolverStrongFlags p)) - ++ "\nallow boot library installs: " - ++ show (asBool (depResolverAllowBootLibInstalls p)) - ++ "\nonly constrained packages: " - ++ show (depResolverOnlyConstrained p) - ++ "\nmax backjumps: " - ++ maybe - "infinite" - show - (depResolverMaxBackjumps p) + render $ + vcat + [ hang (text "targets:") 2 $ + vcat [text (prettyShow pkgname) | pkgname <- Set.toList (depResolverTargets p)] + , hang (text "constraints:") 2 $ + vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p] + , hang (text "constraints:") 2 $ + vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p] + , hang (text "preferences:") 2 $ + if depResolverVerbosity p >= Deafening + then vcat [text (showPackagePreference pref) | pref <- depResolverPreferences p] + else text "... increase verbosity to see" + , hang (text "strategy:") 2 $ + text (show (depResolverPreferenceDefault p)) + , hang (text "reorder goals:") 2 $ + prettyBool (depResolverReorderGoals p) + , hang (text "count conflicts:") 2 $ + prettyBool (depResolverCountConflicts p) + , hang (text "fine grained conflicts:") 2 $ + prettyBool (depResolverFineGrainedConflicts p) + , hang (text "minimize conflict set:") 2 $ + prettyBool (depResolverMinimizeConflictSet p) + , hang (text "avoid reinstalls:") 2 $ + prettyBool (depResolverAvoidReinstalls p) + , hang (text "shadow packages:") 2 $ + prettyBool (depResolverShadowPkgs p) + , hang (text "strong flags:") 2 $ + prettyBool (depResolverStrongFlags p) + , hang (text "allow boot library installs:") 2 $ + prettyBool (depResolverAllowBootLibInstalls p) + , hang (text "only constrained packages:") 2 $ + text (show (depResolverOnlyConstrained p)) + , hang (text "max backjumps:") 2 $ + text (maybe "infinite" show (depResolverMaxBackjumps p)) + ] where - showLabeledConstraint :: LabeledPackageConstraint -> String - showLabeledConstraint (LabeledPackageConstraint pc src) = - showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" + prettyBool :: BooleanFlag a => a -> Doc + prettyBool = pretty . asBool + + prettyLabeledConstraint :: LabeledPackageConstraint -> Doc + prettyLabeledConstraint (LabeledPackageConstraint pc src) = + pretty pc <+> parens (pretty src) -- | A package selection preference for a particular package. -- @@ -282,16 +289,15 @@ showPackagePreference (PackageStanzasPreference pn st) = prettyShow pn ++ " " ++ show st basicDepResolverParams - :: InstalledPackageIndex - -> PackageIndex.PackageIndex UnresolvedSourcePackage + :: PackageIndex.PackageIndex UnresolvedSourcePackage -> DepResolverParams -basicDepResolverParams installedPkgIndex sourcePkgIndex = +basicDepResolverParams sourcePkgIndex = DepResolverParams { depResolverTargets = Set.empty , depResolverConstraints = [] , depResolverPreferences = [] , depResolverPreferenceDefault = PreferLatestForSelected - , depResolverInstalledPkgIndex = installedPkgIndex + , depResolverInstalledPkgIndex = id , depResolverSourcePkgIndex = sourcePkgIndex , depResolverReorderGoals = ReorderGoals False , depResolverCountConflicts = CountConflicts True @@ -448,7 +454,7 @@ dependOnWiredIns compiler params = addConstraints extraConstraints params where extraConstraints = [ LabeledPackageConstraint - (PackageConstraint (ScopeAnyQualifier pkgName) (PackagePropertyInstalledSpecificUnitId unitId)) + (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgName)) (PackagePropertyInstalledSpecificUnitId unitId)) ConstraintSourceNonReinstallablePackage | (pkgName, unitId) <- fromMaybe [] $ compilerInfoWiredInUnitIds compiler ] @@ -461,7 +467,7 @@ dontInstallNonReinstallablePackages params = where extraConstraints = [ LabeledPackageConstraint - (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) + (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgname)) PackagePropertyInstalled) ConstraintSourceNonReinstallablePackage | pkgname <- nonReinstallablePackages ] @@ -514,10 +520,8 @@ hideInstalledPackagesSpecificBySourcePackageId pkgids params = -- TODO: this should work using exclude constraints instead params { depResolverInstalledPkgIndex = - foldl' - (flip InstalledPackageIndex.deleteSourcePackageId) - (depResolverInstalledPkgIndex params) - pkgids + (\idx -> foldl' (flip InstalledPackageIndex.deleteSourcePackageId) idx pkgids) + . depResolverInstalledPkgIndex params } hideInstalledPackagesAllVersions @@ -528,10 +532,8 @@ hideInstalledPackagesAllVersions pkgnames params = -- TODO: this should work using exclude constraints instead params { depResolverInstalledPkgIndex = - foldl' - (flip InstalledPackageIndex.deletePackageName) - (depResolverInstalledPkgIndex params) - pkgnames + (\idx -> foldl' (flip InstalledPackageIndex.deletePackageName) idx pkgnames) + . depResolverInstalledPkgIndex params } -- | Remove upper bounds in dependencies using the policy specified by the @@ -714,7 +716,7 @@ addSetupCabalMinVersionConstraint minVersion = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ orLaterVersion minVersion) ) ConstraintSetupCabalMinVersion @@ -732,7 +734,7 @@ addSetupCabalMaxVersionConstraint maxVersion = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ earlierVersion maxVersion) ) ConstraintSetupCabalMaxVersion @@ -748,7 +750,7 @@ addSetupCabalProfiledDynamic = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) ) ConstraintSourceProfiledDynamic @@ -765,12 +767,10 @@ reinstallTargets params = -- | A basic solver policy on which all others are built. basicInstallPolicy - :: InstalledPackageIndex - -> SourcePackageDb + :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams basicInstallPolicy - installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) pkgSpecifiers = addPreferences @@ -786,7 +786,6 @@ basicInstallPolicy . addSourcePackages [pkg | SpecificSourcePackage pkg <- pkgSpecifiers] $ basicDepResolverParams - installedPkgIndex sourcePkgIndex -- | The policy used by all the standard commands, install, fetch, freeze etc @@ -794,14 +793,12 @@ basicInstallPolicy -- -- It extends the 'basicInstallPolicy' with a policy on setup deps. standardInstallPolicy - :: InstalledPackageIndex - -> SourcePackageDb + :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams -standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = +standardInstallPolicy sourcePkgDb pkgSpecifiers = addDefaultSetupDependencies setImplicitSetupInfo mkDefaultSetupDeps $ basicInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers where @@ -847,49 +844,47 @@ runSolver = modularResolver -- a 'Progress' structure that can be unfolded to provide progress information, -- logging messages and the final result or an error. resolveDependencies - :: Platform - -> CompilerInfo - -> Maybe PkgConfigDb + :: Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> DepResolverParams -> Progress String String SolverInstallPlan -resolveDependencies platform comp pkgConfigDB params = do - step (showDepResolverParams finalparams) - pkgs <- - formatProgress $ - runSolver - ( SolverConfig - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity - (PruneAfterFirstSuccess False) - ) - platform - comp - installedPkgIndex - sourcePkgIndex - pkgConfigDB - preferences - constraints - targets - validateSolverResult platform comp indGoals pkgs +resolveDependencies toolchains pkgConfigDB installedPkgIndex params = + Step (showDepResolverParams finalparams) $ + fmap (validateSolverResult toolchains) $ + formatProgress $ + runSolver + ( SolverConfig + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity + (PruneAfterFirstSuccess False) + ) + toolchains + pkgConfigDB + installedPkgIndex' + sourcePkgIndex + preferences + constraints + targets where finalparams@( DepResolverParams targets constraints prefs defpref - installedPkgIndex + installedPkgIndexM sourcePkgIndex reordGoals cntConflicts @@ -911,6 +906,12 @@ resolveDependencies platform comp pkgConfigDB params = do then dependOnWiredIns comp params else dontInstallNonReinstallablePackages params + comp = fst (getStage toolchains Host) + + installedPkgIndex' = Staged $ \case + Build -> getStage installedPkgIndex Build + Host -> installedPkgIndexM (getStage installedPkgIndex Host) + formatProgress :: Progress SummarizedMessage String a -> Progress String String a formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p @@ -979,17 +980,16 @@ interpretPackagesPreference selected defaultPref prefs = -- | Make an install plan from the output of the dep resolver. -- It checks that the plan is valid, or it's an error in the dep resolver. validateSolverResult - :: Platform - -> CompilerInfo - -> IndependentGoals + :: HasCallStack + => Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] - -> Progress String String SolverInstallPlan -validateSolverResult platform comp indepGoals pkgs = - case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals graph of - Right plan -> return plan - Left problems -> fail (formatPlanProblems problems) - problems -> fail (formatPkgProblems problems) + -> SolverInstallPlan +validateSolverResult toolchains pkgs = + case planPackagesProblems toolchains pkgs of + [] -> case SolverInstallPlan.new (IndependentGoals False) graph of + Right plan -> plan + Left problems -> error (formatPlanProblems problems) + problems -> error (formatPkgProblems problems) where graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc) graph = Graph.fromDistinctList pkgs @@ -1030,14 +1030,13 @@ showPlanPackageProblem (DuplicatePackageSolverId pid dups) = ++ " duplicate instances." planPackagesProblems - :: Platform - -> CompilerInfo + :: Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] -> [PlanPackageProblem] -planPackagesProblems platform cinfo pkgs = +planPackagesProblems toolchains pkgs = [ InvalidConfiguredPackage pkg packageProblems | Configured pkg <- pkgs - , let packageProblems = configuredPackageProblems platform cinfo pkg + , let packageProblems = configuredPackageProblems toolchains pkg , not (null packageProblems) ] ++ [ DuplicatePackageSolverId (Graph.nodeKey aDup) dups @@ -1086,14 +1085,12 @@ showPackageProblem (InvalidDep dep pkgid) = -- in the configuration given by the flag assignment, all the package -- dependencies are satisfied by the specified packages. configuredPackageProblems - :: Platform - -> CompilerInfo + :: Staged (CompilerInfo, Platform) -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems - platform - cinfo - (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = + toolchains + (SolverPackage stage _qpn pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = [ DuplicateFlag flag | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] @@ -1163,8 +1160,8 @@ configuredPackageProblems specifiedFlags compSpec (const Satisfied) - platform - cinfo + (snd (getStage toolchains stage)) + (fst (getStage toolchains stage)) [] (srcpkgDescription pkg) of Right (resolvedPkg, _) -> @@ -1203,6 +1200,7 @@ configuredPackageProblems -- It simply means preferences for installed packages will be ignored. resolveWithoutDependencies :: DepResolverParams + -> InstalledPackageIndex -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies ( DepResolverParams @@ -1210,7 +1208,7 @@ resolveWithoutDependencies constraints prefs defpref - installedPkgIndex + installedPkgIndexM sourcePkgIndex _reorderGoals _countConflicts @@ -1227,7 +1225,8 @@ resolveWithoutDependencies _onlyConstrained _order _verbosity - ) = + ) + installedPkgIndex = collectEithers $ map selectPackage (Set.toList targets) where selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage @@ -1252,6 +1251,7 @@ resolveWithoutDependencies bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering bestByPrefs = comparing $ \pkg -> (installPref pkg, versionPref pkg, packageVersion pkg) + installPref :: UnresolvedSourcePackage -> Bool installPref = case preferInstalled of Preference.PreferLatest -> const False @@ -1260,8 +1260,9 @@ resolveWithoutDependencies not . null . InstalledPackageIndex.lookupSourcePackageId - installedPkgIndex + (installedPkgIndexM installedPkgIndex) . packageId + versionPref :: Package a => a -> Int versionPref pkg = length . filter (packageVersion pkg `withinRange`) $ diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 0a6e51b09e7..8067c12ecb1 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -34,6 +34,7 @@ import Distribution.Client.Config ( defaultLogsDir , defaultStoreDir ) +import Distribution.Client.Toolchain (Stage) import Distribution.Compiler import Distribution.Package ( ComponentId @@ -51,7 +52,6 @@ import Distribution.Simple.Compiler import Distribution.Simple.Configure (interpretPackageDbFlags) import Distribution.System import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained @@ -59,7 +59,8 @@ import Distribution.Types.LibraryName -- and for good reason: we don't want this path to change if -- the user, say, adds a dependency to their project. data DistDirParams = DistDirParams - { distParamUnitId :: UnitId + { distParamStage :: Stage + , distParamUnitId :: UnitId , distParamPackageId :: PackageId , distParamComponentId :: ComponentId , distParamComponentName :: Maybe ComponentName @@ -199,28 +200,10 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = distBuildDirectory :: DistDirParams -> FilePath distBuildDirectory params = distBuildRootDirectory + prettyShow (distParamStage params) prettyShow (distParamPlatform params) prettyShow (distParamCompilerId params) - prettyShow (distParamPackageId params) - ( case distParamComponentName params of - Nothing -> "" - Just (CLibName LMainLibName) -> "" - Just (CLibName (LSubLibName name)) -> "l" prettyShow name - Just (CFLibName name) -> "f" prettyShow name - Just (CExeName name) -> "x" prettyShow name - Just (CTestName name) -> "t" prettyShow name - Just (CBenchName name) -> "b" prettyShow name - ) - ( case distParamOptimization params of - NoOptimisation -> "noopt" - NormalOptimisation -> "" - MaximumOptimisation -> "opt" - ) - ( let uid_str = prettyShow (distParamUnitId params) - in if uid_str == prettyShow (distParamComponentId params) - then "" - else uid_str - ) + prettyShow (distParamUnitId params) distUnpackedSrcRootDirectory :: FilePath distUnpackedSrcRootDirectory = distDirectory "src" diff --git a/cabal-install/src/Distribution/Client/Errors.hs b/cabal-install/src/Distribution/Client/Errors.hs index 8f02620c6d8..a5497c0bab4 100644 --- a/cabal-install/src/Distribution/Client/Errors.hs +++ b/cabal-install/src/Distribution/Client/Errors.hs @@ -23,6 +23,7 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS8 import Data.List (groupBy) import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.ProjectPlanning.Stage (WithStage) import qualified Distribution.Client.Types.Repo as Repo import qualified Distribution.Client.Types.RepoName as RepoName import Distribution.Compat.Prelude @@ -95,7 +96,7 @@ data CabalInstallException | PlanPackages String | NoSupportForRunCommand | RunPhaseReached - | UnknownExecutable String UnitId + | UnknownExecutable String (WithStage UnitId) | MultipleMatchingExecutables String [String] | CmdRunReportTargetProblems String | CleanAction [String] diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 13c6f23415e..2f4ab5f5cff 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -38,6 +38,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.Errors import Distribution.Package @@ -175,9 +176,9 @@ planPackages installPlan <- foldProgress logMsg (dieWithException verbosity . PlanPackages . show) return $ resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams -- The packages we want to fetch are those packages the 'InstallPlan' @@ -189,7 +190,7 @@ planPackages ] | otherwise = either (dieWithException verbosity . PlanPackages . unlines . map show) return $ - resolveWithoutDependencies resolverParams + resolveWithoutDependencies resolverParams installedPkgIndex where resolverParams :: DepResolverParams resolverParams = @@ -221,7 +222,7 @@ planPackages -- already installed. Since we want to get the source packages of -- things we might have installed (but not have the sources for). . reinstallTargets - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + $ standardInstallPolicy sourcePkgDb pkgSpecifiers includeDependencies = fromFlag (fetchDeps fetchFlags) logMsg message rest = debug verbosity message >> rest diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index 94c27746920..7052515e8ce 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -51,7 +51,10 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.ResolverPackage (solverId) import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage (SolverPackage (..)) +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.Errors import Distribution.Package @@ -213,9 +216,9 @@ planPackages installPlan <- foldProgress logMsg (dieWithException verbosity . FreezeException) return $ resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams return $ pruneInstallPlan installPlan pkgSpecifiers @@ -246,7 +249,7 @@ planPackages in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + $ standardInstallPolicy sourcePkgDb pkgSpecifiers logMsg message rest = debug verbosity message >> rest @@ -287,9 +290,15 @@ pruneInstallPlan installPlan pkgSpecifiers = removeSelf pkgIds $ SolverInstallPlan.dependencyClosure installPlan pkgIds where + -- Get the source packages from the (specific) package specifiers. + srcpkgs :: [UnresolvedSourcePackage] + srcpkgs = [pkg | SpecificSourcePackage pkg <- pkgSpecifiers] + -- Get the 'SolverId's of the packages we are freezing. + pkgIds :: [SolverId] pkgIds = - [ PlannedId (packageId pkg) - | SpecificSourcePackage pkg <- pkgSpecifiers + [ solverId (SolverInstallPlan.Configured pkg) + | SolverInstallPlan.Configured pkg <- SolverInstallPlan.toList installPlan + , solverPkgSource pkg `elem` srcpkgs ] removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) removeSelf _ = diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs index 44de794c878..2df320aef77 100644 --- a/cabal-install/src/Distribution/Client/Get.hs +++ b/cabal-install/src/Distribution/Client/Get.hs @@ -125,6 +125,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do either (dieWithException verbosity . PkgSpecifierException . map show) return $ resolveWithoutDependencies (resolverParams sourcePkgDb pkgSpecifiers) + mempty unless (null prefix) $ createDirectoryIfMissing True prefix @@ -143,7 +144,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams resolverParams sourcePkgDb pkgSpecifiers = -- TODO: add command-line constraint and preference args for unpack - standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + standardInstallPolicy sourcePkgDb pkgSpecifiers onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags) diff --git a/cabal-install/src/Distribution/Client/InLibrary.hs b/cabal-install/src/Distribution/Client/InLibrary.hs index 7b6470ba73f..847222a14cd 100644 --- a/cabal-install/src/Distribution/Client/InLibrary.hs +++ b/cabal-install/src/Distribution/Client/InLibrary.hs @@ -37,6 +37,9 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.SetupHooks.Internal import qualified Distribution.Simple.Test as Cabal import Distribution.Simple.Utils +import Distribution.Client.Toolchain (Toolchain (..)) +import Distribution.Solver.Types.Stage (Stage (..)) +import Distribution.Solver.Types.Stage (getStage) import Distribution.System (Platform) import Distribution.Types.BuildType import Distribution.Types.ComponentRequestedSpec @@ -86,8 +89,7 @@ libraryConfigureInputsFromElabPackage -- NB: don't use the ProgramDb from the ElaboratedSharedConfig; -- that one is only for the compiler itself and not for the package. ElaboratedSharedConfig - { pkgConfigPlatform = plat - , pkgConfigCompiler = compil + { pkgConfigToolchains = toolchains } (ReadyPackage pkg) userTargets = @@ -123,6 +125,9 @@ libraryConfigureInputsFromElabPackage where pkgDescr = elabPkgDescription pkg gpkgDescr = elabGPkgDescription pkg + hostToolchain = getStage toolchains Host + plat = toolchainPlatform hostToolchain + compil = toolchainCompiler hostToolchain configure :: LibraryConfigureInputs diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 4082259c9f5..b98df15d15b 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -127,6 +127,7 @@ import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Targets import Distribution.Client.Types as Source import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) +import Distribution.Client.Types.ReadyPackage (ReadyPackage) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Solver.Types.PackageFixedDeps @@ -142,6 +143,7 @@ import Distribution.Solver.Types.PkgConfigDb ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage as SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.ProjectConfig import Distribution.Client.Utils @@ -584,9 +586,9 @@ planPackages pkgConfigDb pkgSpecifiers = resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return where @@ -649,7 +651,6 @@ planPackages -- doesn't understand how to install them . setSolveExecutables (SolveExecutables False) $ standardInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers @@ -715,7 +716,7 @@ pruneInstallPlan pkgSpecifiers = nub [ depid | SolverInstallPlan.PackageMissingDeps _ depids <- problems - , depid <- depids + , depid <- toList depids , packageName depid `elem` targetnames ] diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index bb427f44a2c..0ff295c4608 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1,7 +1,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -25,10 +28,11 @@ module Distribution.Client.InstallPlan , PlanPackage , GenericPlanPackage (..) , foldPlanPackage - , IsUnit + , renderPlanPackageTag -- * Operations on 'InstallPlan's , new + , new' , toGraph , toList , toMap @@ -41,6 +45,7 @@ module Distribution.Client.InstallPlan , configureInstallPlan , remove , installed + , installedM , lookup , directDeps , revDirectDeps @@ -59,16 +64,19 @@ module Distribution.Client.InstallPlan , failed -- * Display - , showPlanGraph + , renderPlanGraph , ShowPlanNode (..) , showInstallPlan , showInstallPlan_gen - , showPlanPackageTag + , PlanProblem + , renderPlanProblem + , renderPlanProblems -- * Graph-like operations , dependencyClosure , reverseTopologicalOrder , reverseDependencyClosure + , IsGraph (..) ) where import Distribution.Client.Compat.Prelude hiding (lookup, toList) @@ -90,9 +98,7 @@ import Distribution.Package ( HasMungedPackageId (..) , HasUnitId (..) , Package (..) - , UnitId ) -import Distribution.Pretty (defaultStyle) import Distribution.Solver.Types.SolverPackage import Text.PrettyPrint @@ -110,11 +116,16 @@ import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) import Control.Exception ( assert ) +import Data.Bifoldable +import Data.Bifunctor +import Data.Bitraversable import qualified Data.Foldable as Foldable (all, toList) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve. @@ -173,38 +184,33 @@ data GenericPlanPackage ipkg srcpkg = PreExisting ipkg | Configured srcpkg | Installed srcpkg - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Traversable, Foldable, Functor) -displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String -displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) +instance Bifunctor GenericPlanPackage where + bimap f _ (PreExisting ipkg) = PreExisting (f ipkg) + bimap _ g (Configured srcpkg) = Configured (g srcpkg) + bimap _ g (Installed srcpkg) = Installed (g srcpkg) --- | Convenience combinator for destructing 'GenericPlanPackage'. --- This is handy because if you case manually, you have to handle --- 'Configured' and 'Installed' separately (where often you want --- them to be the same.) -foldPlanPackage - :: (ipkg -> a) - -> (srcpkg -> a) - -> GenericPlanPackage ipkg srcpkg - -> a -foldPlanPackage f _ (PreExisting ipkg) = f ipkg -foldPlanPackage _ g (Configured srcpkg) = g srcpkg -foldPlanPackage _ g (Installed srcpkg) = g srcpkg +instance Bifoldable GenericPlanPackage where + bifoldMap f _ (PreExisting ipkg) = f ipkg + bifoldMap _ g (Configured srcpkg) = g srcpkg + bifoldMap _ g (Installed srcpkg) = g srcpkg -type IsUnit a = (IsNode a, Key a ~ UnitId) +instance Bitraversable GenericPlanPackage where + bitraverse f _ (PreExisting ipkg) = PreExisting <$> f ipkg + bitraverse _ g (Configured srcpkg) = Configured <$> g srcpkg + bitraverse _ g (Installed srcpkg) = Installed <$> g srcpkg -depends :: IsUnit a => a -> [UnitId] -depends = nodeNeighbors +-- I admit this is a bit awkward but I could not find a better way. --- NB: Expanded constraint synonym here to avoid undecidable --- instance errors in GHC 7.8 and earlier. -instance - (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) - => IsNode (GenericPlanPackage ipkg srcpkg) - where - type Key (GenericPlanPackage ipkg srcpkg) = UnitId +class (IsNode a, IsNode b, Key a ~ Key b) => IsGraph a b where + type GraphKey a b + +instance (IsNode a, Key a ~ key, IsNode b, Key b ~ key) => IsGraph a b where + type GraphKey a b = Key a + +instance IsGraph ipkg srcpkg => IsNode (GenericPlanPackage ipkg srcpkg) where + type Key (GenericPlanPackage ipkg srcpkg) = GraphKey ipkg srcpkg nodeKey (PreExisting ipkg) = nodeKey ipkg nodeKey (Configured spkg) = nodeKey spkg nodeKey (Installed spkg) = nodeKey spkg @@ -215,11 +221,6 @@ instance instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg) -type PlanPackage = - GenericPlanPackage - InstalledPackageInfo - (ConfiguredPackage UnresolvedPkgLoc) - instance (Package ipkg, Package srcpkg) => Package (GenericPlanPackage ipkg srcpkg) @@ -253,32 +254,45 @@ instance configuredId (Configured spkg) = configuredId spkg configuredId (Installed spkg) = configuredId spkg -data GenericInstallPlan ipkg srcpkg = GenericInstallPlan +displayGenericPlanPackage :: (IsNode ipkg, Key ipkg ~ key, IsNode srcpkg, Key srcpkg ~ key, Pretty key) => GenericPlanPackage ipkg srcpkg -> String +displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) + +-- | Convenience combinator for destructing 'GenericPlanPackage'. +-- This is handy because if you case manually, you have to handle +-- 'Configured' and 'Installed' separately (where often you want +-- them to be the same.) +foldPlanPackage + :: (ipkg -> a) + -> (srcpkg -> a) + -> GenericPlanPackage ipkg srcpkg + -> a +foldPlanPackage f _ (PreExisting ipkg) = f ipkg +foldPlanPackage _ g (Configured srcpkg) = g srcpkg +foldPlanPackage _ g (Installed srcpkg) = g srcpkg + +depends :: IsNode a => a -> [Key a] +depends = nodeNeighbors + +type PlanPackage = + GenericPlanPackage + InstalledPackageInfo + (ConfiguredPackage UnresolvedPkgLoc) + +data GenericInstallPlan' key ipkg srcpkg = GenericInstallPlan { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)) , planIndepGoals :: !IndependentGoals } +type GenericInstallPlan ipkg srcpkg = GenericInstallPlan' (GraphKey ipkg srcpkg) ipkg srcpkg + -- | 'GenericInstallPlan' specialised to most commonly used types. type InstallPlan = GenericInstallPlan InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) --- | Smart constructor that deals with caching the 'Graph' representation. -mkInstallPlan - :: (IsUnit ipkg, IsUnit srcpkg) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> IndependentGoals - -> GenericInstallPlan ipkg srcpkg -mkInstallPlan loc graph indepGoals = - assert - (valid loc graph) - GenericInstallPlan - { planGraph = graph - , planIndepGoals = indepGoals - } - internalError :: WithCallStack (String -> String -> a) internalError loc msg = error $ @@ -286,7 +300,10 @@ internalError loc msg = ++ loc ++ if null msg then "" else ": " ++ msg -instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where +instance + (Typeable key, Structured ipkg, Structured srcpkg) + => Structured (GenericInstallPlan' key ipkg srcpkg) + where structure p = Nominal (typeRep p) @@ -297,14 +314,14 @@ instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ] instance - ( IsNode ipkg - , Key ipkg ~ UnitId - , IsNode srcpkg - , Key srcpkg ~ UnitId + ( IsGraph ipkg srcpkg + , key ~ GraphKey ipkg srcpkg , Binary ipkg , Binary srcpkg + , Pretty key + , Show key ) - => Binary (GenericInstallPlan ipkg srcpkg) + => Binary (GenericInstallPlan' key ipkg srcpkg) where put GenericInstallPlan @@ -313,23 +330,24 @@ instance } = put graph >> put indepGoals get = do - graph <- get - indepGoals <- get - return $! mkInstallPlan "(instance Binary)" graph indepGoals + graph <- mkInstallPlan <$> get + return $! either (const (error "Deserialised invalid GenericInstallPlan")) id graph data ShowPlanNode = ShowPlanNode { showPlanHerald :: Doc , showPlanNeighbours :: [Doc] } -showPlanGraph :: [ShowPlanNode] -> String -showPlanGraph graph = - renderStyle defaultStyle $ - vcat (map dispPlanPackage graph) +renderPlanGraph :: [ShowPlanNode] -> Doc +renderPlanGraph graph = + vcat (map dispPlanPackage graph) where dispPlanPackage (ShowPlanNode herald neighbours) = hang herald 2 (vcat neighbours) +showPlanGraph :: [ShowPlanNode] -> String +showPlanGraph = render . renderPlanGraph + -- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information showInstallPlan_gen :: forall ipkg srcpkg @@ -340,7 +358,11 @@ showInstallPlan_gen toShow = showPlanGraph . fmap toShow . Foldable.toList . pla showInstallPlan :: forall ipkg srcpkg - . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) + . ( IsGraph ipkg srcpkg + , Package ipkg + , Package srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => GenericInstallPlan ipkg srcpkg -> String showInstallPlan = showInstallPlan_gen toShow @@ -349,25 +371,59 @@ showInstallPlan = showInstallPlan_gen toShow toShow p = ShowPlanNode ( hsep - [ text (showPlanPackageTag p) + [ renderPlanPackageTag p , pretty (packageId p) , parens (pretty (nodeKey p)) ] ) (map pretty (nodeNeighbors p)) -showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String -showPlanPackageTag (PreExisting _) = "PreExisting" -showPlanPackageTag (Configured _) = "Configured" -showPlanPackageTag (Installed _) = "Installed" +renderPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> Doc +renderPlanPackageTag (PreExisting _) = text "pre-existing" +renderPlanPackageTag (Configured _) = text "configured" +renderPlanPackageTag (Installed _) = text "installed" --- | Build an installation plan from a valid set of resolved packages. +-- | Smart constructor that deals with caching the 'Graph' representation. +mkInstallPlan + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => Graph (GenericPlanPackage ipkg srcpkg) + -> Either Doc (GenericInstallPlan ipkg srcpkg) +mkInstallPlan graph = + case NE.nonEmpty (problems graph) of + Just problems' -> Left $ renderPlanProblems (NE.toList problems') + Nothing -> Right $ GenericInstallPlan{planGraph = graph, planIndepGoals = IndependentGoals False} + +mkInstallPlan' + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => Graph (GenericPlanPackage ipkg srcpkg) + -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan ipkg srcpkg) +mkInstallPlan' graph = + case NE.nonEmpty (problems graph) of + Just problems' -> Left problems' + Nothing -> Right $ GenericInstallPlan{planGraph = graph, planIndepGoals = IndependentGoals False} + +-- | Build an installation plan from a set of packages. new - :: (IsUnit ipkg, IsUnit srcpkg) - => IndependentGoals - -> Graph (GenericPlanPackage ipkg srcpkg) - -> GenericInstallPlan ipkg srcpkg -new indepGoals graph = mkInstallPlan "new" graph indepGoals + :: ( IsGraph ipkg srcpkg + , Show (GraphKey ipkg srcpkg) + , Pretty (GraphKey ipkg srcpkg) + ) + => [GenericPlanPackage ipkg srcpkg] + -> LogProgress (GenericInstallPlan ipkg srcpkg) +new = eitherToLogProgress . mkInstallPlan . Graph.fromDistinctList + +-- | Build an installation plan from a graph of packages. +new' + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => Graph (GenericPlanPackage ipkg srcpkg) + -> LogProgress (GenericInstallPlan ipkg srcpkg) +new' = eitherToLogProgress . mkInstallPlan toGraph :: GenericInstallPlan ipkg srcpkg @@ -381,13 +437,13 @@ toList = Foldable.toList . planGraph toMap :: GenericInstallPlan ipkg srcpkg - -> Map UnitId (GenericPlanPackage ipkg srcpkg) + -> Map (Key ipkg) (GenericPlanPackage ipkg srcpkg) toMap = Graph.toMap . planGraph -keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] +keys :: GenericInstallPlan ipkg srcpkg -> [Key ipkg] keys = Graph.keys . planGraph -keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId +keysSet :: GenericInstallPlan ipkg srcpkg -> Set (Key ipkg) keysSet = Graph.keysSet . planGraph -- | Remove packages from the install plan. This will result in an @@ -396,16 +452,15 @@ keysSet = Graph.keysSet . planGraph -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. remove - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => (GenericPlanPackage ipkg srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg + -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan' (Key srcpkg) ipkg srcpkg) remove shouldRemove plan = - mkInstallPlan "remove" newGraph (planIndepGoals plan) - where - newGraph = - Graph.fromDistinctList $ - filter (not . shouldRemove) (toList plan) + mkInstallPlan' $ Graph.fromDistinctList $ filter (not . shouldRemove) (toList plan) -- | Change a number of packages in the 'Configured' state to the 'Installed' -- state. @@ -413,7 +468,7 @@ remove shouldRemove plan = -- To preserve invariants, the package must have all of its dependencies -- already installed too (that is 'PreExisting' or 'Installed'). installed - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => (srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg @@ -432,11 +487,31 @@ installed shouldBeInstalled installPlan = { planGraph = Graph.insert (Installed pkg) (planGraph plan) } +-- | Change a number of packages in the 'Configured' state to the 'Installed' +-- state. +-- +-- To preserve invariants, the package must have all of its dependencies +-- already installed too (that is 'PreExisting' or 'Installed'). +installedM + :: (IsGraph ipkg srcpkg, Monad m) + => (srcpkg -> m Bool) + -> GenericInstallPlan ipkg srcpkg + -> m (GenericInstallPlan ipkg srcpkg) +installedM shouldBeInstalled installPlan = do + s <- filterM shouldBeInstalled [pkg | Configured pkg <- reverseTopologicalOrder installPlan] + return $ foldl markInstalled installPlan s + where + markInstalled plan pkg = + assert (all isInstalled (directDeps plan (nodeKey pkg))) $ + plan + { planGraph = Graph.insert (Installed pkg) (planGraph plan) + } + -- | Lookup a package in the plan. lookup - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> Maybe (GenericPlanPackage ipkg srcpkg) lookup plan pkgid = Graph.lookup pkgid (planGraph plan) @@ -445,7 +520,7 @@ lookup plan pkgid = Graph.lookup pkgid (planGraph plan) -- Note that the package must exist in the plan or it is an error. directDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] directDeps plan pkgid = case Graph.neighbors (planGraph plan) pkgid of @@ -457,7 +532,7 @@ directDeps plan pkgid = -- Note that the package must exist in the plan or it is an error. revDirectDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] revDirectDeps plan pkgid = case Graph.revNeighbors (planGraph plan) pkgid of @@ -480,7 +555,7 @@ reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) -- the given packages. dependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] + -> [GraphKey ipkg srcpkg] -> [GenericPlanPackage ipkg srcpkg] dependencyClosure plan = fromMaybe [] @@ -490,7 +565,7 @@ dependencyClosure plan = -- given packages. reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] + -> [GraphKey ipkg srcpkg] -> [GenericPlanPackage ipkg srcpkg] reverseDependencyClosure plan = fromMaybe [] @@ -510,7 +585,11 @@ reverseDependencyClosure plan = -- because that's not enough information. fromSolverInstallPlan - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( HasCallStack + , IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg] @@ -518,39 +597,17 @@ fromSolverInstallPlan -> SolverInstallPlan -> GenericInstallPlan ipkg srcpkg fromSolverInstallPlan f plan = - mkInstallPlan - "fromSolverInstallPlan" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) - where - (_, _, pkgs'') = - foldl' - f' - (Map.empty, Map.empty, []) - (SolverInstallPlan.reverseTopologicalOrder plan) - - f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs) - where - pkgs' = f (mapDep pidMap ipiMap) pkg - - (pidMap', ipiMap') = - case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) - - mapDep _ ipiMap (PreExistingId _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) - --- This shouldn't happen, since mapDep should only be called --- on neighbor SolverId, which must have all been done already --- by the reverse top-sort (we assume the graph is not broken). + either (error . show) id $ + runLogProgress' $ + fromSolverInstallPlanWithProgress + (\mapDep planpkg -> return $ f mapDep planpkg) + plan fromSolverInstallPlanWithProgress - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage -> LogProgress [GenericPlanPackage ipkg srcpkg] @@ -558,35 +615,22 @@ fromSolverInstallPlanWithProgress -> SolverInstallPlan -> LogProgress (GenericInstallPlan ipkg srcpkg) fromSolverInstallPlanWithProgress f plan = do - (_, _, pkgs'') <- + (_, pkgs'') <- foldM f' - (Map.empty, Map.empty, []) + (Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan) - return $ - mkInstallPlan - "fromSolverInstallPlanWithProgress" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) + new' (Graph.fromDistinctList pkgs'') where - f' (pidMap, ipiMap, pkgs) pkg = do - pkgs' <- f (mapDep pidMap ipiMap) pkg - let (pidMap', ipiMap') = - case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) - return (pidMap', ipiMap', pkgs' ++ pkgs) - - mapDep _ ipiMap (PreExistingId _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) - --- This shouldn't happen, since mapDep should only be called --- on neighbor SolverId, which must have all been done already --- by the reverse top-sort (we assume the graph is not broken). + f' (pMap, pkgs) pkg = do + pkgs' <- f (mapDep pMap) pkg + let pMap' = Map.insert (nodeKey pkg) pkgs' pMap + return (pMap', pkgs' ++ pkgs) + + -- The error below shouldn't happen, since mapDep should only + -- be called on neighbor SolverId, which must have all been done + -- already by the reverse top-sort (we assume the graph is not broken). + mapDep pMap key = fromMaybe (error ("fromSolverInstallPlanWithProgress: " ++ prettyShow key)) (Map.lookup key pMap) -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' @@ -672,7 +716,7 @@ configureInstallPlan configFlags solverPlan = -- and includes the set of packages that are in the processing state, e.g. in -- the process of being installed, plus those that have been completed and -- those where processing failed. -data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) +data Processing key = Processing !(Set key) !(Set key) !(Set key) -- processing, completed, failed @@ -685,9 +729,13 @@ data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) -- all the packages that are ready will now be processed and so we can consider -- them to be in the processing state. ready - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => GenericInstallPlan ipkg srcpkg - -> ([GenericReadyPackage srcpkg], Processing) + -> ([GenericReadyPackage srcpkg], Processing key) ready plan = assert (processingInvariant plan processing) (readyPackages, processing) where @@ -712,11 +760,11 @@ isInstalled _ = False -- process), along with the updated 'Processing' state. completed :: forall ipkg srcpkg - . (IsUnit ipkg, IsUnit srcpkg) + . (IsGraph ipkg srcpkg, Ord (GraphKey ipkg srcpkg), Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg - -> Processing - -> UnitId - -> ([GenericReadyPackage srcpkg], Processing) + -> Processing (GraphKey ipkg srcpkg) + -> (GraphKey ipkg srcpkg) + -> ([GenericReadyPackage srcpkg], Processing (GraphKey ipkg srcpkg)) completed plan (Processing processingSet completedSet failedSet) pkgid = assert (pkgid `Set.member` processingSet) $ assert @@ -748,11 +796,11 @@ completed plan (Processing processingSet completedSet failedSet) pkgid = asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg failed - :: (IsUnit ipkg, IsUnit srcpkg) + :: (IsGraph ipkg srcpkg, Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg - -> Processing - -> UnitId - -> ([srcpkg], Processing) + -> Processing (GraphKey ipkg srcpkg) + -> GraphKey ipkg srcpkg + -> ([srcpkg], Processing (GraphKey ipkg srcpkg)) failed plan (Processing processingSet completedSet failedSet) pkgid = assert (pkgid `Set.member` processingSet) $ assert (all (`Set.notMember` processingSet) (drop 1 newlyFailedIds)) $ @@ -778,9 +826,13 @@ failed plan (Processing processingSet completedSet failedSet) pkgid = asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg processingInvariant - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => GenericInstallPlan ipkg srcpkg - -> Processing + -> Processing key -> Bool processingInvariant plan (Processing processingSet completedSet failedSet) = -- All the packages in the three sets are actually in the graph @@ -859,7 +911,7 @@ processingInvariant plan (Processing processingSet completedSet failedSet) = -- source packages in the dependency graph, albeit not necessarily exactly the -- same ordering as that produced by 'reverseTopologicalOrder'. executionOrder - :: (IsUnit ipkg, IsUnit srcpkg) + :: (IsGraph ipkg srcpkg, Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg] executionOrder plan = @@ -881,15 +933,15 @@ executionOrder plan = -- ------------------------------------------------------------ -- | The set of results we get from executing an install plan. -type BuildOutcomes failure result = Map UnitId (Either failure result) +type BuildOutcomes key failure result = Map key (Either failure result) -- | Lookup the build result for a single package. lookupBuildOutcome - :: HasUnitId pkg + :: (IsNode pkg, Key pkg ~ key) => pkg - -> BuildOutcomes failure result + -> BuildOutcomes key failure result -> Maybe (Either failure result) -lookupBuildOutcome = Map.lookup . installedUnitId +lookupBuildOutcome = Map.lookup . nodeKey -- | Execute an install plan. This traverses the plan in dependency order. -- @@ -907,29 +959,30 @@ lookupBuildOutcome = Map.lookup . installedUnitId -- these will have no 'BuildOutcome'. execute :: forall m ipkg srcpkg result failure - . ( IsUnit ipkg - , IsUnit srcpkg + . ( IsGraph ipkg srcpkg , Monad m + , Pretty (Key srcpkg) ) - => JobControl m (UnitId, Either failure result) + => JobControl m (GraphKey ipkg srcpkg, Either failure result) -> Bool -- ^ Keep going after failure -> (srcpkg -> failure) -- ^ Value for dependents of failed packages -> GenericInstallPlan ipkg srcpkg -> (GenericReadyPackage srcpkg -> m (Either failure result)) - -> m (BuildOutcomes failure result) + -> m (BuildOutcomes (GraphKey ipkg srcpkg) failure result) execute jobCtl keepGoing depFailure plan installPkg = let (newpkgs, processing) = ready plan - in tryNewTasks Map.empty False False processing newpkgs + in tryNewTasks mempty False False processing newpkgs where tryNewTasks - :: BuildOutcomes failure result + :: (Pretty key, Key srcpkg ~ key) + => BuildOutcomes key failure result -> Bool -> Bool - -> Processing + -> Processing key -> [GenericReadyPackage srcpkg] - -> m (BuildOutcomes failure result) + -> m (BuildOutcomes key failure result) tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs -- we were in the process of cancelling and now we're finished @@ -956,11 +1009,12 @@ execute jobCtl keepGoing depFailure plan installPkg = waitForTasks results tasksFailed processing waitForTasks - :: BuildOutcomes failure result + :: (Pretty key, Key srcpkg ~ key) + => BuildOutcomes key failure result -> Bool - -> Processing - -> m (BuildOutcomes failure result) - waitForTasks !results tasksFailed !processing = do + -> Processing key + -> m (BuildOutcomes key failure result) + waitForTasks results tasksFailed !processing = do (pkgid, result) <- collectJob jobCtl case result of @@ -998,83 +1052,123 @@ execute jobCtl keepGoing depFailure plan installPkg = -- ------------------------------------------------------------ --- | A valid installation plan is a set of packages that is closed, acyclic --- and respects the package state relation. --- --- * if the result is @False@ use 'problems' to get a detailed list. -valid - :: (IsUnit ipkg, IsUnit srcpkg) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> Bool -valid loc graph = - case problems graph of - [] -> True - ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) - data PlanProblem ipkg srcpkg - = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] - | PackageCycle [GenericPlanPackage ipkg srcpkg] + = PackageMissingDeps + (GenericPlanPackage ipkg srcpkg) + -- ^ The package that is missing dependencies + (NonEmpty (GraphKey ipkg srcpkg)) + -- ^ The missing dependencies + | -- | The packages involved in a dependency cycle + PackageCycle + [GenericPlanPackage ipkg srcpkg] | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) + -- ^ The package that is in an invalid state (GenericPlanPackage ipkg srcpkg) + -- ^ The package that it depends on which is in an invalid state -showPlanProblem - :: (IsUnit ipkg, IsUnit srcpkg) +renderPlanProblems + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => [PlanProblem ipkg srcpkg] + -> Doc +renderPlanProblems = + vcat . map renderPlanProblem + +renderPlanProblem + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => PlanProblem ipkg srcpkg - -> String -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " - ++ prettyShow (nodeKey pkg) - ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) -showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup) -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " - ++ prettyShow (nodeKey pkg) - ++ " is in the " - ++ showPlanPackageTag pkg - ++ " state but it depends on package " - ++ prettyShow (nodeKey pkg') - ++ " which is in the " - ++ showPlanPackageTag pkg' - ++ " state" + -> Doc +renderPlanProblem (PackageMissingDeps pkg missingDeps) = + fsep + [ text "Package" + , pretty (nodeKey pkg) + , text "depends on the following packages which are missing from the plan:" + , fsep (punctuate comma (map pretty $ NE.toList missingDeps)) + ] +renderPlanProblem (PackageCycle cycleGroup) = + fsep + [ text "The following packages are involved in a dependency cycle:" + , fsep (punctuate comma (map (pretty . nodeKey) cycleGroup)) + ] +renderPlanProblem (PackageStateInvalid pkg pkg') = + fsep + [ text "Package" + , pretty (nodeKey pkg) + , text "is in the" + , renderPlanPackageTag pkg + , text "state but it depends on package" + , pretty (nodeKey pkg') + , text "which is in the" + , renderPlanPackageTag pkg' + , text "state" + ] -- | For an invalid plan, produce a detailed list of problems as human readable -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. problems - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg] problems graph = + concat + [ checkForMissingDeps graph + , checkForCycles graph + , -- , checkForDependencyInconsistencies graph + checkForPackageStateInconsistencies graph + ] + +checkForMissingDeps + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForMissingDeps graph = [ PackageMissingDeps pkg - ( mapMaybe - (fmap nodeKey . flip Graph.lookup graph) - missingDeps - ) + missingDeps | (pkg, missingDeps) <- Graph.broken graph ] - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles graph - ] - {- - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - dependencyInconsistencies indepGoals graph ] - --TODO: consider re-enabling this one, see SolverInstallPlan - -} - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Foldable.toList graph - , Just pkg' <- - map - (`Graph.lookup` graph) - (nodeNeighbors pkg) - , not (stateDependencyRelation pkg pkg') - ] + +checkForCycles + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForCycles graph = + [PackageCycle cycleGroup | cycleGroup <- Graph.cycles graph] + +-- TODO: consider re-enabling this one, see SolverInstallPlan +-- +-- checkForDependencyInconsistencies +-- :: ( IsGraph ipkg srcpkg +-- , Pretty (GraphKey ipkg srcpkg) +-- , Key srcpkg ~ PlanProblem ipkg srcpkg +-- , Key ipkg ~ GraphKey ipkg srcpkg +-- ) +-- => Graph (GenericPlanPackage ipkg srcpkg) +-- -> [PlanProblem ipkg srcpkg] +-- checkForDependencyInconsistencies graph = +-- [ PackageInconsistency name inconsistencies +-- | (name, inconsistencies) <- +-- dependencyInconsistencies indepGoals graph +-- ] + +checkForPackageStateInconsistencies + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForPackageStateInconsistencies graph = + [ PackageStateInvalid pkg pkg' + | pkg <- Foldable.toList graph + , Just pkg' <- + map + (flip Graph.lookup graph) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') + ] -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs index 280916fdf6c..d37397987d3 100644 --- a/cabal-install/src/Distribution/Client/JobControl.hs +++ b/cabal-install/src/Distribution/Client/JobControl.hs @@ -50,7 +50,6 @@ import Control.Monad (forever, replicateM_) import Distribution.Client.Compat.Semaphore import Distribution.Client.Utils (numberOfProcessors) import Distribution.Compat.Stack -import Distribution.Simple.Compiler import Distribution.Simple.Utils import Distribution.Types.ParStrat import System.Semaphore @@ -277,29 +276,15 @@ criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act newJobControlFromParStrat :: Verbosity - -> Maybe Compiler - -- ^ The compiler, used to determine whether Jsem is supported. - -- When Nothing, Jsem is assumed to be unsupported. -> ParStratInstall -- ^ The parallel strategy -> Maybe Int -- ^ A cap on the number of jobs (e.g. to force a maximum of 2 concurrent downloads despite a -j8 parallel strategy) -> IO (JobControl IO a) -newJobControlFromParStrat verbosity mcompiler parStrat numJobsCap = case parStrat of +newJobControlFromParStrat verbosity parStrat numJobsCap = case parStrat of Serial -> newSerialJobControl NumJobs n -> newParallelJobControl (capJobs (fromMaybe numberOfProcessors n)) - UseSem n -> - case mcompiler of - Just compiler - | jsemSupported compiler -> - newSemaphoreJobControl verbosity (capJobs n) - | otherwise -> - do - warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control." - newParallelJobControl (capJobs n) - Nothing -> - -- Don't warn in the Nothing case, as there isn't really a "selected" compiler. - newParallelJobControl (capJobs n) + UseSem n -> newSemaphoreJobControl verbosity (capJobs n) where capJobs n = min (fromMaybe maxBound numJobsCap) n diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs index 3a94c0e028b..227a1792691 100644 --- a/cabal-install/src/Distribution/Client/PackageHash.hs +++ b/cabal-install/src/Distribution/Client/PackageHash.hs @@ -182,7 +182,8 @@ data PackageHashInputs = PackageHashInputs , pkgHashComponent :: Maybe CD.Component , pkgHashSourceHash :: PackageSourceHash , pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion) - , pkgHashDirectDeps :: Set InstalledPackageId + , pkgHashLibDeps :: Set InstalledPackageId + , pkgHashExeDeps :: Set InstalledPackageId , pkgHashOtherConfig :: PackageHashConfigInputs } @@ -220,7 +221,7 @@ data PackageHashConfigInputs = PackageHashConfigInputs , pkgHashExtraIncludeDirs :: [FilePath] , pkgHashProgPrefix :: Maybe PathTemplate , pkgHashProgSuffix :: Maybe PathTemplate - , pkgHashPackageDbs :: [Maybe PackageDBCWD] + , pkgHashPackageDbs :: [PackageDBCWD] , -- Haddock options pkgHashDocumentation :: Bool , pkgHashHaddockHoogle :: Bool @@ -258,7 +259,8 @@ renderPackageHashInputs { pkgHashPkgId , pkgHashComponent , pkgHashSourceHash - , pkgHashDirectDeps + , pkgHashLibDeps + , pkgHashExeDeps , pkgHashPkgConfigDeps , pkgHashOtherConfig = PackageHashConfigInputs{..} @@ -297,12 +299,19 @@ renderPackageHashInputs ) pkgHashPkgConfigDeps , entry - "deps" + "lib-deps" ( intercalate ", " . map prettyShow . Set.toList ) - pkgHashDirectDeps + pkgHashLibDeps + , entry + "exe-deps" + ( intercalate ", " + . map prettyShow + . Set.toList + ) + pkgHashExeDeps , -- and then all the config entry "compilerid" prettyShow pkgHashCompilerId , entry "compilerabi" prettyShow pkgHashCompilerABI diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 97b3de3b177..53eddd56baf 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -57,7 +58,6 @@ import Distribution.Client.GlobalFlags (RepoContext) import Distribution.Client.InstallPlan ( GenericInstallPlan , GenericPlanPackage - , IsUnit ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.JobControl @@ -71,7 +71,6 @@ import Distribution.Client.Types hiding import Distribution.Package import Distribution.Simple.Compiler -import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import Distribution.Compat.Graph (IsNode (..)) @@ -97,6 +96,7 @@ import Distribution.Simple.Flag (fromFlagOrDefault) import Distribution.Client.ProjectBuilding.PackageFileMonitor import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import qualified Distribution.Compat.Graph as Graph ------------------------------------------------------------------------------ @@ -259,21 +259,26 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = -- visiting function is passed the results for all the immediate package -- dependencies. This can be used to propagate information from dependencies. foldMInstallPlanDepOrder - :: forall m ipkg srcpkg b - . (Monad m, IsUnit ipkg, IsUnit srcpkg) + :: forall m ipkg srcpkg b key + . ( Monad m + , IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => ( GenericPlanPackage ipkg srcpkg -> [b] -> m b ) -> GenericInstallPlan ipkg srcpkg - -> m (Map UnitId b) + -> m (Map key b) foldMInstallPlanDepOrder visit = go Map.empty . InstallPlan.reverseTopologicalOrder where go - :: Map UnitId b + :: Map key b -> [GenericPlanPackage ipkg srcpkg] - -> m (Map UnitId b) + -> m (Map key b) go !results [] = return results go !results (pkg : pkgs) = do -- we go in the right order so the results map has entries for all deps @@ -298,7 +303,7 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus = where canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool canPackageBeImproved pkg = - case Map.lookup (installedUnitId pkg) pkgsBuildStatus of + case Map.lookup (nodeKey pkg) pkgsBuildStatus of Just BuildStatusUpToDate{} -> True Just _ -> False Nothing -> @@ -335,26 +340,67 @@ rebuildTargets -> BuildTimeSettings -> IO BuildOutcomes rebuildTargets + verbosity + projectConfig + distDirLayout + storeDirLayout + installPlan + sharedPackageConfig + pkgsBuildStatus + buildSettings + | buildSettingOnlyDownload buildSettings = do + rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $ + \downloadMap _jobControl pkg pkgBuildStatus -> + rebuildTargetOnlyDownload + verbosity + downloadMap + pkg + pkgBuildStatus + | otherwise = do + registerLock <- newLock -- serialise registration + cacheLock <- newLock -- serialise access to setup exe cache + rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $ + \downloadMap jobControl pkg pkgBuildStatus -> + rebuildTarget + verbosity + distDirLayout + storeDirLayout + (jobControlSemaphore jobControl) + buildSettings + downloadMap + registerLock + cacheLock + sharedPackageConfig + installPlan + pkg + pkgBuildStatus + +rebuildTargets' + :: Verbosity + -> ProjectConfig + -> DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> BuildStatusMap + -> BuildTimeSettings + -> (AsyncFetchMap -> JobControl IO (Graph.Key (GenericReadyPackage ElaboratedConfiguredPackage), Either BuildFailure BuildResult) -> GenericReadyPackage ElaboratedConfiguredPackage -> BuildStatus -> IO BuildResult) + -> IO BuildOutcomes +rebuildTargets' verbosity ProjectConfig { projectConfigBuildOnly = config } - distDirLayout@DistDirLayout{..} - storeDirLayout + DistDirLayout{..} installPlan - sharedPackageConfig@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } + sharedPackageConfig pkgsBuildStatus buildSettings@BuildTimeSettings { buildSettingNumJobs , buildSettingKeepGoing } + act | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError | otherwise = do - registerLock <- newLock -- serialise registration - cacheLock <- newLock -- serialise access to setup exe cache -- TODO: [code cleanup] eliminate setup exe cache info verbosity $ "Executing install plan " @@ -365,11 +411,11 @@ rebuildTargets createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory createDirectoryIfMissingVerbose verbosity True distTempDirectory - traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + createPackageDBsIfMissing -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. - withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do + withJobControl (newJobControlFromParStrat verbosity buildSettingNumJobs Nothing) $ \jobControl -> do -- Before traversing the install plan, preemptively find all packages that -- will need to be downloaded and start downloading them. asyncDownloadPackages @@ -382,56 +428,53 @@ rebuildTargets InstallPlan.execute jobControl keepGoing - (BuildFailure Nothing . DependentFailed . packageId) + (BuildFailure Nothing . DependentFailed . Graph.nodeKey) installPlan $ \pkg -> -- TODO: review exception handling handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus - - rebuildTarget - verbosity - distDirLayout - storeDirLayout - (jobControlSemaphore jobControl) - buildSettings - downloadMap - registerLock - cacheLock - sharedPackageConfig - installPlan - pkg - pkgBuildStatus + let pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") (nodeKey pkg) pkgsBuildStatus + act downloadMap jobControl pkg pkgBuildStatus where keepGoing = buildSettingKeepGoing withRepoCtx = projectConfigWithBuilderRepoContext verbosity buildSettings - packageDBsToUse = - -- all the package dbs we may need to create - (Set.toList . Set.fromList) - [ pkgdb - | InstallPlan.Configured elab <- InstallPlan.toList installPlan - , pkgdb <- - concat - [ elabBuildPackageDBStack elab - , elabRegisterPackageDBStack elab - , elabSetupPackageDBStack elab - ] - ] + + createPackageDBsIfMissing :: IO () + createPackageDBsIfMissing = + for_ (InstallPlan.toList installPlan) $ \case + InstallPlan.Configured elab -> do + let pkgdbs = + (Set.toList . Set.fromList) $ + concat + [ elabBuildPackageDBStack elab + , elabRegisterPackageDBStack elab + , elabSetupPackageDBStack elab + ] + for_ pkgdbs $ \case + SpecificPackageDB dbPath -> do + exists <- Cabal.doesPackageDBExist dbPath + let Toolchain{toolchainCompiler, toolchainProgramDb} = + getStage (pkgConfigToolchains sharedPackageConfig) (elabStage elab) + unless exists $ do + createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + Cabal.createPackageDB verbosity toolchainCompiler toolchainProgramDb dbPath + _ -> pure () + _ -> pure () offlineError :: BuildOutcomes offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload where - makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome) + makeBuildOutcome :: ElaboratedConfiguredPackage -> (Graph.Key ElaboratedPlanPackage, BuildOutcome) makeBuildOutcome ElaboratedConfiguredPackage { elabUnitId + , elabStage , elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion} } = - ( elabUnitId + ( WithStage elabStage elabUnitId , Left ( BuildFailure { buildFailureLogFile = Nothing @@ -457,25 +500,6 @@ rebuildTargets isRemote (RemoteSourceRepoPackage _ _) = True isRemote _ = False --- | Create a package DB if it does not currently exist. Note that this action --- is /not/ safe to run concurrently. -createPackageDBIfMissing - :: Verbosity - -> Compiler - -> ProgramDb - -> PackageDBCWD - -> IO () -createPackageDBIfMissing - verbosity - compiler - progdb - (SpecificPackageDB dbPath) = do - exists <- Cabal.doesPackageDBExist dbPath - unless exists $ do - createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - Cabal.createPackageDB verbosity compiler progdb dbPath -createPackageDBIfMissing _ _ _ _ = return () - -- | Given all the context and resources, (re)build an individual package. rebuildTarget :: Verbosity @@ -518,7 +542,8 @@ rebuildTarget void $ waitAsyncPackageDownload verbosity downloadMap pkg _ -> return () return $ BuildResult DocsNotTried TestsNotTried Nothing - | otherwise = + | otherwise = do + info verbosity $ "[rebuildTarget] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " with current status " ++ buildStatusToString pkgBuildStatus -- We rely on the 'BuildStatus' to decide which phase to start from: case pkgBuildStatus of BuildStatusDownload -> downloadPhase @@ -561,7 +586,8 @@ rebuildTarget -- would only start from download or unpack phases. -- rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult - rebuildPhase buildStatus srcdir = + rebuildPhase buildStatus srcdir = do + info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir assert (isInplaceBuildStyle $ elabBuildStyle pkg) buildInplace @@ -576,7 +602,8 @@ rebuildTarget -- TODO: [nice to have] ^^ do this relative stuff better buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult - buildAndInstall srcdir builddir = + buildAndInstall srcdir builddir = do + info verbosity $ "[buildAndInstall] Building and installing " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir buildAndInstallUnpackedPackage verbosity distDirLayout @@ -592,8 +619,9 @@ rebuildTarget builddir buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult - buildInplace buildStatus srcdir builddir = + buildInplace buildStatus srcdir builddir = do -- TODO: [nice to have] use a relative build dir rather than absolute + info verbosity $ "[buildInplace] Building inplace " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir buildInplaceUnpackedPackage verbosity distDirLayout @@ -608,6 +636,23 @@ rebuildTarget srcdir builddir +rebuildTargetOnlyDownload + :: Verbosity + -> AsyncFetchMap + -> GenericReadyPackage ElaboratedConfiguredPackage + -> BuildStatus + -> IO BuildResult +rebuildTargetOnlyDownload + verbosity + downloadMap + (ReadyPackage pkg) + pkgBuildStatus = do + case pkgBuildStatus of + BuildStatusDownload -> + void $ waitAsyncPackageDownload verbosity downloadMap pkg + _ -> return () + return $ BuildResult DocsNotTried TestsNotTried Nothing + -- TODO: [nice to have] do we need to use a with-style for the temp -- files for downloading http packages, or are we going to cache them -- persistently? @@ -642,8 +687,7 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body [ elabPkgSourceLocation elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan - , let uid = installedUnitId elab - pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus + , let pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") (Graph.nodeKey elab) pkgsBuildStatus , BuildStatusDownload <- [pkgBuildStatus] ] diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 864455cb540..8a54b494f76 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -25,8 +25,9 @@ import Prelude () import Distribution.Client.FileMonitor (MonitorChangedReason (..)) import Distribution.Client.Types (DocsResult, TestsResult) +import Distribution.Client.ProjectPlanning.Types (ElaboratedConfiguredPackage, ElaboratedPlanPackage) +import qualified Distribution.Compat.Graph as Graph import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Package (PackageId, UnitId) import Distribution.Simple.LocalBuildInfo (ComponentName) ------------------------------------------------------------------------------ @@ -36,7 +37,7 @@ import Distribution.Simple.LocalBuildInfo (ComponentName) -- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. -- -- This is used as the result of the dry-run of building an install plan. -type BuildStatusMap = Map UnitId BuildStatus +type BuildStatusMap = Map (Graph.Key ElaboratedPlanPackage) BuildStatus -- | The build status for an individual package is the state that the -- package is in /prior/ to initiating a (re)build. @@ -135,7 +136,7 @@ data BuildReason -- -- | A summary of the outcome for building a whole set of packages. -type BuildOutcomes = Map UnitId BuildOutcome +type BuildOutcomes = Map (Graph.Key ElaboratedPlanPackage) BuildOutcome -- | A summary of the outcome for building a single package: either success -- or failure. @@ -160,7 +161,7 @@ instance Exception BuildFailure -- | Detail on the reason that a package failed to build. data BuildFailureReason - = DependentFailed PackageId + = DependentFailed (Graph.Key ElaboratedConfiguredPackage) | GracefulFailure String | DownloadFailed SomeException | UnpackFailed SomeException diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 4168472065f..2518d96599f 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -92,12 +92,12 @@ import qualified Distribution.Simple.LocalBuildInfo as Cabal import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.Setup as Cabal + import Distribution.Types.BuildType import Distribution.Types.PackageDescription.Lens (componentModules) import Distribution.Client.Errors import Distribution.Simple.Utils -import Distribution.System (Platform (..)) import Distribution.Utils.Path hiding ( (<.>) , () @@ -121,6 +121,11 @@ import System.Semaphore (SemaphoreName (..)) import GHC.Stack import Web.Browser (openBrowser) +import Distribution.Client.Errors + +import Distribution.Client.ProjectBuilding.PackageFileMonitor +import qualified Distribution.Compat.Graph as Graph +import Distribution.System (Platform (..)) -- | Each unpacked package is processed in the following phases: -- -- * Configure phase @@ -181,37 +186,29 @@ buildAndRegisterUnpackedPackage buildTimeSettings@BuildTimeSettings{buildSettingKeepTempFiles} registerLock cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } + pkgshared plan rpkg@(ReadyPackage pkg) srcdir builddir mlogFile delegate = do + info verbosity $ "\n\nbuildAndRegisterUnpackedPackage: " ++ prettyShow (Graph.nodeKey pkg) -- Configure phase mbLBI <- delegate $ PBConfigurePhase $ - annotateFailure mlogFile ConfigureFailed $ - setup - configureCommand - Cabal.configCommonFlags - configureFlags - configureArgs + annotateFailure mlogFile ConfigureFailed $ do + info verbosity $ "--- Configure phase " ++ prettyShow (Graph.nodeKey pkg) + setup configureCommand Cabal.configCommonFlags configureFlags configureArgs (InLibraryArgs $ InLibraryConfigureArgs pkgshared rpkg) -- Build phase delegate $ PBBuildPhase $ annotateFailure mlogFile BuildFailed $ do - setup - buildCommand - Cabal.buildCommonFlags - (return . buildFlags) - buildArgs + info verbosity $ "--- Build phase " ++ prettyShow (Graph.nodeKey pkg) + setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI) -- Haddock phase @@ -219,26 +216,21 @@ buildAndRegisterUnpackedPackage delegate $ PBHaddockPhase $ annotateFailure mlogFile HaddocksFailed $ do - setup - haddockCommand - Cabal.haddockCommonFlags - (return . haddockFlags) - haddockArgs + info verbosity $ "--- Haddock phase " ++ prettyShow (Graph.nodeKey pkg) + setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI) -- Install phase delegate $ PBInstallPhase { runCopy = \destdir -> - annotateFailure mlogFile InstallFailed $ - setup - Cabal.copyCommand - Cabal.copyCommonFlags - (return . copyFlags destdir) - copyArgs + annotateFailure mlogFile InstallFailed $ do + info verbosity $ "--- Install phase, copy " ++ prettyShow (Graph.nodeKey pkg) + setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs (InLibraryArgs $ InLibraryPostConfigureArgs SCopyPhase mbLBI) , runRegister = \pkgDBStack registerOpts -> annotateFailure mlogFile InstallFailed $ do + info verbosity $ "--- Install phase, register " ++ prettyShow (Graph.nodeKey pkg) -- We register ourselves rather than via Setup.hs. We need to -- grab and modify the InstalledPackageInfo. We decide what -- the installed package id is, not the build system. @@ -247,8 +239,8 @@ buildAndRegisterUnpackedPackage criticalSection registerLock $ Cabal.registerPackage verbosity - compiler - progdb + toolchainCompiler + toolchainProgramDb Nothing (coercePackageDBStack pkgDBStack) ipkg @@ -260,42 +252,36 @@ buildAndRegisterUnpackedPackage whenTest $ delegate $ PBTestPhase $ - annotateFailure mlogFile TestsFailed $ - setup - testCommand - Cabal.testCommonFlags - (return . testFlags) - testArgs + annotateFailure mlogFile TestsFailed $ do + info verbosity $ "--- Test phase " ++ prettyShow (Graph.nodeKey pkg) + setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI) -- Bench phase whenBench $ delegate $ PBBenchPhase $ - annotateFailure mlogFile BenchFailed $ - setup - benchCommand - Cabal.benchmarkCommonFlags - (return . benchFlags) - benchArgs + annotateFailure mlogFile BenchFailed $ do + info verbosity $ "--- Benchmark phase " ++ prettyShow (Graph.nodeKey pkg) + setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) -- Repl phase whenRepl $ delegate $ PBReplPhase $ - annotateFailure mlogFile ReplFailed $ - setupInteractive - replCommand - Cabal.replCommonFlags - (return . replFlags) - replArgs + annotateFailure mlogFile ReplFailed $ do + info verbosity $ "--- Repl phase " ++ prettyShow (Graph.nodeKey pkg) + setupInteractive replCommand Cabal.replCommonFlags (return . replFlags) replArgs (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI) return () where uid = installedUnitId rpkg + Toolchain{toolchainCompiler, toolchainProgramDb} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + comp_par_strat = case maybe_semaphore of Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name) _ -> Cabal.NoFlag @@ -497,7 +483,7 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock - pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} + pkgshared plan rpkg@(ReadyPackage pkg) buildStatus @@ -595,6 +581,9 @@ buildInplaceUnpackedPackage dparams = elabDistDirParams pkgshared pkg + Toolchain{toolchainPlatform = Platform _ os} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams withFileMonitor :: IO [MonitorFilePath] -> IO () @@ -709,10 +698,7 @@ buildAndInstallUnpackedPackage buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigPlatform = platform - } + pkgshared plan rpkg@(ReadyPackage pkg) srcdir @@ -766,11 +752,8 @@ buildAndInstallUnpackedPackage "registerPkg: elab does NOT require registration for " ++ prettyShow uid | otherwise = do - assert - ( elabRegisterPackageDBStack pkg - == storePackageDBStack compiler (elabPackageDbs pkg) - ) - (return ()) + let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout toolchainCompiler] + assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ()) _ <- runRegister (elabRegisterPackageDBStack pkg) @@ -785,7 +768,7 @@ buildAndInstallUnpackedPackage newStoreEntry verbosity storeDirLayout - compiler + toolchainCompiler uid (copyPkgFiles verbosity pkgshared pkg runCopy) registerPkg @@ -823,6 +806,9 @@ buildAndInstallUnpackedPackage uid = installedUnitId rpkg pkgid = packageId rpkg + Toolchain{toolchainCompiler, toolchainPlatform} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + dispname :: String dispname = case elabPkgOrComp pkg of -- Packages built altogether, instead of per component @@ -847,7 +833,7 @@ buildAndInstallUnpackedPackage mlogFile = case buildSettingLogFile of Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + Just mkLogFile -> Just (mkLogFile toolchainCompiler toolchainPlatform pkgid uid) initLogFile :: IO () initLogFile = diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index c81b9c16535..a96fa4a0926 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -14,6 +14,7 @@ module Distribution.Client.ProjectConfig , ProjectConfigBuildOnly (..) , ProjectConfigShared (..) , ProjectConfigSkeleton + , ProjectConfigToolchain (..) , ProjectConfigProvenance (..) , PackageConfig (..) , MapLast (..) @@ -1400,7 +1401,6 @@ mplusMaybeT ma mb = do fetchAndReadSourcePackages :: Verbosity -> DistDirLayout - -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> [ProjectPackageLocation] @@ -1408,7 +1408,6 @@ fetchAndReadSourcePackages fetchAndReadSourcePackages verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly pkgLocations = do @@ -1445,7 +1444,6 @@ fetchAndReadSourcePackages syncAndReadSourcePackagesRemoteRepos verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly (fromFlag (projectConfigOfflineMode projectConfigBuildOnly)) @@ -1565,7 +1563,6 @@ fetchAndReadSourcePackageRemoteTarball syncAndReadSourcePackagesRemoteRepos :: Verbosity -> DistDirLayout - -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> Bool @@ -1574,7 +1571,6 @@ syncAndReadSourcePackagesRemoteRepos syncAndReadSourcePackagesRemoteRepos verbosity DistDirLayout{distDownloadSrcDirectory} - compiler ProjectConfigShared { projectConfigProgPathExtra } @@ -1609,7 +1605,7 @@ syncAndReadSourcePackagesRemoteRepos concat <$> rerunConcurrentlyIfChanged verbosity - (newJobControlFromParStrat verbosity compiler parStrat (Just maxNumFetchJobs)) + (newJobControlFromParStrat verbosity parStrat (Just maxNumFetchJobs)) [ ( monitor , repoGroup' , do diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index f49279f7781..1422900fdd0 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -12,7 +12,14 @@ import qualified Data.Set as Set import Distribution.CabalSpecVersion (CabalSpecVersion (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (clientInstallFlagsGrammar) import qualified Distribution.Client.ProjectConfig.Lens as L -import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..)) +import Distribution.Client.ProjectConfig.Types + ( PackageConfig (..) + , ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigProvenance (..) + , ProjectConfigShared (..) + , ProjectConfigToolchain (..) + ) import Distribution.Client.Utils.Parsec import Distribution.Compat.Prelude import Distribution.FieldGrammar @@ -76,12 +83,9 @@ projectConfigSharedFieldGrammar source = <*> optionalFieldDefAla "project-file" (alaFlag FilePathNT) L.projectConfigProjectFile mempty <*> pure mempty -- You can't set the parser type in the project file. <*> optionalFieldDef "ignore-project" L.projectConfigIgnoreProject mempty - <*> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty - <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty - <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty + <*> blurFieldGrammar L.projectConfigToolchain projectConfigToolchainFieldGrammar <*> optionalFieldDef "doc-index-file" L.projectConfigHaddockIndex mempty <*> blurFieldGrammar L.projectConfigInstallDirs installDirsGrammar - <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs <*> pure mempty -- repository stanza for projectConfigRemoteRepos <*> pure mempty -- repository stanza for projectConfigLocalNoIndexRepos <*> monoidalField "active-repositories" L.projectConfigActiveRepos @@ -109,6 +113,18 @@ projectConfigSharedFieldGrammar source = <*> monoidalFieldAla "extra-prog-path-shared-only" (alaNubList' FSep FilePathNT) L.projectConfigProgPathExtra <*> optionalFieldDef "multi-repl" L.projectConfigMultiRepl mempty +projectConfigToolchainFieldGrammar :: ParsecFieldGrammar' ProjectConfigToolchain +projectConfigToolchainFieldGrammar = + ProjectConfigToolchain + <$> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty + <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty + <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty + <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs + <*> optionalFieldDef "build-compiler" L.projectConfigBuildHcFlavor mempty + <*> optionalFieldDefAla "with-build-compiler" (alaFlag FilePathNT) L.projectConfigBuildHcPath mempty + <*> optionalFieldDefAla "with-build-hc-pkg" (alaFlag FilePathNT) L.projectConfigBuildHcPkg mempty + <*> monoidalFieldAla "build-package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigBuildPackageDBs + packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig packageConfigFieldGrammar knownPrograms = mkPackageConfig diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index fc4faa6a64a..e8f77515616 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -380,7 +380,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where - isSet f = f (projectConfigShared pc) /= NoFlag + isSet f = f (projectConfigToolchain $ projectConfigShared pc) /= NoFlag sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ProjectParseResult ProjectConfigSkeleton sanityWalkPCS underConditional t@(CondNode (listToMaybe -> c, d) comps) @@ -711,17 +711,17 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , globalStoreDir = projectConfigStoreDir } = globalFlags + projectConfigToolchain = ProjectConfigToolchain{..} projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_ + projectConfigBuildPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigBuildPackageDBs_ ConfigFlags { configCommonFlags = commonFlags , configHcFlavor = projectConfigHcFlavor , configHcPath = projectConfigHcPath , configHcPkg = projectConfigHcPkg - , -- configProgramPathExtra = projectConfigProgPathExtra DELETE ME - configInstallDirs = projectConfigInstallDirs - , -- configUserInstall = projectConfigUserInstall, - configPackageDBs = projectConfigPackageDBs_ + , configInstallDirs = projectConfigInstallDirs + , configPackageDBs = projectConfigPackageDBs_ } = configFlags CommonSetupFlags @@ -739,6 +739,10 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = projectConfigBuildHcFlavor + , configBuildHcPath = projectConfigBuildHcPath + , configBuildHcPkg = projectConfigBuildHcPkg + , configBuildPackageDBs = projectConfigBuildPackageDBs_ } = configExFlags InstallFlags @@ -962,10 +966,7 @@ convertToLegacySharedConfig ProjectConfig { projectConfigBuildOnly = ProjectConfigBuildOnly{..} , projectConfigShared = ProjectConfigShared{..} - , projectConfigAllPackages = - PackageConfig - { packageConfigDocumentation - } + , projectConfigAllPackages = PackageConfig{..} } = LegacySharedConfig { legacyGlobalFlags = globalFlags @@ -977,6 +978,7 @@ convertToLegacySharedConfig , legacyMultiRepl = projectConfigMultiRepl } where + ProjectConfigToolchain{..} = projectConfigToolchain globalFlags = GlobalFlags { globalVersion = mempty @@ -1021,6 +1023,10 @@ convertToLegacySharedConfig , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = projectConfigBuildHcFlavor + , configBuildHcPath = projectConfigBuildHcPath + , configBuildHcPkg = projectConfigBuildHcPkg + , configBuildPackageDBs = fmap (fmap (fmap unsafeMakeSymbolicPath)) projectConfigBuildPackageDBs } installFlags = @@ -1083,6 +1089,8 @@ convertToLegacyAllPackageConfig , legacyBenchmarkFlags = mempty } where + ProjectConfigToolchain{..} = projectConfigToolchain + commonFlags = mempty diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 03164305a62..fcbdbcbae88 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -7,7 +7,16 @@ import Distribution.Client.IndexUtils.ActiveRepos ( ActiveRepos ) import Distribution.Client.IndexUtils.IndexState (TotalIndexState) -import Distribution.Client.ProjectConfig.Types (MapLast, MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared) +import Distribution.Client.ProjectConfig.Types + ( MapLast + , MapMappend + , PackageConfig + , ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigProvenance + , ProjectConfigShared + , ProjectConfigToolchain (..) + ) import qualified Distribution.Client.ProjectConfig.Types as T import Distribution.Client.Targets (UserConstraint) import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder) @@ -192,18 +201,42 @@ projectConfigIgnoreProject :: Lens' ProjectConfigShared (Flag Bool) projectConfigIgnoreProject f s = fmap (\x -> s{T.projectConfigIgnoreProject = x}) (f (T.projectConfigIgnoreProject s)) {-# INLINEABLE projectConfigIgnoreProject #-} -projectConfigHcFlavor :: Lens' ProjectConfigShared (Flag CompilerFlavor) +projectConfigToolchain :: Lens' ProjectConfigShared ProjectConfigToolchain +projectConfigToolchain f s = fmap (\x -> s{T.projectConfigToolchain = x}) (f (T.projectConfigToolchain s)) +{-# INLINEABLE projectConfigToolchain #-} + +projectConfigHcFlavor :: Lens' ProjectConfigToolchain (Flag CompilerFlavor) projectConfigHcFlavor f s = fmap (\x -> s{T.projectConfigHcFlavor = x}) (f (T.projectConfigHcFlavor s)) {-# INLINEABLE projectConfigHcFlavor #-} -projectConfigHcPath :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigHcPath :: Lens' ProjectConfigToolchain (Flag FilePath) projectConfigHcPath f s = fmap (\x -> s{T.projectConfigHcPath = x}) (f (T.projectConfigHcPath s)) {-# INLINEABLE projectConfigHcPath #-} -projectConfigHcPkg :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigHcPkg :: Lens' ProjectConfigToolchain (Flag FilePath) projectConfigHcPkg f s = fmap (\x -> s{T.projectConfigHcPkg = x}) (f (T.projectConfigHcPkg s)) {-# INLINEABLE projectConfigHcPkg #-} +projectConfigPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD] +projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) +{-# INLINEABLE projectConfigPackageDBs #-} + +projectConfigBuildHcFlavor :: Lens' ProjectConfigToolchain (Flag CompilerFlavor) +projectConfigBuildHcFlavor f s = fmap (\x -> s{T.projectConfigBuildHcFlavor = x}) (f (T.projectConfigBuildHcFlavor s)) +{-# INLINEABLE projectConfigBuildHcFlavor #-} + +projectConfigBuildHcPath :: Lens' ProjectConfigToolchain (Flag FilePath) +projectConfigBuildHcPath f s = fmap (\x -> s{T.projectConfigBuildHcPath = x}) (f (T.projectConfigBuildHcPath s)) +{-# INLINEABLE projectConfigBuildHcPath #-} + +projectConfigBuildHcPkg :: Lens' ProjectConfigToolchain (Flag FilePath) +projectConfigBuildHcPkg f s = fmap (\x -> s{T.projectConfigBuildHcPkg = x}) (f (T.projectConfigBuildHcPkg s)) +{-# INLINEABLE projectConfigBuildHcPkg #-} + +projectConfigBuildPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD] +projectConfigBuildPackageDBs f s = fmap (\x -> s{T.projectConfigBuildPackageDBs = x}) (f (T.projectConfigBuildPackageDBs s)) +{-# INLINEABLE projectConfigBuildPackageDBs #-} + projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate) projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s)) {-# INLINEABLE projectConfigHaddockIndex #-} @@ -212,10 +245,6 @@ projectConfigInstallDirs :: Lens' ProjectConfigShared (InstallDirs (Flag PathTem projectConfigInstallDirs f s = fmap (\x -> s{T.projectConfigInstallDirs = x}) (f (T.projectConfigInstallDirs s)) {-# INLINEABLE projectConfigInstallDirs #-} -projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDBCWD] -projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) -{-# INLINEABLE projectConfigPackageDBs #-} - projectConfigLocalNoIndexRepos :: Lens' ProjectConfigShared (NubList LocalRepo) projectConfigLocalNoIndexRepos f s = fmap (\x -> s{T.projectConfigLocalNoIndexRepos = x}) (f (T.projectConfigLocalNoIndexRepos s)) {-# INLINEABLE projectConfigLocalNoIndexRepos #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 90740fc7a93..0576186de29 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -210,7 +210,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where - isSet f = f (projectConfigShared pc) /= NoFlag + isSet f = f (projectConfigToolchain (projectConfigShared pc)) /= NoFlag sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectFileSource ProjectConfigSkeleton sanityWalkPCS underConditional t@(CondNode (_c, d) comps) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 751875be403..e2c36da813f 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -9,6 +9,7 @@ module Distribution.Client.ProjectConfig.Types , ProjectConfigToParse (..) , ProjectConfigBuildOnly (..) , ProjectConfigShared (..) + , ProjectConfigToolchain (..) , ProjectConfigProvenance (..) , PackageConfig (..) , ProjectFileParser (..) @@ -194,16 +195,13 @@ data ProjectConfigShared = ProjectConfigShared , projectConfigProjectFile :: Flag FilePath , projectConfigProjectFileParser :: Flag ProjectFileParser , projectConfigIgnoreProject :: Flag Bool - , projectConfigHcFlavor :: Flag CompilerFlavor - , projectConfigHcPath :: Flag FilePath - , projectConfigHcPkg :: Flag FilePath + , projectConfigToolchain :: ProjectConfigToolchain , projectConfigHaddockIndex :: Flag PathTemplate , -- Only makes sense for manual mode, not --local mode -- too much control! -- projectConfigUserInstall :: Flag Bool, projectConfigInstallDirs :: InstallDirs (Flag PathTemplate) - , projectConfigPackageDBs :: [Maybe PackageDBCWD] , -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. @@ -243,6 +241,18 @@ data ProjectConfigShared = ProjectConfigShared } deriving (Eq, Show, Generic) +data ProjectConfigToolchain = ProjectConfigToolchain + { projectConfigHcFlavor :: Flag CompilerFlavor + , projectConfigHcPath :: Flag FilePath + , projectConfigHcPkg :: Flag FilePath + , projectConfigPackageDBs :: [Maybe PackageDBCWD] + , projectConfigBuildHcFlavor :: Flag CompilerFlavor + , projectConfigBuildHcPath :: Flag FilePath + , projectConfigBuildHcPkg :: Flag FilePath + , projectConfigBuildPackageDBs :: [Maybe PackageDBCWD] + } + deriving (Eq, Show, Generic) + data ProjectFileParser = LegacyParser | ParsecParser @@ -347,6 +357,7 @@ data PackageConfig = PackageConfig instance Binary ProjectConfig instance Binary ProjectConfigBuildOnly +instance Binary ProjectConfigToolchain instance Binary ProjectConfigShared instance Binary ProjectConfigProvenance instance Binary PackageConfig @@ -354,6 +365,7 @@ instance Binary ProjectFileParser instance Structured ProjectConfig instance Structured ProjectConfigBuildOnly +instance Structured ProjectConfigToolchain instance Structured ProjectConfigShared instance Structured ProjectConfigProvenance instance Structured PackageConfig @@ -364,6 +376,7 @@ instance NFData ProjectConfigToParse where instance NFData ProjectConfig instance NFData ProjectConfigBuildOnly +instance NFData ProjectConfigToolchain instance NFData ProjectConfigShared instance NFData ProjectConfigProvenance where @@ -422,6 +435,13 @@ instance Monoid ProjectConfigBuildOnly where instance Semigroup ProjectConfigBuildOnly where (<>) = gmappend +instance Monoid ProjectConfigToolchain where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfigToolchain where + (<>) = gmappend + instance Monoid ProjectConfigShared where mempty = gmempty mappend = (<>) diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 12718e4be5f..5baeb8b8346 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -61,6 +62,7 @@ module Distribution.Client.ProjectOrchestration , resolveTargetsFromSolver , resolveTargetsFromLocalPackages , TargetsMap + , TargetsMapS , allTargetSelectors , uniqueTargetSelectors , TargetSelector (..) @@ -102,12 +104,14 @@ module Distribution.Client.ProjectOrchestration -- * Dummy projects , establishDummyProjectBaseContext , establishDummyDistDirLayout + , filterTargetsWithStage ) where import Distribution.Client.Compat.Prelude import System.Directory ( makeAbsolute ) +import qualified Distribution.Compat.Graph as Graph import Prelude () import Distribution.Client.ProjectBuilding @@ -135,12 +139,9 @@ import Distribution.Client.TargetSelector , reportTargetSelectorProblems ) import Distribution.Client.Types - ( DocsResult (..) - , GenericReadyPackage (..) - , PackageLocation (..) + ( GenericReadyPackage (..) , PackageSpecifier (..) , SourcePackageDb (..) - , TestsResult (..) , UnresolvedSourcePackage , WriteGhcEnvironmentFilesPolicy (..) ) @@ -149,23 +150,11 @@ import Distribution.Solver.Types.PackageIndex ) import Distribution.Solver.Types.SourcePackage (SourcePackage (..)) -import Distribution.Client.BuildReports.Anonymous (cabalInstallID) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReports -import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeLocal - ) - import Distribution.Client.HttpUtils import Distribution.Client.Setup hiding (packageName) -import Distribution.Compiler - ( CompilerFlavor (GHC) - ) import Distribution.Types.ComponentName ( componentNameString ) -import Distribution.Types.InstalledPackageInfo - ( InstalledPackageInfo - ) import Distribution.Types.UnqualComponentName ( UnqualComponentName , packageNameToUnqualComponentName @@ -184,9 +173,6 @@ import Distribution.Package import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Compiler ( OptimisationLevel (..) - , compilerCompatVersion - , compilerId - , compilerInfo , showCompilerId ) import Distribution.Simple.Configure (computeEffectiveProfiling) @@ -209,22 +195,19 @@ import Distribution.Simple.Utils , ordNub , warn ) -import Distribution.System - ( Platform (Platform) - ) import Distribution.Types.Flag ( FlagAssignment , diffFlagAssignment , showFlagAssignment ) +import Distribution.Utils.LogProgress + ( LogProgress + ) import Distribution.Utils.NubList ( fromNubList ) import Distribution.Utils.Path (makeSymbolicPath) import Distribution.Verbosity -import Distribution.Version - ( mkVersion - ) #ifdef MIN_VERSION_unix import System.Posix.Signals (sigKILL, sigSEGV) @@ -345,7 +328,7 @@ data ProjectBuildContext = ProjectBuildContext , pkgsBuildStatus :: BuildStatusMap -- ^ The result of the dry-run phase. This tells us about each member of -- the 'elaboratedPlanToExecute'. - , targetsMap :: TargetsMap + , targetsMap :: TargetsMapS -- ^ The targets selected by @selectPlanSubset@. This is useful eg. in -- CmdRun, where we need a valid target to execute. } @@ -383,7 +366,7 @@ withInstallPlan runProjectPreBuildPhase :: Verbosity -> ProjectBaseContext - -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMapS)) -> IO ProjectBuildContext runProjectPreBuildPhase verbosity @@ -490,7 +473,7 @@ runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ runProjectPostBuildPhase verbosity ProjectBaseContext{..} - bc@ProjectBuildContext{..} + ProjectBuildContext{..} buildOutcomes = do -- Update other build artefacts -- TODO: currently none, but could include: @@ -519,21 +502,19 @@ runProjectPostBuildPhase writeGhcEnvFilesPolicy of AlwaysWriteGhcEnvironmentFiles -> True NeverWriteGhcEnvironmentFiles -> False - WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> - let compiler = pkgConfigCompiler elaboratedShared - ghcCompatVersion = compilerCompatVersion GHC compiler - in maybe False (>= mkVersion [8, 4, 4]) ghcCompatVersion - + -- FIXME: whatever + WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> True when shouldWriteGhcEnvironment $ void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) + Host elaboratedPlanOriginal elaboratedShared postBuildStatus -- Write the build reports - writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes + -- writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes -- Finally if there were any build failures then report them and throw -- an exception to terminate the program @@ -571,12 +552,22 @@ type TargetsMap = TargetsMapX UnitId type TargetsMapX u = Map u [(ComponentTarget, NonEmpty TargetSelector)] +type TargetsMapS = TargetsMapX (WithStage UnitId) + +filterTargetsWithStage :: Stage -> TargetsMapS -> TargetsMap +filterTargetsWithStage stage = + Map.fromList + . mapMaybe (\(WithStage s uid, v) -> if s == stage then Just (uid, v) else Nothing) + . Map.toList + +-- Map.mapMaybeWithKey (\(WithStage s uid) v -> if s == stage then Just v else Nothing) + -- | Get all target selectors. -allTargetSelectors :: TargetsMap -> [TargetSelector] +allTargetSelectors :: TargetsMapS -> [TargetSelector] allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems -- | Get all unique target selectors. -uniqueTargetSelectors :: TargetsMap -> [TargetSelector] +uniqueTargetSelectors :: TargetsMapS -> [TargetSelector] uniqueTargetSelectors = ordNub . allTargetSelectors -- | Resolve targets from a solver result. @@ -599,7 +590,7 @@ resolveTargetsFromSolver -> ElaboratedInstallPlan -> Maybe (SourcePackageDb) -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap + -> Either [TargetProblem err] TargetsMapS resolveTargetsFromSolver selectPackageTargets selectComponentTarget installPlan sourceDb targetSelectors = resolveTargets selectPackageTargets @@ -821,18 +812,18 @@ type AvailableTargetsMap k u = Map k [AvailableTarget (u, ComponentName)] -- -- They are all constructed lazily because they are not necessarily all used. -- -availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes UnitId +availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes (WithStage UnitId) availableTargetIndexes installPlan = AvailableTargetIndexes{..} where availableTargetsByPackageIdAndComponentName :: Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageIdAndComponentName = availableTargets installPlan availableTargetsByPackageId - :: Map PackageId [AvailableTarget (UnitId, ComponentName)] + :: Map PackageId [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageId = Map.mapKeysWith (++) @@ -841,7 +832,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} `Map.union` availableTargetsEmptyPackages availableTargetsByPackageName - :: Map PackageName [AvailableTarget (UnitId, ComponentName)] + :: Map PackageName [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageName = Map.mapKeysWith (++) @@ -851,7 +842,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} availableTargetsByPackageNameAndComponentName :: Map (PackageName, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageNameAndComponentName = Map.mapKeysWith (++) @@ -861,7 +852,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} availableTargetsByPackageNameAndUnqualComponentName :: Map (PackageName, UnqualComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageNameAndUnqualComponentName = Map.mapKeysWith (++) @@ -1053,9 +1044,9 @@ selectComponentTargetBasic -- for the extra unneeded info in the 'TargetsMap'. pruneInstallPlanToTargets :: TargetAction - -> TargetsMap - -> ElaboratedInstallPlan + -> TargetsMapS -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = assert (Map.size targetsMap > 0) $ ProjectPlanning.pruneInstallPlanToTargets @@ -1065,7 +1056,7 @@ pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = -- | Utility used by repl and run to check if the targets spans multiple -- components, since those commands do not support multiple components. -distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) +distinctTargetComponents :: TargetsMapS -> Set.Set (WithStage UnitId, ComponentName) distinctTargetComponents targetsMap = Set.fromList [ (uid, cname) @@ -1136,6 +1127,7 @@ printPlan filter (not . null) [ " -" + , prettyShow (elabStage elab) , if verbosityLevel verbosity >= Deafening then prettyShow (installedUnitId elab) else prettyShow (packageId elab) @@ -1145,17 +1137,17 @@ printPlan , case elabPkgOrComp elab of ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) ElabComponent comp -> - "(" ++ showComp elab comp ++ ")" + "(" ++ showComp comp ++ ")" , showFlagAssignment (nonDefaultFlags elab) , showConfigureFlags elab - , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab + , let buildStatus = pkgsBuildStatus Map.! Graph.nodeKey elab in "(" ++ showBuildStatus buildStatus ++ ")" ] - showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String - showComp elab comp = + showComp :: ElaboratedComponent -> String + showComp comp = maybe "custom" prettyShow (compComponentName comp) - ++ if Map.null (elabInstantiatedWith elab) + ++ if Map.null (compInstantiatedWith comp) then "" else " with " @@ -1163,7 +1155,7 @@ printPlan ", " -- TODO: Abbreviate the UnitIds [ prettyShow k ++ "=" ++ prettyShow v - | (k, v) <- Map.toList (elabInstantiatedWith elab) + | (k, v) <- Map.toList (compInstantiatedWith comp) ] nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment @@ -1184,7 +1176,8 @@ printPlan showConfigureFlags :: ElaboratedConfiguredPackage -> String showConfigureFlags elab = - let commonFlags = + let Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains elaboratedShared) (elabStage elab) + commonFlags = setupHsCommonFlags verbosity Nothing -- omit working directory @@ -1224,7 +1217,7 @@ printPlan in -- Not necessary to "escape" it, it's just for user output unwords . ("" :) $ commandShowOptions - (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) + (Setup.configureCommand toolchainProgramDb) partialConfigureFlags showBuildStatus :: BuildStatus -> String @@ -1256,7 +1249,8 @@ printPlan showBuildProfile = "Build profile: " ++ unwords - [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared + [ "-w " ++ (showCompilerId . toolchainCompiler $ getStage (pkgConfigToolchains elaboratedShared) Host) + , "-W " ++ (showCompilerId . toolchainCompiler $ getStage (pkgConfigToolchains elaboratedShared) Build) , "-O" ++ ( case globalOptimization <> localOptimization of -- if local is not set, read global Setup.Flag NoOptimisation -> "0" @@ -1267,53 +1261,53 @@ printPlan ] ++ "\n" -writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO () -writeBuildReports settings buildContext plan buildOutcomes = do - let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext - comp = pkgConfigCompiler . elaboratedShared $ buildContext - getRepo (RepoTarballPackage r _ _) = Just r - getRepo _ = Nothing - fromPlanPackage (InstallPlan.Configured pkg) (Just result) = - let installOutcome = case result of - Left bf -> case buildFailureReason bf of - GracefulFailure _ -> BuildReports.PlanningFailed - DependentFailed p -> BuildReports.DependencyFailed p - DownloadFailed _ -> BuildReports.DownloadFailed - UnpackFailed _ -> BuildReports.UnpackFailed - ConfigureFailed _ -> BuildReports.ConfigureFailed - BuildFailed _ -> BuildReports.BuildFailed - TestsFailed _ -> BuildReports.TestsFailed - InstallFailed _ -> BuildReports.InstallFailed - ReplFailed _ -> BuildReports.InstallOk - HaddocksFailed _ -> BuildReports.InstallOk - BenchFailed _ -> BuildReports.InstallOk - Right _br -> BuildReports.InstallOk - - docsOutcome = case result of - Left bf -> case buildFailureReason bf of - HaddocksFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultDocs br of - DocsNotTried -> BuildReports.NotTried - DocsFailed -> BuildReports.Failed - DocsOk -> BuildReports.Ok - - testsOutcome = case result of - Left bf -> case buildFailureReason bf of - TestsFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultTests br of - TestsNotTried -> BuildReports.NotTried - TestsOk -> BuildReports.Ok - in Just (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? - fromPlanPackage _ _ = Nothing - buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan - - BuildReports.storeLocal - (compilerInfo comp) - (buildSettingSummaryFile settings) - buildReports - plat +-- writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO () +-- writeBuildReports settings buildContext plan buildOutcomes = do +-- let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext +-- comp = pkgConfigCompiler . elaboratedShared $ buildContext +-- getRepo (RepoTarballPackage r _ _) = Just r +-- getRepo _ = Nothing +-- fromPlanPackage (InstallPlan.Configured pkg) (Just result) = +-- let installOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- GracefulFailure _ -> BuildReports.PlanningFailed +-- DependentFailed p -> BuildReports.DependencyFailed p +-- DownloadFailed _ -> BuildReports.DownloadFailed +-- UnpackFailed _ -> BuildReports.UnpackFailed +-- ConfigureFailed _ -> BuildReports.ConfigureFailed +-- BuildFailed _ -> BuildReports.BuildFailed +-- TestsFailed _ -> BuildReports.TestsFailed +-- InstallFailed _ -> BuildReports.InstallFailed +-- ReplFailed _ -> BuildReports.InstallOk +-- HaddocksFailed _ -> BuildReports.InstallOk +-- BenchFailed _ -> BuildReports.InstallOk +-- Right _br -> BuildReports.InstallOk + +-- docsOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- HaddocksFailed _ -> BuildReports.Failed +-- _ -> BuildReports.NotTried +-- Right br -> case buildResultDocs br of +-- DocsNotTried -> BuildReports.NotTried +-- DocsFailed -> BuildReports.Failed +-- DocsOk -> BuildReports.Ok + +-- testsOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- TestsFailed _ -> BuildReports.Failed +-- _ -> BuildReports.NotTried +-- Right br -> case buildResultTests br of +-- TestsNotTried -> BuildReports.NotTried +-- TestsOk -> BuildReports.Ok +-- in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? +-- fromPlanPackage _ _ = Nothing +-- buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan + +-- BuildReports.storeLocal +-- (compilerInfo comp) +-- (buildSettingSummaryFile settings) +-- buildReports +-- plat -- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1 -- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle. @@ -1360,7 +1354,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes , (pkg, failureClassification) <- failuresClassification ] where - failures :: [(UnitId, BuildFailure)] + failures :: [(Graph.Key ElaboratedPlanPackage, BuildFailure)] failures = [ (pkgid, failure) | (pkgid, Left failure) <- Map.toList buildOutcomes @@ -1418,9 +1412,10 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes -- isSimpleCase :: Bool isSimpleCase - | [(pkgid, failure)] <- failures + | [(WithStage s pkgid, failure)] <- failures , [pkg] <- rootpkgs , installedUnitId pkg == pkgid + , stageOf pkg == s , isFailureSelfExplanatory (buildFailureReason failure) , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] = True @@ -1444,16 +1439,15 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes , hasNoDependents pkg ] - ultimateDeps - :: UnitId - -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage] - ultimateDeps pkgid = + ultimateDeps :: (WithStage UnitId) -> [ElaboratedPlanPackage] + ultimateDeps pkgid@(WithStage s uid) = filter - (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) + (\pkg -> hasNoDependents pkg && installedUnitId pkg /= uid && stageOf pkg == s) (InstallPlan.reverseDependencyClosure plan [pkgid]) - hasNoDependents :: HasUnitId pkg => pkg -> Bool - hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId + -- TODO: ugly + hasNoDependents :: (Graph.IsNode pkg, Graph.Key pkg ~ WithStage UnitId) => pkg -> Bool + hasNoDependents = null . InstallPlan.revDirectDeps plan . Graph.nodeKey renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String renderFailureDetail mentionDepOf pkg reason = @@ -1467,7 +1461,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes case reason of DownloadFailed _ -> "Failed to download " ++ pkgstr UnpackFailed _ -> "Failed to unpack " ++ pkgstr - ConfigureFailed _ -> "Failed to build " ++ pkgstr + ConfigureFailed _ -> "Failed to configure " ++ pkgstr BuildFailed _ -> "Failed to build " ++ pkgstr ReplFailed _ -> "repl failed for " ++ pkgstr HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr @@ -1477,7 +1471,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes GracefulFailure msg -> msg DependentFailed depid -> "Failed to build " - ++ prettyShow (packageId pkg) + ++ prettyShow (Graph.nodeKey pkg) ++ " because it depends on " ++ prettyShow depid ++ " which itself failed to build" @@ -1485,7 +1479,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes pkgstr = elabConfiguredName verbosity pkg ++ if mentionDepOf - then renderDependencyOf (installedUnitId pkg) + then renderDependencyOf (Graph.nodeKey pkg) else "" renderFailureExtraDetail :: BuildFailureReason -> String @@ -1496,7 +1490,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes renderFailureExtraDetail _ = "" - renderDependencyOf :: UnitId -> String + renderDependencyOf :: Graph.Key ElaboratedConfiguredPackage -> String renderDependencyOf pkgid = case ultimateDeps pkgid of [] -> "" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 8f5f5211ec1..fbec1e50554 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -30,6 +30,7 @@ import qualified Distribution.Client.Utils.Json as J import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps +import qualified Distribution.Solver.Types.Stage as Stage import qualified Distribution.Compat.Binary as Binary import Distribution.Compat.Graph (Graph, Node) @@ -76,6 +77,7 @@ import System.FilePath import System.IO import Distribution.Simple.Program.GHC (packageDbArgsDb) +import GHC.Stack (HasCallStack) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -104,20 +106,26 @@ encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedCo encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- TODO: [nice to have] include all of the sharedPackageConfig and all of -- the parts of the elaboratedInstallPlan - J.object + J.object $ [ "cabal-version" J..= jdisplay cabalInstallVersion , "cabal-lib-version" J..= jdisplay cabalVersion - , "compiler-id" - J..= (J.String . showCompilerId . pkgConfigCompiler) - elaboratedSharedConfig - , "compiler-abi" J..= jdisplay (compilerAbiTag (pkgConfigCompiler elaboratedSharedConfig)) - , "os" J..= jdisplay os - , "arch" J..= jdisplay arch - , "install-plan" J..= installPlanToJ elaboratedInstallPlan ] + ++ toolchainJ Host + ++ toolchainJ Build + ++ ["install-plan" J..= installPlanToJ elaboratedInstallPlan] where - plat :: Platform - plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig + toolchains = pkgConfigToolchains elaboratedSharedConfig + + toolchainJ stage = + [ prefixed "compiler-id" J..= J.String (showCompilerId toolchainCompiler) + , prefixed "arch" J..= (jdisplay arch) + , prefixed "os" J..= (jdisplay os) + ] + where + Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} = Stage.getStage toolchains stage + prefixed s = case stage of + Stage.Build -> "build-" ++ s + Stage.Host -> s installPlanToJ :: ElaboratedInstallPlan -> [J.Value] installPlanToJ = map planPackageToJ . InstallPlan.toList @@ -133,7 +141,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- that case, but the code supports it in case we want to use this -- later in some use case where we want the status of the build. - installedPackageInfoToJ :: InstalledPackageInfo -> J.Value + installedPackageInfoToJ :: WithStage InstalledPackageInfo -> J.Value installedPackageInfoToJ ipi = -- Pre-existing packages lack configuration information such as their flag -- settings or non-lib components. We only get pre-existing packages for @@ -142,10 +150,11 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- J.object [ "type" J..= J.String "pre-existing" - , "id" J..= (jdisplay . installedUnitId) ipi + , "stage" J..= jdisplay (stageOf ipi) + , "id" J..= (jdisplay . Graph.nodeKey) ipi , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi - , "depends" J..= map jdisplay (installedDepends ipi) + , "depends" J..= map jdisplay (traverse installedDepends ipi) ] elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value @@ -157,7 +166,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = then "installed" else "configured" ) - , "id" J..= (jdisplay . installedUnitId) elab + , "id" J..= (jdisplay . Graph.nodeKey) elab + , "stage" J..= jdisplay (elabStage elab) , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab , -- The `x-revision` field is a feature of repos (not cabal itself), @@ -192,8 +202,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = J.object $ [ comp2str c J..= J.object - ( [ "depends" J..= map ((jdisplay . confInstId) . fst) ldeps - , "exe-depends" J..= map (jdisplay . confInstId) edeps + ( [ "depends" J..= map (jdisplay . confInstId) (map fst ldeps) + , "exe-depends" J..= map (jdisplay . fmap confInstId) edeps ] ++ bin_file c ) @@ -205,12 +215,15 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ] in ["components" J..= components] ElabComponent comp -> - [ "depends" J..= map ((jdisplay . confInstId) . fst) (elabLibDependencies elab) + [ "depends" J..= map (jdisplay . fmap confInstId . fst) (elabLibDependencies elab) , "exe-depends" J..= map jdisplay (elabExeDependencies elab) , "component-name" J..= J.String (comp2str (compSolverName comp)) ] ++ bin_file (compSolverName comp) where + Toolchain{toolchainPlatform = plat} = + Stage.getStage toolchains (elabStage elab) + -- \| Only add build-info file location if the Setup.hs CLI -- is recent enough to be able to generate build info files. -- Otherwise, write 'null'. @@ -455,7 +468,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- successfully then they're still out of date -- meeting our definition of -- invalid. -type PackageIdSet = Set UnitId +type PackageIdSet = Set (Graph.Key ElaboratedPlanPackage) type PackagesUpToDate = PackageIdSet data PostBuildProjectStatus = PostBuildProjectStatus @@ -508,7 +521,7 @@ data PostBuildProjectStatus = PostBuildProjectStatus -- or data file generation failing. -- -- This is a subset of 'packagesInvalidByChangedLibDeps'. - , packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + , packagesLibDepGraph :: Graph (Node (Graph.Key ElaboratedPlanPackage) ElaboratedPlanPackage) -- ^ A subset of the plan graph, including only dependency-on-library -- edges. That is, dependencies /on/ libraries, not dependencies /of/ -- libraries. This tells us all the libraries that packages link to. @@ -531,7 +544,8 @@ data PostBuildProjectStatus = PostBuildProjectStatus -- | Work out which packages are out of date or invalid after a build. postBuildProjectStatus - :: ElaboratedInstallPlan + :: HasCallStack + => ElaboratedInstallPlan -> PackagesUpToDate -> BuildStatusMap -> BuildOutcomes @@ -577,11 +591,13 @@ postBuildProjectStatus -- The previous set of up-to-date packages will contain bogus package ids -- when the solver plan or config contributing to the hash changes. -- So keep only the ones where the package id (i.e. hash) is the same. + previousPackagesUpToDate' :: Set (WithStage UnitId) previousPackagesUpToDate' = Set.intersection previousPackagesUpToDate (InstallPlan.keysSet plan) + packagesUpToDatePreBuild :: Set (WithStage UnitId) packagesUpToDatePreBuild = Set.filter (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) @@ -589,23 +605,26 @@ postBuildProjectStatus -- know anything about their status, so not known to be /up to date/. (InstallPlan.keysSet plan) + packagesOutOfDatePreBuild :: Set (WithStage UnitId) packagesOutOfDatePreBuild = - Set.fromList . map installedUnitId $ + Set.fromList . map Graph.nodeKey $ InstallPlan.reverseDependencyClosure plan [ ipkgid | pkg <- InstallPlan.toList plan - , let ipkgid = installedUnitId pkg + , let ipkgid = Graph.nodeKey pkg , lookupBuildStatusRequiresBuild False ipkgid -- For packages not in the plan subset we did the dry-run on we don't -- know anything about their status, so not known to be /out of date/. ] + packagesSuccessfulPostBuild :: Set (WithStage UnitId) packagesSuccessfulPostBuild = Set.fromList [ikgid | (ikgid, Right _) <- Map.toList buildOutcomes] -- direct failures, not failures due to deps + packagesFailurePostBuild :: Set (WithStage UnitId) packagesFailurePostBuild = Set.fromList [ ikgid @@ -617,6 +636,7 @@ postBuildProjectStatus -- Packages that have a library dependency on a package for which a build -- was attempted + packagesDepOnChangedLib :: Set (WithStage UnitId) packagesDepOnChangedLib = Set.fromList . map Graph.nodeKey $ fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ @@ -628,19 +648,25 @@ postBuildProjectStatus ) -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph :: HasCallStack => Graph (Node (Graph.Key ElaboratedPlanPackage) ElaboratedPlanPackage) packagesLibDepGraph = Graph.fromDistinctList - [ Graph.N pkg (installedUnitId pkg) libdeps + [ Graph.N pkg (Graph.nodeKey pkg) libdeps | pkg <- InstallPlan.toList plan , let libdeps = case pkg of - InstallPlan.PreExisting ipkg -> installedDepends ipkg - InstallPlan.Configured srcpkg -> elabLibDeps srcpkg - InstallPlan.Installed srcpkg -> elabLibDeps srcpkg + InstallPlan.PreExisting (WithStage s ipkg) -> map (WithStage s) (installedDepends ipkg) + InstallPlan.Configured srcpkg -> map (WithStage (elabStage srcpkg)) (elabLibDeps srcpkg) + InstallPlan.Installed srcpkg -> map (WithStage (elabStage srcpkg)) (elabLibDeps srcpkg) ] elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] - elabLibDeps = map ((newSimpleUnitId . confInstId) . fst) . elabLibDependencies + elabLibDeps = + map (newSimpleUnitId . confInstId) + -- Note, we remove the stage here. In the end we only care about the hash which already incorporates the stage. + -- Moreover, library dependencies are always in the same stage as the package itself. + . map (\(WithStage _ d) -> d) + . map fst + . elabLibDependencies -- Was a build was attempted for this package? -- If it doesn't have both a build status and outcome then the answer is no. @@ -657,13 +683,13 @@ postBuildProjectStatus buildAttempted _ (Left BuildFailure{}) = True buildAttempted _ (Right _) = True - lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool - lookupBuildStatusRequiresBuild def ipkgid = - case Map.lookup ipkgid pkgBuildStatus of + lookupBuildStatusRequiresBuild :: Bool -> Graph.Key ElaboratedPlanPackage -> Bool + lookupBuildStatusRequiresBuild def key = + case Map.lookup key pkgBuildStatus of Nothing -> def -- Not in the plan subset we did the dry-run on Just buildStatus -> buildStatusRequiresBuild buildStatus - packagesBuildLocal :: Set UnitId + packagesBuildLocal :: Set (WithStage UnitId) packagesBuildLocal = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -671,7 +697,7 @@ postBuildProjectStatus InstallPlan.Installed _ -> False InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg - packagesBuildInplace :: Set UnitId + packagesBuildInplace :: Set (WithStage UnitId) packagesBuildInplace = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -679,7 +705,7 @@ postBuildProjectStatus InstallPlan.Installed _ -> False InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg) - packagesAlreadyInStore :: Set UnitId + packagesAlreadyInStore :: Set (WithStage UnitId) packagesAlreadyInStore = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -688,10 +714,8 @@ postBuildProjectStatus InstallPlan.Configured _ -> False selectPlanPackageIdSet - :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage - -> Bool - ) - -> Set UnitId + :: (ElaboratedPlanPackage -> Bool) + -> Set (Graph.Key ElaboratedPlanPackage) selectPlanPackageIdSet p = Map.keysSet . Map.filter p @@ -817,11 +841,16 @@ createPackageEnvironmentAndArgs elaboratedPlan elaboratedShared buildStatus - | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC = + | buildCompiler /= hostCompiler = + do + warn verbosity "package environment configuration is not supported for cross-compilation; commands that need the current project's package database are likely to fail" + return ([], []) + | compilerFlavor hostCompiler == GHC = do envFileM <- writePlanGhcEnvironment path + Host elaboratedPlan elaboratedShared buildStatus @@ -834,55 +863,42 @@ createPackageEnvironmentAndArgs do warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" return ([], []) + where + compilers = toolchainCompiler <$> pkgConfigToolchains elaboratedShared + buildCompiler = getStage compilers Build + hostCompiler = getStage compilers Host -- Writing .ghc.environment files -- writePlanGhcEnvironment :: FilePath + -> Stage -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> PostBuildProjectStatus -> IO (Maybe FilePath) writePlanGhcEnvironment path + stage elaboratedInstallPlan - ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigPlatform = platform - } - postBuildStatus - | compilerFlavor compiler == GHC - , supportsPkgEnvFiles (getImplInfo compiler) = - -- TODO: check ghcjs compat + elaboratedSharedConfig + postBuildStatus = + if (compilerFlavor toolchainCompiler == GHC && supportsPkgEnvFiles (getImplInfo toolchainCompiler)) + then -- TODO: check ghcjs compat + fmap Just $ writeGhcEnvironmentFile path - platform - (compilerVersion compiler) - ( renderGhcEnvironmentFile - path - elaboratedInstallPlan - postBuildStatus - ) --- TODO: [required eventually] support for writing user-wide package --- environments, e.g. like a global project, but we would not put the --- env file in the home dir, rather it lives under ~/.ghc/ + toolchainPlatform + (compilerVersion toolchainCompiler) + env + else return Nothing + where + Toolchain{toolchainPlatform, toolchainCompiler} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage -writePlanGhcEnvironment _ _ _ _ = return Nothing + env = headerComment : simpleGhcEnvironmentFile packageDBs unitIds -renderGhcEnvironmentFile - :: FilePath - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry FilePath] -renderGhcEnvironmentFile - projectRootDir - elaboratedInstallPlan - postBuildStatus = - headerComment - : simpleGhcEnvironmentFile packageDBs unitIds - where headerComment = GhcEnvFileComment $ "This is a GHC environment file written by cabal. This means you can\n" @@ -890,11 +906,17 @@ renderGhcEnvironmentFile ++ "But you still need to use cabal repl $target to get the environment\n" ++ "of specific components (libs, exes, tests etc) because each one can\n" ++ "have its own source dirs, cpp flags etc.\n\n" - unitIds = selectGhcEnvironmentFileLibraries postBuildStatus + + unitIds = [unitId | WithStage Host unitId <- selectGhcEnvironmentFileLibraries postBuildStatus] + packageDBs = - relativePackageDBPaths projectRootDir $ + relativePackageDBPaths path $ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan +-- TODO: [required eventually] support for writing user-wide package +-- environments, e.g. like a global project, but we would not put the +-- env file in the home dir, rather it lives under ~/.ghc/ + argsEquivalentOfGhcEnvironmentFile :: Compiler -> DistDirLayout @@ -962,7 +984,7 @@ argsEquivalentOfGhcEnvironmentFileGhc -- to find the libs) then those exes still end up in our list so we have -- to filter them out at the end. -- -selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] +selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [WithStage UnitId] selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of Nothing -> error "renderGhcEnvironmentFile: broken dep closure" @@ -979,7 +1001,7 @@ selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = -- or just locally. Check it's a lib and that it is probably up to date. InstallPlan.Configured pkg -> elabRequiresRegistration pkg - && installedUnitId pkg `Set.member` packagesProbablyUpToDate + && Graph.nodeKey pkg `Set.member` packagesProbablyUpToDate selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStackCWD selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 5be55634324..9c72ebf204d 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -36,12 +36,21 @@ module Distribution.Client.ProjectPlanning ( -- * Types for the elaborated install plan ElaboratedInstallPlan + , ElaboratedInstalledPackageInfo , ElaboratedConfiguredPackage (..) , ElaboratedPlanPackage , ElaboratedSharedConfig (..) , ElaboratedReadyPackage , BuildStyle (..) , CabalFileText + , Toolchain (..) + , Stage (..) + , Staged (..) + , WithStage (..) + , elabOrderLibDependencies + , elabOrderExeDependencies + , elabLibDependencies + , elabExeDependencies -- * Reading the project configuration -- $readingTheProjectConfiguration @@ -69,7 +78,7 @@ module Distribution.Client.ProjectPlanning -- * Utils required for building , pkgHasEphemeralBuildTargets , elabBuildTargetWholeComponents - , configureCompiler + , configureToolchains -- * Setup.hs CLI flags for building , setupHsScriptOptions @@ -95,12 +104,12 @@ module Distribution.Client.ProjectPlanning , binDirectories , storePackageInstallDirs , storePackageInstallDirs' + , elabDistDirParams ) where import Distribution.Client.Compat.Prelude import Text.PrettyPrint - ( colon - , comma + ( comma , fsep , hang , punctuate @@ -126,7 +135,6 @@ import Distribution.Client.ProjectConfig.Types (defaultProjectFileParser) import Distribution.Client.ProjectPlanOutput import Distribution.Client.ProjectPlanning.SetupPolicy ( NonSetupLibDepSolverPlanPackage (..) - , mkDefaultSetupDeps , packageSetupScriptSpecVersion , packageSetupScriptStyle ) @@ -136,8 +144,9 @@ import Distribution.Client.Setup hiding (cabalVersion, packageName) import Distribution.Client.SetupWrapper import Distribution.Client.Store import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.Toolchain import Distribution.Client.Types -import Distribution.Client.Utils (concatMapM, incVersion) +import Distribution.Client.Utils (concatMapM) import qualified Distribution.Client.BuildReports.Storage as BuildReports import qualified Distribution.Client.IndexUtils as IndexUtils @@ -197,7 +206,7 @@ import Distribution.Types.PackageVersionConstraint import Distribution.Types.PkgconfigDependency import Distribution.Types.UnqualComponentName -import Distribution.Backpack +import Distribution.Backpack hiding (mkDefUnitId) import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ConfiguredComponent import Distribution.Backpack.FullUnitId @@ -224,14 +233,18 @@ import qualified Distribution.Compat.Graph as Graph import Control.Exception (assert) import Control.Monad (mapM_, sequence) import Control.Monad.IO.Class (liftIO) -import Control.Monad.State as State (State, execState, runState, state) +import Control.Monad.State (State, execState, gets, modify) import Data.Foldable (fold) import Data.List (deleteBy, groupBy) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Client.Errors +import Distribution.Client.InstallPlan (foldPlanPackage) import Distribution.Solver.Types.ProjectConfigPath +import Distribution.Solver.Types.ResolverPackage (solverId) +import qualified Distribution.Solver.Types.ResolverPackage as ResolverPackage +import GHC.Stack (HasCallStack) import System.Directory (getCurrentDirectory) import System.FilePath import qualified Text.PrettyPrint as Disp @@ -379,9 +392,9 @@ rebuildProjectConfig configPath <- getConfigFilePath verbosity projectConfigConfigFile return ( configPath - , distProjectFileMain distProjectFile - , (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg) + , distProjectFile "" , projectConfigProjectFileParser + , projectConfigToolchain , progsearchpath , packageConfigProgramPaths , packageConfigProgramPathExtra @@ -400,21 +413,23 @@ rebuildProjectConfig let fetchCompiler = do -- have to create the cache directory before configuring the compiler liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (snd (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) - pure (os, arch, compiler) + toolchains <- configureToolchains verbosity distDirLayout (snd (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + -- The project configuration is always done with the host compiler + let Toolchain{toolchainCompiler = compiler, toolchainPlatform = Platform arch os} = getStage toolchains Host + return (os, arch, compiler) - (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton - when (projectConfigDistDir (projectConfigShared projectConfig) /= NoFlag) $ + (projectConfig, _compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton + when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $ liftIO $ warn verbosity "The builddir option is not supported in project and config files. It will be ignored." - localPackages <- phaseReadLocalPackages compiler (projectConfig <> cliConfig) + localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig) return (projectConfig, localPackages) informAboutConfigFiles projectConfig return (projectConfig <> cliConfig, localPackages) where - ProjectConfigShared{projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile} = + ProjectConfigShared{projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile, projectConfigToolchain} = projectConfigShared cliConfig PackageConfig{packageConfigProgramPaths, packageConfigProgramPathExtra} = @@ -435,11 +450,9 @@ rebuildProjectConfig -- NOTE: These are all packages mentioned in the project configuration. -- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`. phaseReadLocalPackages - :: Maybe Compiler - -> ProjectConfig + :: ProjectConfig -> Rebuild [PackageSpecifier UnresolvedSourcePackage] phaseReadLocalPackages - compiler projectConfig@ProjectConfig { projectConfigShared , projectConfigBuildOnly @@ -454,7 +467,6 @@ rebuildProjectConfig fetchAndReadSourcePackages verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly pkgLocations @@ -500,12 +512,12 @@ rebuildProjectConfig $ projectConfigProvenance projectConfig ] -configureCompiler +configureToolchains :: Verbosity -> DistDirLayout -> ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) -configureCompiler + -> Rebuild Toolchains +configureToolchains verbosity DistDirLayout { distProjectCacheFile @@ -513,9 +525,17 @@ configureCompiler ProjectConfig { projectConfigShared = ProjectConfigShared - { projectConfigHcFlavor - , projectConfigHcPath - , projectConfigHcPkg + { projectConfigToolchain = + ProjectConfigToolchain + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigPackageDBs + , projectConfigBuildHcFlavor + , projectConfigBuildHcPath + , projectConfigBuildHcPkg + , projectConfigBuildPackageDBs + } , projectConfigProgPathExtra } , projectConfigLocalPackages = @@ -524,17 +544,54 @@ configureCompiler , packageConfigProgramPathExtra } } = do - let fileMonitorCompiler = newFileMonitor $ distProjectCacheFile "compiler" + let fileMonitorBuildCompiler = newFileMonitor $ distProjectCacheFile "build-compiler" + fileMonitorHostCompiler = newFileMonitor $ distProjectCacheFile "host-compiler" progsearchpath <- liftIO getSystemSearchPath - (hc, plat, hcProgDb) <- + (buildHc, buildPlat, buildHcProgDb) <- + rerunIfChanged + verbosity + fileMonitorBuildCompiler + ( buildHcFlavor + , buildHcPath + , buildHcPkg + , progsearchpath + , packageConfigProgramPaths + , packageConfigProgramPathExtra + ) + $ do + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + progdb <- + liftIO $ + -- Add paths in the global config + prependProgramSearchPath verbosity (fromNubList projectConfigProgPathExtra) [] defaultProgramDb + -- Add paths in the local config + >>= prependProgramSearchPath verbosity (fromNubList packageConfigProgramPathExtra) [] + >>= pure . userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + result@(_, _, progdb') <- + liftIO $ + Cabal.configCompiler + buildHcFlavor + buildHcPath + progdb + verbosity + -- Note that we added the user-supplied program locations and args + -- for /all/ programs, not just those for the compiler prog and + -- compiler-related utils. In principle we don't know which programs + -- the compiler will configure (and it does vary between compilers). + -- We do know however that the compiler will only configure the + -- programs it cares about, and those are the ones we monitor here. + monitorFiles (programsMonitorFiles progdb') + return result + + (hostHc, hostPlat, hostHcProgDb) <- rerunIfChanged verbosity - fileMonitorCompiler - ( hcFlavor - , hcPath - , hcPkg + fileMonitorHostCompiler + ( hostHcFlavor + , hostHcPath + , hostHcPkg , progsearchpath , packageConfigProgramPaths , packageConfigProgramPathExtra @@ -551,8 +608,8 @@ configureCompiler result@(_, _, progdb') <- liftIO $ Cabal.configCompiler - hcFlavor - hcPath + hostHcFlavor + hostHcPath progdb verbosity -- Note that we added the user-supplied program locations and args @@ -568,12 +625,32 @@ configureCompiler -- auxiliary unconfigured programs to the ProgramDb (e.g. hc-pkg, haddock, ar, ld...). -- -- See Note [Caching the result of configuring the compiler] - finalProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hc hcProgDb hcPkg - return (hc, plat, finalProgDb) + finalBuildProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity buildHc buildHcProgDb buildHcPkg + finalHostProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hostHc hostHcProgDb hostHcPkg + + return $ Staged $ \case + Build -> + Toolchain + { toolchainCompiler = buildHc + , toolchainPlatform = buildPlat + , toolchainProgramDb = finalBuildProgDb + , toolchainPackageDBs = Cabal.interpretPackageDbFlags False projectConfigBuildPackageDBs + } + Host -> + Toolchain + { toolchainCompiler = hostHc + , toolchainPlatform = hostPlat + , toolchainProgramDb = finalHostProgDb + , toolchainPackageDBs = Cabal.interpretPackageDbFlags False projectConfigPackageDBs + } where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg + hostHcFlavor = flagToMaybe projectConfigHcFlavor + hostHcPath = flagToMaybe projectConfigHcPath + hostHcPkg = flagToMaybe projectConfigHcPkg + -- Use the host compiler if a separate build compiler is not specified + buildHcFlavor = flagToMaybe projectConfigBuildHcFlavor <|> flagToMaybe projectConfigHcFlavor + buildHcPath = flagToMaybe projectConfigBuildHcPath <|> flagToMaybe projectConfigHcPath + buildHcPkg = flagToMaybe projectConfigBuildHcPkg <|> flagToMaybe projectConfigHcPkg {- Note [Caching the result of configuring the compiler] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -678,27 +755,30 @@ rebuildInstallPlan , progsearchpath ) $ do - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- + toolchains <- phaseConfigureToolchains projectConfig + phaseConfigurePrograms projectConfig toolchains + (solverPlan, _, pkgConfigDBs, totalIndexState, activeRepos) <- phaseRunSolver projectConfig - compilerEtc + toolchains localPackages (fromMaybe mempty mbInstalledPackages) - ( elaboratedPlan - , elaboratedShared - ) <- + + (elaboratedPlan, elaboratedShared) <- phaseElaboratePlan projectConfig - compilerEtc - pkgConfigDB + toolchains + pkgConfigDBs solverPlan localPackages phaseMaintainPlanOutputs elaboratedPlan elaboratedShared return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + -- \| Given the 'InstalledPackageIndex' for a nix-style package store, and an + -- 'ElaboratedInstallPlan', replace configured source packages by installed + -- packages from the store whenever they exist. + -- -- The improved plan changes each time we install something, whereas -- the underlying elaborated plan only changes when input config -- changes, so it's worth caching them separately. @@ -715,14 +795,20 @@ rebuildInstallPlan newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile -- Configure the compiler we're using. - -- + -- This is moderately expensive and doesn't change that often so we cache -- it independently. -- - phaseConfigureCompiler + phaseConfigureToolchains :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) - phaseConfigureCompiler = configureCompiler verbosity distDirLayout + -> Rebuild Toolchains + phaseConfigureToolchains projectConfig = do + toolchains <- configureToolchains verbosity distDirLayout projectConfig + liftIO $ do + putStrLn "Toolchains:" + for_ stages $ \s -> + print $ Disp.hsep [Disp.text "-" <+> pretty s <+> Disp.text "compiler" <+> pretty (compilerId (toolchainCompiler (getStage toolchains s)))] + return toolchains -- Configuring other programs. -- @@ -738,17 +824,18 @@ rebuildInstallPlan -- phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchains -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do + phaseConfigurePrograms projectConfig toolchains = do -- Users are allowed to specify program locations independently for -- each package (e.g. to use a particular version of a pre-processor -- for some packages). However they cannot do this for the compiler -- itself as that's just not going to work. So we check for this. - liftIO $ - checkBadPerPackageCompilerPaths - (configuredPrograms compilerprogdb) - (getMapMappend (projectConfigSpecificPackage projectConfig)) + for_ toolchains $ \Toolchain{toolchainProgramDb} -> + liftIO $ + checkBadPerPackageCompilerPaths + (configuredPrograms toolchainProgramDb) + (getMapMappend (projectConfigSpecificPackage projectConfig)) -- TODO: [required eventually] find/configure other programs that the -- user specifies. @@ -761,43 +848,42 @@ rebuildInstallPlan -- phaseRunSolver :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchains -> [PackageSpecifier UnresolvedSourcePackage] -> InstalledPackageIndex - -> Rebuild (SolverInstallPlan, Maybe PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) + -> Rebuild + ( SolverInstallPlan + , Staged InstalledPackageIndex + , Staged (Maybe PkgConfigDb) + , IndexUtils.TotalIndexState + , IndexUtils.ActiveRepos + ) phaseRunSolver projectConfig@ProjectConfig { projectConfigShared , projectConfigBuildOnly } - (compiler, platform, progdb) + toolchains localPackages - installedPackages = + _installedPackages = rerunIfChanged verbosity fileMonitorSolverPlan ( solverSettings , localPackages , localPackagesEnabledStanzas - , compiler - , platform - , programDbSignature progdb + , toolchains ) $ do - installedPkgIndex <- - getInstalledPackages - verbosity - compiler - progdb - platform - corePackageDbs (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx (solverSettingIndexState solverSettings) (solverSettingActiveRepos solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb + + ipis <- for toolchains (getInstalledPackages verbosity) + pkgConfigDbs <- for toolchains (getPkgConfigDb verbosity . toolchainProgramDb) -- TODO: [code cleanup] it'd be better if the Compiler contained the -- ConfiguredPrograms that it needs, rather than relying on the progdb @@ -810,23 +896,25 @@ rebuildInstallPlan foldProgress logMsg (pure . Left) (pure . Right) $ planPackages verbosity - compiler - platform solverSettings - (installedPackages <> installedPkgIndex) + compilerAndPlatform + pkgConfigDbs + ipis sourcePkgDb - pkgConfigDB localPackages localPackagesEnabledStanzas case planOrError of Left msg -> do - reportPlanningFailure projectConfig compiler platform localPackages + -- TODO + for_ toolchains $ \(Toolchain{toolchainCompiler, toolchainPlatform}) -> + reportPlanningFailure projectConfig toolchainCompiler toolchainPlatform localPackages dieWithException verbosity $ PhaseRunSolverErr msg - Right plan -> return (plan, pkgConfigDB, tis, ar) + Right plan -> return (plan, ipis, pkgConfigDbs, tis, ar) where - corePackageDbs :: PackageDBStackCWD - corePackageDbs = - Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared) + compilerAndPlatform = + fmap + (\Toolchain{toolchainCompiler, toolchainPlatform} -> (compilerInfo toolchainCompiler, toolchainPlatform)) + toolchains withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = @@ -875,8 +963,8 @@ rebuildInstallPlan -- phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> Maybe PkgConfigDb + -> Staged Toolchain + -> Staged (Maybe PkgConfigDb) -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Rebuild @@ -891,7 +979,7 @@ rebuildInstallPlan , projectConfigSpecificPackage , projectConfigBuildOnly } - (compiler, platform, progdb) + toolchains pkgConfigDB solverPlan localPackages = do @@ -904,15 +992,16 @@ rebuildInstallPlan (packageLocationsSignature solverPlan) $ getPackageSourceHashes verbosity withRepoCtx solverPlan - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) - (elaboratedPlan, elaboratedShared) <- - liftIO . runLogProgress verbosity $ + installDirs <- + for toolchains $ \t -> do + defaultInstallDirs <- liftIO $ userInstallDirTemplates (toolchainCompiler t) + return $ fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) + + liftIO $ runLogProgress verbosity $ do + (elaboratedPlan, elaboratedShared) <- elaborateInstallPlan verbosity - platform - compiler - progdb + toolchains pkgConfigDB distDirLayout cabalStoreDirLayout @@ -924,14 +1013,17 @@ rebuildInstallPlan projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan = - instantiateInstallPlan - cabalStoreDirLayout - installDirs - elaboratedShared - elaboratedPlan - liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan instantiatedPlan) - return (instantiatedPlan, elaboratedShared) + + instantiatedPlan <- + instantiateInstallPlan + cabalStoreDirLayout + installDirs + elaboratedShared + elaboratedPlan + + infoProgress $ text "Elaborated install plan:" $$ text (showElaboratedInstallPlan instantiatedPlan) + + return (instantiatedPlan, elaboratedShared) where withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = @@ -971,11 +1063,7 @@ rebuildInstallPlan -> Rebuild ElaboratedInstallPlan phaseImprovePlan elaboratedPlan elaboratedShared = do liftIO $ debug verbosity "Improving the install plan..." - storePkgIdSet <- getStoreEntries cabalStoreDirLayout compiler - let improvedPlan = - improveInstallPlanWithInstalledPackages - storePkgIdSet - elaboratedPlan + improvedPlan <- liftIO $ InstallPlan.installedM canBeImproved elaboratedPlan liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan) -- TODO: [nice to have] having checked which packages from the store -- we're using, it may be sensible to sanity check those packages @@ -983,7 +1071,9 @@ rebuildInstallPlan -- matches up as expected, e.g. no dangling deps, files deleted. return improvedPlan where - compiler = pkgConfigCompiler elaboratedShared + canBeImproved pkg = do + let Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains elaboratedShared) (elabStage pkg) + doesStoreEntryExist cabalStoreDirLayout toolchainCompiler (installedUnitId pkg) -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. @@ -1036,44 +1126,28 @@ programsMonitorFiles progdb = (programPath prog) ] --- | Select the bits of a 'ProgramDb' to monitor for value changes. --- Use 'programsMonitorFiles' for the files to monitor. -programDbSignature :: ProgramDb -> [ConfiguredProgram] -programDbSignature progdb = - [ prog - { programMonitorFiles = [] - , programOverrideEnv = - filter - ((/= "PATH") . fst) - (programOverrideEnv prog) - } - | prog <- configuredPrograms progdb - ] - getInstalledPackages :: Verbosity - -> Compiler - -> ProgramDb - -> Platform - -> PackageDBStackCWD + -> Toolchain -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory +getInstalledPackages verbosity Toolchain{..} = do + monitorFiles + . map monitorFileOrDirectory =<< liftIO ( IndexUtils.getInstalledPackagesMonitorFiles verbosity - compiler + toolchainCompiler Nothing -- use ambient working directory - (coercePackageDBStack packagedbs) - progdb - platform + (coercePackageDBStack toolchainPackageDBs) + toolchainProgramDb + toolchainPlatform ) liftIO $ IndexUtils.getInstalledPackages verbosity - compiler - packagedbs - progdb + toolchainCompiler + toolchainPackageDBs + toolchainProgramDb {- --TODO: [nice to have] use this but for sanity / consistency checking @@ -1101,9 +1175,10 @@ getSourcePackages getSourcePackages verbosity withRepoCtx idxState activeRepos = do (sourcePkgDbWithTIS, repos) <- liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos - return (sourcePkgDbWithTIS, repoContextRepos repoctx) + withRepoCtx $ + \repoctx -> do + sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos + return (sourcePkgDbWithTIS, repoContextRepos repoctx) traverse_ needIfExists . IndexUtils.getSourcePackagesMonitorFiles @@ -1226,8 +1301,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do -- the hashes for the packages -- hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ -- TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ + Sec.uncheckClientErrors $ + fmap (Map.fromList . concat) $ -- TODO: [code cleanup] wrap in our own exceptions sequence -- Reading the repo index is expensive so we group the packages by repo [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> @@ -1305,30 +1380,24 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do planPackages :: Verbosity - -> Compiler - -> Platform -> SolverSettings - -> InstalledPackageIndex + -> Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> SourcePackageDb - -> Maybe PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> Map PackageName (Map OptionalStanza Bool) -> Progress String String SolverInstallPlan planPackages verbosity - comp - platform SolverSettings{..} - installedPkgIndex - sourcePkgDb - pkgConfigDB + toolchains + pkgConfigDbs + installedPkgs + sourcePkgs localPackages pkgStanzasEnable = - resolveDependencies - platform - (compilerInfo comp) - pkgConfigDB - resolverParams + resolveDependencies toolchains pkgConfigDbs installedPkgs resolverParams where -- TODO: [nice to have] disable multiple instances restriction in -- the solver, but then make sure we can cope with that in the @@ -1368,14 +1437,18 @@ planPackages . removeLowerBounds solverSettingAllowOlder . removeUpperBounds solverSettingAllowNewer - . addDefaultSetupDependencies - setImplicitSetupInfo - ( mkDefaultSetupDeps comp platform - . PD.packageDescription - . srcpkgDescription - ) - . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint - . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + -- + -- TODO: These need to be per compiler. We should be able to do that + -- when we can use the stage as a solver scope + -- + -- . addDefaultSetupDependencies + -- ( mkDefaultSetupDeps compiler platform + -- . PD.packageDescription + -- . srcpkgDescription + -- ) + -- . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint + -- . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + -- . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver @@ -1399,7 +1472,9 @@ planPackages , not (null stanzas) ] . addConstraints - -- enable stanza constraints where the user asked to enable + -- Enable stanza constraints where the user asked to enable + -- Only applies to the host stage. + -- TODO: Disable test and bench for build stage packages. [ LabeledPackageConstraint ( PackageConstraint (scopeToplevel pkgname) @@ -1448,81 +1523,9 @@ planPackages -- Note: we don't use the standardInstallPolicy here, since that uses -- its own addDefaultSetupDependencies that is not appropriate for us. basicInstallPolicy - installedPkgIndex - sourcePkgDb + sourcePkgs localPackages - -- While we can talk to older Cabal versions (we need to be able to - -- do so for custom Setup scripts that require older Cabal lib - -- versions), we have problems talking to some older versions that - -- don't support certain features. - -- - -- For example, Cabal-1.16 and older do not know about build targets. - -- Even worse, 1.18 and older only supported the --constraint flag - -- with source package ids, not --dependency with installed package - -- ids. That is bad because we cannot reliably select the right - -- dependencies in the presence of multiple instances (i.e. the - -- store). See issue #3932. So we require Cabal 1.20 as a minimum. - -- - -- Moreover, lib:Cabal generally only supports the interface of - -- current and past compilers; in fact recent lib:Cabal versions - -- will warn when they encounter a too new or unknown GHC compiler - -- version (c.f. #415). To avoid running into unsupported - -- configurations we encode the compatibility matrix as lower - -- bounds on lib:Cabal here (effectively corresponding to the - -- respective major Cabal version bundled with the respective GHC - -- release). - -- - -- GHC 9.2 needs Cabal >= 3.6 - -- GHC 9.0 needs Cabal >= 3.4 - -- GHC 8.10 needs Cabal >= 3.2 - -- GHC 8.8 needs Cabal >= 3.0 - -- GHC 8.6 needs Cabal >= 2.4 - -- GHC 8.4 needs Cabal >= 2.2 - -- GHC 8.2 needs Cabal >= 2.0 - -- GHC 8.0 needs Cabal >= 1.24 - -- - -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is - -- the absolute lower bound) - -- - -- TODO: long-term, this compatibility matrix should be - -- stored as a field inside 'Distribution.Compiler.Compiler' - setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [9, 10] = mkVersion [3, 12] - | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10] - | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8] - | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6] - | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4] - | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2] - | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0] - | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4] - | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2] - | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0] - | otherwise = mkVersion [1, 24] - where - isGHC = compFlav `elem` [GHC, GHCJS] - compFlav = compilerFlavor comp - compVer = compilerVersion comp - - -- As we can't predict the future, we also place a global upper - -- bound on the lib:Cabal version we know how to interact with: - -- - -- The upper bound is computed by incrementing the current major - -- version twice in order to allow for the current version, as - -- well as the next adjacent major version (one of which will not - -- be released, as only "even major" versions of Cabal are - -- released to Hackage or bundled with proper GHC releases). - -- - -- For instance, if the current version of cabal-install is an odd - -- development version, e.g. Cabal-2.1.0.0, then we impose an - -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a - -- stable/release even version, e.g. Cabal-2.2.1.0, the upper - -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility - -- when dealing with development snapshots of Cabal and cabal-install. - -- - setupMaxCabalVersionConstraint = - alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion - ------------------------------------------------------------------------------ -- * Install plan post-processing @@ -1628,16 +1631,14 @@ planPackages -- matching that of the classic @cabal install --user@ or @--global@ elaborateInstallPlan :: Verbosity - -> Platform - -> Compiler - -> ProgramDb - -> Maybe PkgConfigDb + -> Staged Toolchain + -> Staged (Maybe PkgConfigDb) -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Map PackageId PackageSourceHash - -> InstallDirs.InstallDirTemplates + -> Staged InstallDirs.InstallDirTemplates -> ProjectConfigShared -> PackageConfig -> PackageConfig @@ -1645,9 +1646,7 @@ elaborateInstallPlan -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) elaborateInstallPlan verbosity - platform - compiler - compilerprogdb + toolchains pkgConfigDB distDirLayout@DistDirLayout{..} storeDirLayout@StoreDirLayout{storePackageDBStack} @@ -1664,9 +1663,7 @@ elaborateInstallPlan where elaboratedSharedConfig = ElaboratedSharedConfig - { pkgConfigPlatform = platform - , pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = compilerprogdb + { pkgConfigToolchains = toolchains , pkgConfigReplOptions = mempty } @@ -1686,13 +1683,12 @@ elaborateInstallPlan ) f _ = Nothing - elaboratedInstallPlan - :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) + elaboratedInstallPlan :: LogProgress ElaboratedInstallPlan elaboratedInstallPlan = flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> case planpkg of SolverInstallPlan.PreExisting pkg -> - return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + return [InstallPlan.PreExisting (WithStage (instSolverStage pkg) (instSolverPkgIPI pkg))] SolverInstallPlan.Configured pkg -> let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" @@ -1708,348 +1704,400 @@ elaborateInstallPlan -- NB: We don't INSTANTIATE packages at this point. That's -- a post-pass. This makes it simpler to compute dependencies. elaborateSolverToComponents - :: (SolverId -> [ElaboratedPlanPackage]) + :: HasCallStack + => (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) = - case mkComponentsGraph (elabEnabledSpec elab0) pd of - Right g -> do - let src_comps = componentsGraphToList g - infoProgress $ - hang - (text "Component graph for" <+> pretty pkgid <<>> colon) - 4 - (dispComponentsWithDeps src_comps) - (_, comps) <- - mapAccumM - buildComponent - (Map.empty, Map.empty, Map.empty) - (map fst src_comps) - let whyNotPerComp = why_not_per_component src_comps - case NE.nonEmpty whyNotPerComp of - Nothing -> do - elaborationWarnings - return comps - Just notPerCompReasons -> do - checkPerPackageOk comps notPerCompReasons - pkgComp <- - elaborateSolverToPackage - notPerCompReasons - spkg - g - (comps ++ maybeToList setupComponent) - return [pkgComp] - Left cns -> - dieProgress $ - hang - (text "Dependency cycle between the following components:") - 4 - (vcat (map (text . componentNameStanza) cns)) - where - bt = PD.buildType (elabPkgDescription elab0) - -- You are eligible to per-component build if this list is empty - why_not_per_component g = - cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag - where - -- Custom and Hooks are not implemented. Implementing - -- per-component builds with Custom would require us to create a - -- new 'ElabSetup' type, and teach all of the code paths how to - -- handle it. - -- Once you've implemented this, swap it for the code below. - -- (See #9986 for more information about this task.) - cuz_buildtype = - case bt of - PD.Configure -> [] - -- Configure is supported, but we only support configuring the - -- main library in cabal. Other components will need to depend - -- on the main library for configured data. - PD.Custom -> [CuzBuildType CuzCustomBuildType] - PD.Make -> [CuzBuildType CuzMakeBuildType] - PD.Simple -> [] - -- TODO: remove the following, once we make Setup a separate - -- component (task tracked at #9986). - PD.Hooks -> [CuzBuildType CuzHooksBuildType] - - -- cabal-format versions prior to 1.8 have different build-depends semantics - -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 - -- see, https://github.com/haskell/cabal/issues/4121 - cuz_spec - | PD.specVersion pd >= CabalSpecV1_8 = [] - | otherwise = [CuzCabalSpecVersion] - -- In the odd corner case that a package has no components at all - -- then keep it as a whole package, since otherwise it turns into - -- 0 component graph nodes and effectively vanishes. We want to - -- keep it around at least for error reporting purposes. - cuz_length - | length g > 0 = [] - | otherwise = [CuzNoBuildableComponents] - -- For ease of testing, we let per-component builds be toggled - -- at the top level - cuz_flag - | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = - [] - | otherwise = [CuzDisablePerComponent] - - -- \| Sometimes a package may make use of features which are only - -- supported in per-package mode. If this is the case, we should - -- give an error when this occurs. - checkPerPackageOk comps reasons = do - let is_sublib (CLibName (LSubLibName _)) = True - is_sublib _ = False - when (any (matchElabPkg is_sublib) comps) $ + elaborateSolverToComponents + mapDep + solverPkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} = + case mkComponentsGraph (elabEnabledSpec elab0) pd of + Left cns -> dieProgress $ - text "Internal libraries only supported with per-component builds." - $$ text "Per-component builds were disabled because" - <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) - -- TODO: Maybe exclude Backpack too - - (elab0, elaborationWarnings) = elaborateSolverToCommon spkg - pkgid = elabPkgSourceId elab0 - pd = elabPkgDescription elab0 - - -- TODO: This is just a skeleton to get elaborateSolverToPackage - -- working correctly - -- TODO: When we actually support building these components, we - -- have to add dependencies on this from all other components - setupComponent :: Maybe ElaboratedConfiguredPackage - setupComponent - | bt `elem` [PD.Custom, PD.Hooks] = - Just - elab0 - { elabModuleShape = emptyModuleShape - , elabUnitId = notImpl "elabUnitId" - , elabComponentId = notImpl "elabComponentId" - , elabLinkedInstantiatedWith = Map.empty - , elabInstallDirs = notImpl "elabInstallDirs" - , elabPkgOrComp = ElabComponent (ElaboratedComponent{..}) - } - | otherwise = - Nothing - where - compSolverName = CD.ComponentSetup - compComponentName = Nothing - - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 - - compLibDependencies = - -- MP: No idea what this function does - map (\cid -> (configuredId cid, False)) dep_pkgs - compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - compOrderLibDependencies = notImpl "compOrderLibDependencies" - - -- Not supported: - compExeDependencies :: [a] - compExeDependencies = [] - - compExeDependencyPaths :: [a] - compExeDependencyPaths = [] - - compPkgConfigDependencies :: [a] - compPkgConfigDependencies = [] - - notImpl f = - error $ - "Distribution.Client.ProjectPlanning.setupComponent: " - ++ f - ++ " not implemented yet" - - buildComponent - :: ( ConfiguredComponentMap - , LinkedComponentMap - , Map ComponentId FilePath - ) - -> Cabal.Component - -> LogProgress - ( ( ConfiguredComponentMap - , LinkedComponentMap - , Map ComponentId FilePath + hang + (text "Dependency cycle between the following components:") + 4 + (vcat (map (text . componentNameStanza) cns)) + Right g -> do + let src_comps = componentsGraphToList g + + infoProgress $ + hang + (text "Component graph for" <+> pretty (solverId (ResolverPackage.Configured solverPkg))) + 4 + (dispComponentsWithDeps src_comps) + + (_, comps) <- + mapAccumM + buildComponent + (Map.empty, Map.empty, Map.empty) + (map fst src_comps) + + let whyNotPerComp = why_not_per_component src_comps + + case NE.nonEmpty whyNotPerComp of + Nothing -> + return comps + Just notPerCompReasons -> do + checkPerPackageOk comps notPerCompReasons + pkgComp <- + elaborateSolverToPackage + notPerCompReasons + solverPkg + g + (comps ++ maybeToList setupComponent) + return [pkgComp] + where + bt = PD.buildType (elabPkgDescription elab0) + + -- You are eligible to per-component build if this list is empty + why_not_per_component g = + cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag + where + -- Custom and Hooks are not implemented. Implementing + -- per-component builds with Custom would require us to create a + -- new 'ElabSetup' type, and teach all of the code paths how to + -- handle it. + -- Once you've implemented this, swap it for the code below. + cuz_buildtype = + case bt of + PD.Configure -> [] + -- Configure is supported, but we only support configuring the + -- main library in cabal. Other components will need to depend + -- on the main library for configured data. + PD.Custom -> [CuzBuildType CuzCustomBuildType] + PD.Hooks -> [CuzBuildType CuzHooksBuildType] + PD.Make -> [CuzBuildType CuzMakeBuildType] + PD.Simple -> [] + -- cabal-format versions prior to 1.8 have different build-depends semantics + -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 + -- see, https://github.com/haskell/cabal/issues/4121 + cuz_spec + | PD.specVersion pd >= CabalSpecV1_8 = [] + | otherwise = [CuzCabalSpecVersion] + -- In the odd corner case that a package has no components at all + -- then keep it as a whole package, since otherwise it turns into + -- 0 component graph nodes and effectively vanishes. We want to + -- keep it around at least for error reporting purposes. + cuz_length + | length g > 0 = [] + | otherwise = [CuzNoBuildableComponents] + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = + [] + | otherwise = [CuzDisablePerComponent] + + -- \| Sometimes a package may make use of features which are only + -- supported in per-package mode. If this is the case, we should + -- give an error when this occurs. + checkPerPackageOk comps reasons = do + let is_sublib (CLibName (LSubLibName _)) = True + is_sublib _ = False + when (any (matchElabPkg is_sublib) comps) $ + dieProgress $ + text "Internal libraries only supported with per-component builds." + $$ text "Per-component builds were disabled because" + <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) + -- TODO: Maybe exclude Backpack too + + (elab0, _) = elaborateSolverToCommon solverPkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + -- TODO: This is just a skeleton to get elaborateSolverToPackage + -- working correctly + -- TODO: When we actually support building these components, we + -- have to add dependencies on this from all other components + setupComponent :: Maybe ElaboratedConfiguredPackage + setupComponent + | bt `elem` [PD.Custom, PD.Hooks] = + Just + elab0 + { elabModuleShape = emptyModuleShape + , elabUnitId = notImpl "elabUnitId" + , elabComponentId = notImpl "elabComponentId" + , elabInstallDirs = notImpl "elabInstallDirs" + , elabPkgOrComp = + ElabComponent + ( ElaboratedComponent + { compSolverName = CD.ComponentSetup + , compComponentName = Nothing + , compLibDependencies = + [ (configuredId cid, False) + | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep + ] + , compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + , compOrderLibDependencies = notImpl "compOrderLibDependencies" + , -- Not supported: + compExeDependencies = mempty + , compExeDependencyPaths = mempty + , compPkgConfigDependencies = mempty + , compInstantiatedWith = mempty + , compLinkedInstantiatedWith = Map.empty + } + ) + } + | otherwise = + Nothing + where + notImpl f = + error $ + "Distribution.Client.ProjectPlanning.setupComponent: " + ++ f + ++ " not implemented yet" + + -- Note: this function is used to configure the components in a single package (`elab`, defined in the outer scope) + buildComponent + :: HasCallStack + => ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) + , Map ComponentId FilePath + ) + -> Cabal.Component + -> LogProgress + ( ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) + , Map ComponentId FilePath + ) + , ElaboratedConfiguredPackage ) - , ElaboratedConfiguredPackage + buildComponent (cc_map, lc_map, exe_map) comp = + addProgressCtx + ( text "In the stanza" + <+> quotes (text (componentNameStanza cname)) ) - buildComponent (cc_map, lc_map, exe_map) comp = - addProgressCtx - ( text "In the stanza" - <+> quotes (text (componentNameStanza cname)) - ) - $ do - -- 1. Configure the component, but with a place holder ComponentId. - cc0 <- - toConfiguredComponent - pd - (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") - (Map.unionWith Map.union external_lib_cc_map cc_map) - (Map.unionWith Map.union external_exe_cc_map cc_map) - comp - - let do_ cid = - let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid - in (cid', False) -- filled in later in pruneInstallPlanPhase2) - -- 2. Read out the dependencies from the ConfiguredComponent cc0 - let compLibDependencies = - -- Nub because includes can show up multiple times - ordNub - ( map - (\cid -> do_ cid) - (cc_includes cc0) - ) - compExeDependencies = - map - annotatedIdToConfiguredId - (cc_exe_deps cc0) - compExeDependencyPaths = - [ (annotatedIdToConfiguredId aid', path) - | aid' <- cc_exe_deps cc0 - , Just paths <- [Map.lookup (ann_id aid') exe_map1] - , path <- paths - ] - elab_comp = ElaboratedComponent{..} - - -- 3. Construct a preliminary ElaboratedConfiguredPackage, - -- and use this to compute the component ID. Fix up cc_id - -- correctly. - let elab1 = - elab0 - { elabPkgOrComp = ElabComponent elab_comp + $ do + let lib_dep_map = Map.unionWith Map.union external_lib_cc_map cc_map + -- TODO: is cc_map correct here? + exe_dep_map = Map.unionWith Map.union external_exe_cc_map cc_map + + -- 1. Configure the component, but with a place holder ComponentId. + infoProgress $ + hang (text "configuring component" <+> pretty cname) 4 $ + vcat + [ text "lib_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys lib_dep_map)) + , text "exe_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys exe_dep_map)) + ] + + cc0 <- + toConfiguredComponent + pd + (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") + lib_dep_map + exe_dep_map + comp + + let do_ cid = + let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid + in (cid', False) -- filled in later in pruneInstallPlanPhase2) + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub + ( map + (\cid -> do_ cid) + (cc_includes cc0) + ) + + compExeDependencies :: [WithStage ConfiguredId] + compExeDependencies = + -- External + [ WithStage (stageOf pkg) confId + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , -- only executables + Just (CExeName _) <- [confCompName confId] + , confSrcId confId /= pkgid + ] + <> + -- Internal, assume the same stage + [ WithStage solverPkgStage confId + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + ] + + compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] + compExeDependencyPaths = + -- External + [ (WithStage (stageOf pkg) confId, path) + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , confSrcId confId /= pkgid + , -- only executables + Just (CExeName _) <- [confCompName confId] + , path <- planPackageExePaths pkg + ] + <> + -- Internal, assume the same stage + [ (WithStage solverPkgStage confId, path) + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + , Just paths <- [Map.lookup (ann_id aid) exe_map1] + , path <- paths + ] + + elab_comp = + ElaboratedComponent + { compSolverName + , compComponentName + , compLibDependencies + , compExeDependencies + , compPkgConfigDependencies + , compExeDependencyPaths + , compInstantiatedWith = Map.empty + , compLinkedInstantiatedWith = Map.empty + , -- filled later (in step 5) + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + , compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" + } + + -- 3. Construct a preliminary ElaboratedConfiguredPackage, + -- and use this to compute the component ID. Fix up cc_id + -- correctly. + let elab1 = + elab0 + { elabPkgOrComp = ElabComponent elab_comp + } + + -- This is where the component id is computed. + cid = case elabBuildStyle elab0 of + BuildInplaceOnly{} -> + mkComponentId $ + case Cabal.componentNameString cname of + Nothing -> prettyShow pkgid + Just n -> prettyShow pkgid ++ "-" ++ prettyShow n + BuildAndInstall -> + hashedInstalledPackageId + ( packageHashInputs + elaboratedSharedConfig + elab1 -- knot tied + ) + + cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} + + -- 4. Perform mix-in linking + let lookup_uid def_uid = + case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of + Just full -> full + Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) + lc_dep_map = Map.union external_lc_map lc_map + lc <- + toLinkedComponent + verbosity + False + -- \^ whether there are any "promised" package dependencies which we won't find already installed + lookup_uid + -- \^ full db + (elabPkgSourceId elab0) + -- \^ the source package id + lc_dep_map + -- \^ linked component map + cc + -- \^ configured component + + -- NB: elab is setup to be the correct form for an + -- indefinite library, or a definite library with no holes. + -- We will modify it in 'instantiateInstallPlan' to handle + -- instantiated packages. + + -- 5. Construct the final ElaboratedConfiguredPackage + let + elab2 = + elab1 + { elabModuleShape = lc_shape lc + , elabUnitId = abstractUnitId (lc_uid lc) + , elabComponentId = lc_cid lc + , elabPkgOrComp = + ElabComponent $ + elab_comp + { compLinkedLibDependencies = + ordNub (map ci_id (lc_includes lc)) + , compOrderLibDependencies = + ordNub + ( map + (abstractUnitId . ci_id) + (lc_includes lc ++ lc_sig_includes lc) + ) + , compLinkedInstantiatedWith = + Map.fromList (lc_insts lc) + } } - cid = case elabBuildStyle elab0 of - BuildInplaceOnly{} -> - mkComponentId $ - prettyShow pkgid - ++ "-inplace" - ++ ( case Cabal.componentNameString cname of - Nothing -> "" - Just s -> "-" ++ prettyShow s - ) - BuildAndInstall -> - hashedInstalledPackageId - ( packageHashInputs + elab = + elab2 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs elaboratedSharedConfig - elab1 -- knot tied - ) - cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} - infoProgress $ dispConfiguredComponent cc - - -- 4. Perform mix-in linking - let lookup_uid def_uid = - case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of - Just full -> full - Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) - lc <- - toLinkedComponent - verbosity - False - lookup_uid - (elabPkgSourceId elab0) - (Map.union external_lc_map lc_map) - cc - infoProgress $ dispLinkedComponent lc - -- NB: elab is setup to be the correct form for an - -- indefinite library, or a definite library with no holes. - -- We will modify it in 'instantiateInstallPlan' to handle - -- instantiated packages. - - -- 5. Construct the final ElaboratedConfiguredPackage - let - elab2 = - elab1 - { elabModuleShape = lc_shape lc - , elabUnitId = abstractUnitId (lc_uid lc) - , elabComponentId = lc_cid lc - , elabLinkedInstantiatedWith = Map.fromList (lc_insts lc) - , elabPkgOrComp = - ElabComponent $ - elab_comp - { compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)) - , compOrderLibDependencies = - ordNub - ( map - (abstractUnitId . ci_id) - (lc_includes lc ++ lc_sig_includes lc) - ) - } - } - elab = - elab2 - { elabInstallDirs = - computeInstallDirs - storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab2 - } + elab2 + } - -- 6. Construct the updated local maps - let cc_map' = extendConfiguredComponentMap cc cc_map - lc_map' = extendLinkedComponentMap lc lc_map - exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + -- 6. Construct the updated local maps + let cc_map' = extendConfiguredComponentMap cc cc_map + lc_map' = extendLinkedComponentMap lc lc_map + exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map - return ((cc_map', lc_map', exe_map'), elab) - where - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - - cname = Cabal.componentName comp - compComponentName = Just cname - compSolverName = CD.componentNameToComponent cname - - -- NB: compLinkedLibDependencies and - -- compOrderLibDependencies are defined when we define - -- 'elab'. - external_lib_dep_sids = CD.select (== compSolverName) deps0 - external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 - - external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids - - -- Combine library and build-tool dependencies, for backwards - -- compatibility (See issue #5412 and the documentation for - -- InstallPlan.fromSolverInstallPlan), but prefer the versions - -- specified as build-tools. - external_exe_dep_pkgs = - concatMap mapDep $ - ordNubBy (pkgName . packageId) $ - external_exe_dep_sids ++ external_lib_dep_sids - - external_exe_map = - Map.fromList $ - [ (getComponentId pkg, paths) - | pkg <- external_exe_dep_pkgs - , let paths = planPackageExePaths pkg + return ((cc_map', lc_map', exe_map'), elab) + where + cname = Cabal.componentName comp + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname + + -- External dependencies. I.e. dependencies of the component on components of other packages. + external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps + + external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps + + external_exe_map = + Map.fromList $ + [ (getComponentId pkg, planPackageExePaths pkg) + | pkg <- external_exe_dep_pkgs + ] + + exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map + + external_lib_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_lib_dep_pkgs + + external_exe_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_exe_dep_pkgs + + external_lc_map = + Map.fromList $ + map mkShapeMapping $ + external_lib_dep_pkgs ++ external_exe_dep_pkgs + + compPkgConfigDependencies = + [ ( pn + , fromMaybe + ( error $ + "compPkgConfigDependencies: impossible! " + ++ prettyShow pn + ++ " from " + ++ prettyShow (elabPkgSourceId elab0) + ) + (getStage pkgConfigDB (elabStage elab0) >>= \db -> pkgConfigDbPkgVersion db pn) + ) + | PkgconfigDependency pn _ <- + PD.pkgconfigDepends + (Cabal.componentBuildInfo comp) ] - exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map - - external_lib_cc_map = - Map.fromListWith Map.union $ - map mkCCMapping external_lib_dep_pkgs - external_exe_cc_map = - Map.fromListWith Map.union $ - map mkCCMapping external_exe_dep_pkgs - external_lc_map = - Map.fromList $ - map mkShapeMapping $ - external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids - - compPkgConfigDependencies = - [ ( pn - , fromMaybe - ( error $ - "compPkgConfigDependencies: impossible! " - ++ prettyShow pn - ++ " from " - ++ prettyShow (elabPkgSourceId elab0) - ) - (pkgConfigDB >>= \db -> pkgConfigDbPkgVersion db pn) - ) - | PkgconfigDependency pn _ <- - PD.pkgconfigDepends - (Cabal.componentBuildInfo comp) - ] - inplace_bin_dir elab = - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab - $ maybe "" prettyShow (Cabal.componentNameString cname) + inplace_bin_dir elab = + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab + $ case Cabal.componentNameString cname of + Just n -> prettyShow n + Nothing -> "" -- \| Given a 'SolverId' referencing a dependency on a library, return -- the 'ElaboratedPlanPackage' corresponding to the library. This @@ -2100,13 +2148,7 @@ elaborateInstallPlan -> LogProgress ElaboratedConfiguredPackage elaborateSolverToPackage pkgWhyNotPerComponent - pkg@( SolverPackage - (SourcePackage pkgid _gpd _srcloc _descOverride) - _flags - _stanzas - _deps0 - _exe_deps0 - ) + solverPkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}} compGraph comps = do -- Knot tying: the final elab includes the @@ -2115,15 +2157,17 @@ elaborateInstallPlan elaborationWarnings return elab where - (elab0@ElaboratedConfiguredPackage{..}, elaborationWarnings) = - elaborateSolverToCommon pkg + (elab0@ElaboratedConfiguredPackage + { elabPkgSourceHash + , elabStanzasRequested + , elabStage + }, elaborationWarnings) = elaborateSolverToCommon solverPkg elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId , elabComponentId = pkgInstalledId - , elabLinkedInstantiatedWith = Map.empty - , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..} + , elabPkgOrComp = ElabPackage elabPkg , elabModuleShape = modShape } @@ -2144,8 +2188,8 @@ elaborateInstallPlan (find (matchElabPkg (== (CLibName LMainLibName))) comps) pkgInstalledId - | shouldBuildInplaceOnly pkg = - mkComponentId (prettyShow pkgid ++ "-inplace") + | shouldBuildInplaceOnly solverPkg = + mkComponentId (prettyShow srcpkgPackageId) | otherwise = assert (isJust elabPkgSourceHash) $ hashedInstalledPackageId @@ -2156,34 +2200,44 @@ elaborateInstallPlan -- Need to filter out internal dependencies, because they don't -- correspond to anything real anymore. - isExt confid = confSrcId confid /= pkgid - filterExt = filter isExt - - filterExt' :: [(ConfiguredId, a)] -> [(ConfiguredId, a)] - filterExt' = filter (isExt . fst) - - pkgLibDependencies = - buildComponentDeps (filterExt' . compLibDependencies) - pkgExeDependencies = - buildComponentDeps (filterExt . compExeDependencies) - pkgExeDependencyPaths = - buildComponentDeps (filterExt' . compExeDependencyPaths) - - -- TODO: Why is this flat? - pkgPkgConfigDependencies = - fold $ buildComponentDeps compPkgConfigDependencies + isExternal confid = confSrcId confid /= srcpkgPackageId + isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId + + elabPkg = + ElaboratedPackage + { pkgStage = elabStage + , pkgInstalledId + , pkgLibDependencies = buildComponentDeps (filter (isExternal . fst) . compLibDependencies) + , pkgDependsOnSelfLib + , pkgExeDependencies = buildComponentDeps (filter isExternal' . compExeDependencies) + , pkgExeDependencyPaths = buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths) + , -- Why is this flat? + pkgPkgConfigDependencies = concatMap snd . CD.toList $ buildComponentDeps compPkgConfigDependencies + , -- NB: This is not the final setting of 'pkgStanzasEnabled'. + -- See [Sticky enabled testsuites]; we may enable some extra + -- stanzas opportunistically when it is cheap to do so. + -- + -- However, we start off by enabling everything that was + -- requested, so that we can maintain an invariant that + -- pkgStanzasEnabled is a superset of elabStanzasRequested + pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + , pkgWhyNotPerComponent + } + -- This tells us which components depend on the main library of this package. + -- Note: the sublib case should not occur, because sub-libraries are not + -- supported without per-component builds. + -- TODO: Add a check somewhere that this is the case. + pkgDependsOnSelfLib :: CD.ComponentDeps [()] pkgDependsOnSelfLib = CD.fromList [ (CD.componentNameToComponent cn, [()]) - | Graph.N _ cn _ <- fromMaybe [] mb_closure + | Graph.N _ cn _ <- closure ] where - mb_closure = Graph.revClosure compGraph [k | k <- Graph.keys compGraph, is_lib k] - -- NB: the sublib case should not occur, because sub-libraries - -- are not supported without per-component builds - is_lib (CLibName _) = True - is_lib _ = False + closure = + fromMaybe (error "elaborateSolverToPackage: internal error, no closure for main lib") $ + Graph.revClosure compGraph [k | k@(CLibName LMainLibName) <- Graph.keys compGraph] buildComponentDeps :: Monoid a => (ElaboratedComponent -> a) -> CD.ComponentDeps a buildComponentDeps f = @@ -2192,69 +2246,79 @@ elaborateInstallPlan | ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} <- comps ] - -- NB: This is not the final setting of 'pkgStanzasEnabled'. - -- See [Sticky enabled testsuites]; we may enable some extra - -- stanzas opportunistically when it is cheap to do so. - -- - -- However, we start off by enabling everything that was - -- requested, so that we can maintain an invariant that - -- pkgStanzasEnabled is a superset of elabStanzasRequested - pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc -> (ElaboratedConfiguredPackage, LogProgress ()) elaborateSolverToCommon - pkg@( SolverPackage - (SourcePackage pkgid gdesc srcloc descOverride) - flags - stanzas - deps0 - _exe_deps0 - ) = - (elaboratedPackage, wayWarnings pkgid >> buildOptionsAdjustmentWarnings) + solverPkg@SolverPackage + { solverPkgStage + , solverPkgSource = + SourcePackage + { srcpkgPackageId + , srcpkgDescription + , srcpkgSource + , srcpkgDescrOverride + } + , solverPkgFlags + , solverPkgStanzas + , solverPkgLibDeps + } = + (elaboratedPackage, buildOptionsAdjustmentWarnings) where + compilers = fmap toolchainCompiler toolchains + platforms = fmap toolchainPlatform toolchains + programDbs = fmap toolchainProgramDb toolchains + packageDbs = fmap toolchainPackageDBs toolchains + elaboratedPackage = ElaboratedConfiguredPackage{..} buildOptionsAdjustmentWarnings :: LogProgress () buildOptionsAdjustmentWarnings = mapM_ (warnProgress . text) $ Cabal.buildOptionsAdjustmentWarnings - compiler + elabCompiler elabBuildOptionsRaw elabBuildOptions -- These get filled in later elabUnitId = error "elaborateSolverToCommon: elabUnitId" elabComponentId = error "elaborateSolverToCommon: elabComponentId" - elabInstantiatedWith = Map.empty - elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" elabIsCanonical = True - elabPkgSourceId = pkgid - elabPkgDescription = case PD.finalizePD - flags - elabEnabledSpec - (const Satisfied) - platform - (compilerInfo compiler) - [] - gdesc of - Right (desc, _) -> desc - Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" - elabGPkgDescription = gdesc - elabFlagAssignment = flags + elabPkgSourceId = srcpkgPackageId + + elabStage = solverPkgStage + elabCompiler = getStage compilers elabStage + elabPlatform = getStage platforms elabStage + elabProgramDb = getStage programDbs elabStage + + elabPkgDescription = + case PD.finalizePD + solverPkgFlags + elabEnabledSpec + (const Satisfied) + elabPlatform + (compilerInfo elabCompiler) + [] + srcpkgDescription of + Right (desc, _) -> desc + Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + + elabGPkgDescription = srcpkgDescription + + elabFlagAssignment = solverPkgFlags + elabFlagDefaults = PD.mkFlagAssignment [ (PD.flagName flag, PD.flagDefault flag) - | flag <- PD.genPackageFlags gdesc + | flag <- PD.genPackageFlags srcpkgDescription ] - elabEnabledSpec = enableStanzas stanzas - elabStanzasAvailable = stanzas + elabEnabledSpec = enableStanzas solverPkgStanzas + elabStanzasAvailable = solverPkgStanzas elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) elabStanzasRequested = optStanzaTabulate $ \o -> case o of @@ -2268,8 +2332,8 @@ elaborateInstallPlan BenchStanzas -> listToMaybe [v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription] where tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + tests = perPkgOptionMaybe srcpkgPackageId packageConfigTests + benchmarks = perPkgOptionMaybe srcpkgPackageId packageConfigBenchmarks -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' -- and 'pruneInstallPlanPass2'. We can't populate it here @@ -2287,7 +2351,7 @@ elaborateInstallPlan elabHaddockTargets = [] elabBuildHaddocks = - perPkgOptionFlag pkgid False packageConfigDocumentation + perPkgOptionFlag srcpkgPackageId False packageConfigDocumentation -- `documentation: true` should imply `-haddock` for GHC addHaddockIfDocumentationEnabled :: ConfiguredProgram -> ConfiguredProgram @@ -2296,35 +2360,47 @@ elaborateInstallPlan then cp{programOverrideArgs = "-haddock" : programOverrideArgs} else cp - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes - elabLocalToProject = isLocalToProject pkg + elabPkgSourceLocation = srcpkgSource + + elabPkgSourceHash = Map.lookup srcpkgPackageId sourcePackageHashes + + elabLocalToProject = isLocalToProject solverPkg + elabBuildStyle = - if shouldBuildInplaceOnly pkg + if shouldBuildInplaceOnly solverPkg then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = projectConfigPackageDBs sharedPackageConfig - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs + + elabPackageDbs = getStage packageDbs elabStage + elabBuildPackageDBStack = buildAndRegisterDbs elabStage + elabRegisterPackageDBStack = buildAndRegisterDbs elabStage elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + elabSetupScriptCliVersion = packageSetupScriptSpecVersion elabSetupScriptStyle elabPkgDescription libDepGraph - deps0 - elabSetupPackageDBStack = buildAndRegisterDbs + solverPkgLibDeps + + elabSetupPackageDBStack = buildAndRegisterDbs (prevStage elabStage) - elabInplaceBuildPackageDBStack = inplacePackageDbs - elabInplaceRegisterPackageDBStack = inplacePackageDbs - elabInplaceSetupPackageDBStack = inplacePackageDbs + -- Same as corePackageDbs but with the addition of the in-place packagedb. + inplacePackageDbs stage = corePackageDbs stage ++ [SpecificPackageDB (distDirectory "packagedb" prettyShow stage prettyShow (compilerId (getStage compilers stage)))] - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = corePackageDbs + -- The project packagedbs (typically the global packagedb but others can be added) followed by the store. + corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB storeDirLayout (getStage compilers stage)] - elabPkgDescriptionOverride = descOverride + elabInplaceBuildPackageDBStack = inplacePackageDbs elabStage + elabInplaceRegisterPackageDBStack = inplacePackageDbs elabStage + elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage) + + buildAndRegisterDbs stage + | shouldBuildInplaceOnly solverPkg = inplacePackageDbs stage + | otherwise = corePackageDbs stage + + elabPkgDescriptionOverride = srcpkgDescrOverride -- Raw build options derived from per-package config. -- This is the cabal-install equivalent of Cabal's 'buildOptionsFromConfigFlags', @@ -2335,48 +2411,48 @@ elaborateInstallPlan -- 'elabBuildOptions' accurately reflects what will actually be built. elabBuildOptionsRaw = LBC.BuildOptions - { withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = canBuildSharedLibs && pkgid `Set.member` pkgsUseSharedLibrary - , withStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib + { withVanillaLib = perPkgOptionFlag srcpkgPackageId True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively + , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary elabCompiler + , withStaticLib = perPkgOptionFlag srcpkgPackageId False packageConfigStaticLib + , withBytecodeLib = perPkgOptionFlag srcpkgPackageId False packageConfigBytecodeLib , withDynExe = - perPkgOptionFlag pkgid False packageConfigDynExe + perPkgOptionFlag srcpkgPackageId False packageConfigDynExe -- We can't produce a dynamic executable if the user -- wants to enable executable profiling but the -- compiler doesn't support prof+dyn. && (okProfDyn || not profExe) - , withFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe - , withGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still - , withProfExe = profExe - , withProfLib = canBuildProfilingLibs && pkgid `Set.member` pkgsUseProfilingLibrary - , withProfLibShared = canBuildProfilingSharedLibs && pkgid `Set.member` pkgsUseProfilingLibraryShared - , withBytecodeLib = perPkgOptionFlag pkgid False packageConfigBytecodeLib - , exeCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - , libCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - , withOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - , splitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - , splitSections = perPkgOptionFlag pkgid False packageConfigSplitSections - , stripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - , stripExes = perPkgOptionFlag pkgid False packageConfigStripExes - , withDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - , relocatable = perPkgOptionFlag pkgid False packageConfigRelocatable + , withFullyStaticExe = perPkgOptionFlag srcpkgPackageId False packageConfigFullyStaticExe + , withGHCiLib = perPkgOptionFlag srcpkgPackageId False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still + , withProfExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf + , withProfLib = srcpkgPackageId `Set.member` pkgsUseProfilingLibrary elabCompiler + , withProfLibShared = srcpkgPackageId `Set.member` pkgsUseProfilingLibraryShared elabCompiler + , exeCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage + , libCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage + , withOptimization = perPkgOptionFlag srcpkgPackageId NormalOptimisation packageConfigOptimization + , splitObjs = perPkgOptionFlag srcpkgPackageId False packageConfigSplitObjs + , splitSections = perPkgOptionFlag srcpkgPackageId False packageConfigSplitSections + , stripLibs = perPkgOptionFlag srcpkgPackageId False packageConfigStripLibs + , stripExes = perPkgOptionFlag srcpkgPackageId False packageConfigStripExes + , withDebugInfo = perPkgOptionFlag srcpkgPackageId NoDebugInfo packageConfigDebugInfo + , relocatable = perPkgOptionFlag srcpkgPackageId False packageConfigRelocatable , withProfLibDetail = elabProfExeDetail , withProfExeDetail = elabProfLibDetail } - okProfDyn = profilingDynamicSupportedOrUnknown compiler - profExe = perPkgOptionFlag pkgid False packageConfigProf + okProfDyn = profilingDynamicSupportedOrUnknown elabCompiler + profExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf - elabBuildOptions = Cabal.adjustBuildOptions compiler compilerprogdb elabBuildOptionsRaw + elabBuildOptions = Cabal.adjustBuildOptions elabCompiler elabProgramDb elabBuildOptionsRaw ( elabProfExeDetail , elabProfLibDetail ) = perPkgOptionLibExeFlag - pkgid + srcpkgPackageId ProfDetailDefault packageConfigProfDetail packageConfigProfLibDetail - elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo + elabDumpBuildInfo = perPkgOptionFlag srcpkgPackageId NoDumpBuildInfo packageConfigDumpBuildInfo -- Combine the configured compiler prog settings with the user-supplied -- config. For the compiler progs any user-supplied config was taken @@ -2386,73 +2462,63 @@ elaborateInstallPlan elabProgramPaths = Map.fromList [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb + | prog <- configuredPrograms elabProgramDb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths + <> perPkgOptionMapLast srcpkgPackageId packageConfigProgramPaths + elabProgramArgs = - -- Workaround for - -- - -- It turns out that, even with Cabal 2.0, there's still cases such as e.g. - -- custom Setup.hs scripts calling out to GHC even when going via - -- @runProgram ghcProgram@, as e.g. happy does in its - -- - -- (see also ) - -- - -- So for now, let's pass the rather harmless and idempotent - -- `-hide-all-packages` flag to all invocations (which has - -- the benefit that every GHC invocation starts with a - -- consistently well-defined clean slate) until we find a - -- better way. - Map.insertWith (++) "ghc" ["-hide-all-packages"] $ - Map.unionWith - (++) - ( Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog - , not (null args) - ] - ) - (perPkgOptionMapMappend pkgid packageConfigProgramArgs) - elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - elabConfiguredPrograms = configuredPrograms compilerprogdb - elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic - elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs - elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage - elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource - elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump - elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents - elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex - elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl - elabHaddockResourcesDir = perPkgOptionMaybe pkgid packageConfigHaddockResourcesDir - elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir - elabHaddockUseUnicode = perPkgOptionFlag pkgid False packageConfigHaddockUseUnicode - - elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog - elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog - elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails - elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix - elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper - elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites - elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions - - elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions + Map.unionWith + (++) + ( Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms elabProgramDb + , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog + , not (null args) + ] + ) + (perPkgOptionMapMappend srcpkgPackageId packageConfigProgramArgs) + + elabProgramPathExtra = perPkgOptionNubList srcpkgPackageId packageConfigProgramPathExtra + elabConfiguredPrograms = configuredPrograms elabProgramDb + elabConfigureScriptArgs = perPkgOptionList srcpkgPackageId packageConfigConfigureArgs + + elabExtraLibDirs = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirs + elabExtraLibDirsStatic = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirsStatic + elabExtraFrameworkDirs = perPkgOptionList srcpkgPackageId packageConfigExtraFrameworkDirs + elabExtraIncludeDirs = perPkgOptionList srcpkgPackageId packageConfigExtraIncludeDirs + + elabProgPrefix = perPkgOptionMaybe srcpkgPackageId packageConfigProgPrefix + elabProgSuffix = perPkgOptionMaybe srcpkgPackageId packageConfigProgSuffix + + elabHaddockHoogle = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockHoogle + elabHaddockHtml = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockHtml + elabHaddockHtmlLocation = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockHtmlLocation + elabHaddockForeignLibs = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockForeignLibs + elabHaddockForHackage = perPkgOptionFlag srcpkgPackageId Cabal.ForDevelopment packageConfigHaddockForHackage + elabHaddockExecutables = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockCss + elabHaddockLinkedSource = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockLinkedSource + elabHaddockQuickJump = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockQuickJump + elabHaddockHscolourCss = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockContents + elabHaddockIndex = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockIndex + elabHaddockBaseUrl = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockBaseUrl + elabHaddockResourcesDir = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockResourcesDir + elabHaddockOutputDir = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockOutputDir + elabHaddockUseUnicode = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockUseUnicode + + elabTestMachineLog = perPkgOptionMaybe srcpkgPackageId packageConfigTestMachineLog + elabTestHumanLog = perPkgOptionMaybe srcpkgPackageId packageConfigTestHumanLog + elabTestShowDetails = perPkgOptionMaybe srcpkgPackageId packageConfigTestShowDetails + elabTestKeepTix = perPkgOptionFlag srcpkgPackageId False packageConfigTestKeepTix + elabTestWrapper = perPkgOptionMaybe srcpkgPackageId packageConfigTestWrapper + elabTestFailWhenNoTestSuites = perPkgOptionFlag srcpkgPackageId False packageConfigTestFailWhenNoTestSuites + elabTestTestOptions = perPkgOptionList srcpkgPackageId packageConfigTestTestOptions + + elabBenchmarkOptions = perPkgOptionList srcpkgPackageId packageConfigBenchmarkOptions perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a @@ -2469,7 +2535,6 @@ elaborateInstallPlan where exe = fromFlagOrDefault def bothflag lib = fromFlagOrDefault def (bothflag <> libflag) - bothflag = lookupPerPkgOption pkgid fboth libflag = lookupPerPkgOption pkgid flib @@ -2492,12 +2557,6 @@ elaborateInstallPlan mempty perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - inplacePackageDbs = - corePackageDbs - ++ [distPackageDB (compilerId compiler)] - - corePackageDbs = storePackageDBStack compiler (projectConfigPackageDBs sharedPackageConfig) - -- For this local build policy, every package that lives in a local source -- dir (as opposed to a tarball), or depends on such a package, will be -- built inplace into a shared dist dir. Tarball packages that depend on @@ -2505,16 +2564,18 @@ elaborateInstallPlan shouldBuildInplaceOnly :: SolverPackage loc -> Bool shouldBuildInplaceOnly pkg = Set.member - (packageId pkg) + (solverId (ResolverPackage.Configured pkg)) pkgsToBuildInplaceOnly - pkgsToBuildInplaceOnly :: Set PackageId + -- The reverse dependencies of solver packages which match a package id in pkgLocalToProject. + pkgsToBuildInplaceOnly :: Set SolverId pkgsToBuildInplaceOnly = - Set.fromList $ - map packageId $ - SolverInstallPlan.reverseDependencyClosure - solverPlan - (map PlannedId (Set.toList pkgsLocalToProject)) + Set.fromList + [ solverId pkg + | spkg <- SolverInstallPlan.toList solverPlan + , packageId spkg `elem` pkgsLocalToProject + , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan [solverId spkg] + ] isLocalToProject :: Package pkg => pkg -> Bool isLocalToProject pkg = @@ -2528,11 +2589,11 @@ elaborateInstallPlan -- TODO: localPackages is a misnomer, it's all project packages -- here is where we decide which ones will be local! - pkgsUseSharedLibrary :: Set PackageId - pkgsUseSharedLibrary = - packagesWithLibDepsDownwardClosedProperty needsSharedLib + pkgsUseSharedLibrary :: Compiler -> Set PackageId + pkgsUseSharedLibrary compiler = + packagesWithLibDepsDownwardClosedProperty (needsSharedLib compiler) - needsSharedLib pkgid = + needsSharedLib compiler pkgid = fromMaybe compilerShouldUseSharedLibByDefault -- Case 1: --enable-shared or --disable-shared is passed explicitly, honour that. @@ -2557,63 +2618,48 @@ elaborateInstallPlan pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe pkgProf = perPkgOptionMaybe pkgid packageConfigProf - -- TODO: [code cleanup] move this into the Cabal lib. It's currently open - -- coded in Distribution.Simple.Configure, but should be made a proper - -- function of the Compiler or CompilerInfo. - compilerShouldUseSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - compilerShouldUseProfilingLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs - _ -> False - - compilerShouldUseProfilingSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs - _ -> False - - -- Returns False if we definitely can't build shared libs - canBuildWayLibs predicate = case predicate compiler of - Just can_build -> can_build - -- If we don't know for certain, just assume we can - -- which matches behaviour in previous cabal releases - Nothing -> True - - canBuildSharedLibs = canBuildWayLibs dynamicSupported - canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported - canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported - - wayWarnings pkg = do - when - (needsProfilingLib pkg && not canBuildProfilingLibs) - (warnProgress (text "Compiler does not support building p libraries, profiling is disabled")) - when - (needsSharedLib pkg && not canBuildSharedLibs) - (warnProgress (text "Compiler does not support building dyn libraries, dynamic libraries are disabled")) - when - (needsProfilingLibShared pkg && not canBuildProfilingSharedLibs) - (warnProgress (text "Compiler does not support building p_dyn libraries, profiling dynamic libraries are disabled.")) - - pkgsUseProfilingLibrary :: Set PackageId - pkgsUseProfilingLibrary = - packagesWithLibDepsDownwardClosedProperty needsProfilingLib - - needsProfilingLib pkg = + compilerShouldUseSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + canBuildWayLibs predicate = case predicate compiler of + Just can_build -> can_build + -- If we don't know for certain, just assume we can + -- which matches behaviour in previous cabal releases + Nothing -> True + + canBuildSharedLibs = canBuildWayLibs dynamicSupported + canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported + + pkgsUseProfilingLibrary :: Compiler -> Set PackageId + pkgsUseProfilingLibrary compiler = + packagesWithLibDepsDownwardClosedProperty (needsProfilingLib compiler) + + needsProfilingLib compiler pkg = fromFlagOrDefault compilerShouldUseProfilingLibByDefault (profBothFlag <> profLibFlag) where pkgid = packageId pkg profBothFlag = lookupPerPkgOption pkgid packageConfigProf profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib - pkgsUseProfilingLibraryShared :: Set PackageId - pkgsUseProfilingLibraryShared = - packagesWithLibDepsDownwardClosedProperty needsProfilingLibShared + compilerShouldUseProfilingLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs + _ -> False + + canBuildWayLibs predicate = case predicate compiler of + Just can_build -> can_build + Nothing -> True + + canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported - needsProfilingLibShared pkg = + pkgsUseProfilingLibraryShared :: Compiler -> Set PackageId + pkgsUseProfilingLibraryShared compiler = + packagesWithLibDepsDownwardClosedProperty (needsProfilingLibShared compiler) + + needsProfilingLibShared compiler pkg = fromMaybe compilerShouldUseProfilingSharedLibByDefault -- case 1: If --enable-profiling-shared is passed explicitly, honour that @@ -2637,6 +2683,17 @@ elaborateInstallPlan pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe pkgProf = perPkgOptionMaybe pkgid packageConfigProf + compilerShouldUseProfilingSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs + _ -> False + + canBuildWayLibs predicate = case predicate compiler of + Just can_build -> can_build + Nothing -> True + + canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported + -- TODO: [code cleanup] unused: the old deprecated packageConfigProfExe libDepGraph = @@ -2645,6 +2702,7 @@ elaborateInstallPlan NonSetupLibDepSolverPlanPackage (SolverInstallPlan.toList solverPlan) + packagesWithLibDepsDownwardClosedProperty :: (PackageIdentifier -> Bool) -> Set PackageIdentifier packagesWithLibDepsDownwardClosedProperty property = Set.fromList . maybe [] (map packageId) @@ -2668,14 +2726,17 @@ elaborateInstallPlan -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId -shouldBeLocal NamedPackage{} = Nothing -shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of - LocalUnpackedPackage _ -> Just (packageId pkg) - _ -> Nothing +shouldBeLocal (NamedPackage _ _) = + Nothing +shouldBeLocal (SpecificSourcePackage pkg) = + case srcpkgSource pkg of + LocalUnpackedPackage _ -> Just (packageId pkg) + _ -> Nothing -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. +-- TODO: check the role of stage here. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool -matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) +matchPlanPkg p = InstallPlan.foldPlanPackage (\(WithStage _stage ipkg) -> p (ipiComponentName ipkg)) (matchElabPkg p) -- | Get the appropriate 'ComponentName' which identifies an installed -- component. @@ -2701,15 +2762,14 @@ matchElabPkg p elab = (p . componentName) (Cabal.pkgBuildableComponents (elabPkgDescription elab)) --- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' --- and 'ComponentName' to the 'ComponentId' that should be used --- in this case. +-- | Extract from an 'ElaboratedPlanPackage' a mapping from package and component name +-- to a component id. mkCCMapping :: ElaboratedPlanPackage -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) mkCCMapping = InstallPlan.foldPlanPackage - ( \ipkg -> + ( \(WithStage _ ipkg) -> ( packageName ipkg , Map.singleton (ipiComponentName ipkg) @@ -2733,12 +2793,14 @@ mkCCMapping = , case elabPkgOrComp elab of ElabComponent comp -> case compComponentName comp of + -- This should be an error because we cannot explicitly depend on a setup Nothing -> Map.empty Just n -> Map.singleton n (mk_aid n) ElabPackage _ -> Map.fromList $ map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) + -- Shouldn't this be available in ElaboratedPackage? (Cabal.pkgBuildableComponents (elabPkgDescription elab)) ) @@ -2752,9 +2814,8 @@ mkShapeMapping dpkg = where (dcid, shape) = InstallPlan.foldPlanPackage - -- Uses Monad (->) - (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) - (liftM2 (,) elabComponentId elabModuleShape) + (\(WithStage _stage ipkg) -> (IPI.installedComponentId ipkg, shapeInstalledPackage ipkg)) + (\elab -> (elabComponentId elab, elabModuleShape elab)) dpkg indef_uid = IndefFullUnitId @@ -2796,13 +2857,13 @@ binDirectories layout config package = case elabBuildStyle package of distBuildDirectory layout (elabDistDirParams config package) "build" -type InstS = Map UnitId ElaboratedPlanPackage +type InstS = Map (WithStage UnitId) ElaboratedPlanPackage type InstM a = State InstS a getComponentId :: ElaboratedPlanPackage -> ComponentId -getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg +getComponentId (InstallPlan.PreExisting (WithStage _stage dipkg)) = IPI.installedComponentId dipkg getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab @@ -2812,6 +2873,17 @@ extractElabBuildStyle extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab extractElabBuildStyle _ = BuildAndInstall +-- When using Backpack, packages can have "holes" that need to be filled with concrete implementations. + +-- This function takes an initial install plan and creates additional plan entries for all the instantiated versions of packages + +-- The function deals with: + +-- Indefinite packages - Packages with holes/signatures that need to be filled +-- Instantiated packages - Concrete packages created by filling holes with specific implementations +-- Component IDs - Unique identifiers for components (libraries, executables etc.) +-- Unit IDs - Identifiers that track how holes are filled in instantiated packages + -- instantiateInstallPlan is responsible for filling out an InstallPlan -- with all of the extra Configured packages that would be generated by -- recursively instantiating the dependencies of packages. @@ -2856,75 +2928,87 @@ extractElabBuildStyle _ = BuildAndInstall -- * We use the state monad to cache already instantiated modules, so -- we don't instantiate the same thing multiple times. -- -instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan -instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = - InstallPlan.new - (IndependentGoals False) - (Graph.fromDistinctList (Map.elems ready_map)) +instantiateInstallPlan + :: HasCallStack + => StoreDirLayout + -> Staged InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan +instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = do + InstallPlan.new (Map.elems ready_map) where pkgs = InstallPlan.toList plan - cmap = Map.fromList [(getComponentId pkg, pkg) | pkg <- pkgs] + cmap = Map.fromList [(WithStage (stageOf pkg) (getComponentId pkg), pkg) | pkg <- pkgs] instantiateUnitId - :: ComponentId + :: Stage + -> ComponentId + -- \^ The id of the component being instantiated -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names (the "holes" or signatures in Backpack) + -- to the concrete modules (and their build styles) that should fill those + -- holes. -> InstM (DefUnitId, BuildStyle) - instantiateUnitId cid insts = state $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - -- TODO: I don't think the knot tying actually does - -- anything useful - let (r, s') = - runState - (instantiateComponent uid cid insts) - (Map.insert uid r s) - in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') - Just r -> ((def_uid, extractElabBuildStyle r), s) + instantiateUnitId stage cid insts = + gets (Map.lookup (WithStage stage uid)) >>= \case + Nothing -> do + r <- instantiateComponent uid (WithStage stage cid) insts + modify (Map.insert (WithStage stage uid) r) + return (unsafeMkDefUnitId uid, extractElabBuildStyle r) + Just r -> + return (unsafeMkDefUnitId uid, extractElabBuildStyle r) where - def_uid = mkDefUnitId cid (fmap fst insts) - uid = unDefUnitId def_uid + uid = mkDefUnitId cid (fmap fst insts) -- No need to InplaceT; the inplace-ness is properly computed for -- the ElaboratedPlanPackage, so that will implicitly pass it on instantiateComponent :: UnitId - -> ComponentId + -- \^ The unit id to assign to the instantiated component + -> WithStage ComponentId + -- \^ The id of the component being instantiated -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names (the "holes" or signatures in Backpack) + -- to the concrete modules (and their build styles) that should fill those + -- holes. -> InstM ElaboratedPlanPackage - instantiateComponent uid cid insts - | Just planpkg <- Map.lookup cid cmap = + instantiateComponent uid cidws@(WithStage stage cid) insts = + case Map.lookup cidws cmap of + Nothing -> error ("instantiateComponent: " ++ prettyShow cid) + Just planpkg -> case planpkg of - InstallPlan.Configured - ( elab0@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp - } - ) -> do - deps <- - traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) - let build_style = fold (fmap snd insts) - let getDep (Module dep_uid _) = [dep_uid] - elab1 = - fixupBuildStyle build_style $ - elab0 - { elabUnitId = uid - , elabComponentId = cid - , elabInstantiatedWith = fmap fst insts - , elabIsCanonical = Map.null (fmap fst insts) - , elabPkgOrComp = - ElabComponent - comp - { compOrderLibDependencies = - [newSimpleUnitId cid | not (Map.null insts)] - ++ ordNub - ( map - unDefUnitId - (deps ++ concatMap (getDep . fst) (Map.elems insts)) - ) - } - } - elab = + InstallPlan.Installed{} -> return planpkg + InstallPlan.PreExisting{} -> return planpkg + InstallPlan.Configured elab0 -> + case elabPkgOrComp elab0 of + ElabPackage{} -> return planpkg + ElabComponent comp -> do + deps <- traverse (fmap fst . instantiateUnit stage insts) (compLinkedLibDependencies comp) + let build_style = fold (fmap snd insts) + let getDep (Module dep_uid _) = [dep_uid] + elab1 = + fixupBuildStyle build_style $ + elab0 + { elabUnitId = uid + , elabComponentId = cid + , elabIsCanonical = Map.null (fmap fst insts) + , elabPkgOrComp = + ElabComponent + comp + { compOrderLibDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) + ++ ordNub + ( map + unDefUnitId + (deps ++ concatMap (getDep . fst) (Map.elems insts)) + ) + , compInstantiatedWith = fmap fst insts + } + } + return $ + InstallPlan.Configured elab1 { elabInstallDirs = computeInstallDirs @@ -2933,112 +3017,135 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = elaboratedShared elab1 } - return $ InstallPlan.Configured elab - _ -> return planpkg - | otherwise = error ("instantiateComponent: " ++ prettyShow cid) - substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle) - substUnitId _ (DefiniteUnitId uid) = + -- \| Instantiates an OpenUnitId into a concrete UnitId, producing a concrete UnitId and its associated BuildStyle. + -- + -- This function recursively applies a module substitution to an OpenUnitId, producing a fully instantiated + -- (definite) unit and its build style. This is a key step in Backpack-style instantiation, where "holes" in + -- a package are filled with concrete modules. + -- + -- Behavior + -- + -- If given a DefiniteUnitId, it returns the id and a default build style (BuildAndInstall). + -- + -- If given an IndefFullUnitId, it: + -- Recursively applies the substitution to each module in the instantiation map using substSubst. + -- Calls instantiateUnitId to create or retrieve the fully instantiated unit id and build style for this instantiation. + -- + instantiateUnit + :: Stage + -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names to their corresponding modules and build styles. + -> OpenUnitId + -- \^ The unit to instantiate. This can be: + -- DefiniteUnitId uid: already fully instantiated (no holes). + -- IndefFullUnitId cid insts: an indefinite unit (with holes), described by a component id and a mapping of holes to modules. + -> InstM (DefUnitId, BuildStyle) + instantiateUnit _stage _subst (DefiniteUnitId def_uid) = -- This COULD actually, secretly, be an inplace package, but in -- that case it doesn't matter as it's already been recorded -- in the package that depends on this - return (uid, BuildAndInstall) - substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' - - -- NB: NOT composition - substSubst - :: Map ModuleName (Module, BuildStyle) - -> Map ModuleName OpenModule - -> InstM (Map ModuleName (Module, BuildStyle)) - substSubst subst insts = traverse (substModule subst) insts - - substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle) - substModule subst (OpenModuleVar mod_name) + return (def_uid, BuildAndInstall) + instantiateUnit stage subst (IndefFullUnitId cid insts) = do + insts' <- traverse (instantiateModule stage subst) insts + instantiateUnitId stage cid insts' + + -- \| Instantiates an OpenModule into a concrete Module producing a concrete Module + -- and its associated BuildStyle. + instantiateModule + :: Stage + -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names to their corresponding modules and build styles. + -> OpenModule + -- \^ The module to substitute, which can be: + -- OpenModuleVar mod_name: a hole (variable) named mod_name + -- OpenModule uid mod_name: a module from a specific unit (uid). + -> InstM (Module, BuildStyle) + instantiateModule _stage subst (OpenModuleVar mod_name) | Just m <- Map.lookup mod_name subst = return m | otherwise = error "substModule: non-closing substitution" - substModule subst (OpenModule uid mod_name) = do - (uid', build_style) <- substUnitId subst uid + instantiateModule stage subst (OpenModule uid mod_name) = do + (uid', build_style) <- instantiateUnit stage subst uid return (Module uid' mod_name, build_style) - indefiniteUnitId :: ComponentId -> InstM UnitId - indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - state $ \s -> (uid, Map.insert uid r s) - - indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage - indefiniteComponent _uid cid - -- Only need Configured; this phase happens before improvement, so - -- there shouldn't be any Installed packages here. - | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap - , ElabComponent elab_comp <- elabPkgOrComp epkg = - do - -- We need to do a little more processing of the includes: some - -- of them are fully definite even without substitution. We - -- want to build those too; see #5634. - -- - -- This code mimics similar code in Distribution.Backpack.ReadyComponent; - -- however, unlike the conversion from LinkedComponent to - -- ReadyComponent, this transformation is done *without* - -- changing the type in question; and what we are simply - -- doing is enforcing tighter invariants on the data - -- structure in question. The new invariant is that there - -- is no IndefFullUnitId in compLinkedLibDependencies that actually - -- has no holes. We couldn't specify this invariant when - -- we initially created the ElaboratedPlanPackage because - -- we have no way of actually reifying the UnitId into a - -- DefiniteUnitId (that's what substUnitId does!) - new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> - if Set.null (openUnitIdFreeHoles uid) - then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid) - else return uid - -- NB: no fixupBuildStyle needed here, as if the indefinite - -- component depends on any inplace packages, it itself must - -- be indefinite! There is no substitution here, we can't - -- post facto add inplace deps - return . InstallPlan.Configured $ - epkg - { elabPkgOrComp = - ElabComponent - elab_comp - { compLinkedLibDependencies = new_deps - , -- I think this is right: any new definite unit ids we - -- minted in the phase above need to be built before us. - -- Add 'em in. This doesn't remove any old dependencies - -- on the indefinite package; they're harmless. - compOrderLibDependencies = - ordNub $ - compOrderLibDependencies elab_comp - ++ [unDefUnitId d | DefiniteUnitId d <- new_deps] - } - } - | Just planpkg <- Map.lookup cid cmap = - return planpkg - | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) + indefiniteComponent + :: ElaboratedConfiguredPackage + -> InstM ElaboratedConfiguredPackage + indefiniteComponent epkg = + case elabPkgOrComp epkg of + ElabPackage{} -> return epkg + ElabComponent elab_comp -> do + -- We need to do a little more processing of the includes: some + -- of them are fully definite even without substitution. We + -- want to build those too; see #5634. + -- + -- This code mimics similar code in Distribution.Backpack.ReadyComponent; + -- however, unlike the conversion from LinkedComponent to + -- ReadyComponent, this transformation is done *without* + -- changing the type in question; and what we are simply + -- doing is enforcing tighter invariants on the data + -- structure in question. The new invariant is that there + -- is no IndefFullUnitId in compLinkedLibDependencies that actually + -- has no holes. We couldn't specify this invariant when + -- we initially created the ElaboratedPlanPackage because + -- we have no way of actually reifying the UnitId into a + -- DefiniteUnitId (that's what substUnitId does!) + new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> + if Set.null (openUnitIdFreeHoles uid) + then fmap (DefiniteUnitId . fst) (instantiateUnit (elabStage epkg) Map.empty uid) + else return uid + -- NB: no fixupBuildStyle needed here, as if the indefinite + -- component depends on any inplace packages, it itself must + -- be indefinite! There is no substitution here, we can't + -- post facto add inplace deps + return + epkg + { elabPkgOrComp = + ElabComponent + elab_comp + { compLinkedLibDependencies = new_deps + , -- I think this is right: any new definite unit ids we + -- minted in the phase above need to be built before us. + -- Add 'em in. This doesn't remove any old dependencies + -- on the indefinite package; they're harmless. + compOrderLibDependencies = + ordNub $ + compOrderLibDependencies elab_comp + ++ [unDefUnitId d | DefiniteUnitId d <- new_deps] + } + } fixupBuildStyle BuildAndInstall elab = elab - fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab - fixupBuildStyle t@(BuildInplaceOnly{}) elab = + fixupBuildStyle _buildStyle (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab + fixupBuildStyle buildStyle@(BuildInplaceOnly{}) elab = elab - { elabBuildStyle = t + { elabBuildStyle = buildStyle , elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab , elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab , elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab } ready_map = execState work Map.empty - work = for_ pkgs $ \pkg -> case pkg of - InstallPlan.Configured elab - | not (Map.null (elabLinkedInstantiatedWith elab)) -> - indefiniteUnitId (elabComponentId elab) - >> return () + InstallPlan.Configured (elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) + | not (Map.null (compLinkedInstantiatedWith comp)) -> do + r <- indefiniteComponent elab + modify (Map.insert (WithStage (elabStage elab) (elabUnitId elab)) (InstallPlan.Configured r)) _ -> - instantiateUnitId (getComponentId pkg) Map.empty - >> return () + void $ instantiateUnitId (stageOf pkg) (getComponentId pkg) Map.empty + +-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation +-- with no holes. +-- +-- This function is defined in Cabal-syntax but only cabal-install +-- cares about it so I am putting it here. +-- +-- I am also not using the DefUnitId newtype since I believe it +-- provides little value in the code above. +mkDefUnitId :: ComponentId -> Map ModuleName Module -> UnitId +mkDefUnitId cid insts = + mkUnitId (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts)) --------------------------- -- Build targets @@ -3130,15 +3237,17 @@ availableTargets :: ElaboratedInstallPlan -> Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargets installPlan = let rs = [ (pkgid, cname, fake, target) | pkg <- InstallPlan.toList installPlan - , (pkgid, cname, fake, target) <- case pkg of + , (stage, pkgid, cname, fake, target) <- case pkg of InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg InstallPlan.Installed elab -> availableSourceTargets elab InstallPlan.Configured elab -> availableSourceTargets elab + , -- Only host stage can be explicitly requested by the user + stage == Host ] in Map.union ( Map.fromListWith @@ -3161,27 +3270,29 @@ availableTargets installPlan = -- more details on this fake stuff is about. availableInstalledTargets - :: IPI.InstalledPackageInfo - -> [ ( PackageId + :: WithStage IPI.InstalledPackageInfo + -> [ ( Stage + , PackageId , ComponentName , Bool - , AvailableTarget (UnitId, ComponentName) + , AvailableTarget (WithStage UnitId, ComponentName) ) ] -availableInstalledTargets ipkg = +availableInstalledTargets (WithStage stage ipkg) = let unitid = installedUnitId ipkg cname = CLibName LMainLibName - status = TargetBuildable (unitid, cname) TargetRequestedByDefault + status = TargetBuildable (WithStage stage unitid, cname) TargetRequestedByDefault target = AvailableTarget (packageId ipkg) cname status False fake = False - in [(packageId ipkg, cname, fake, target)] + in [(stage, IPI.sourcePackageId ipkg, cname, fake, target)] availableSourceTargets :: ElaboratedConfiguredPackage - -> [ ( PackageId + -> [ ( Stage + , PackageId , ComponentName , Bool - , AvailableTarget (UnitId, ComponentName) + , AvailableTarget (WithStage UnitId, ComponentName) ) ] availableSourceTargets elab = @@ -3215,7 +3326,7 @@ availableSourceTargets elab = -- map (thus eliminating the duplicates) and then we overlay that map with -- the normal buildable targets. (This is done above in 'availableTargets'.) -- - [ (packageId elab, cname, fake, target) + [ (elabStage elab, elabPkgSourceId elab, cname, fake, target) | component <- pkgComponents (elabPkgDescription elab) , let cname = componentName component status = componentAvailableTargetStatus component @@ -3249,7 +3360,7 @@ availableSourceTargets elab = /= Just cname componentAvailableTargetStatus - :: Component -> AvailableTargetStatus (UnitId, ComponentName) + :: Component -> AvailableTargetStatus (WithStage UnitId, ComponentName) componentAvailableTargetStatus component = case componentOptionalStanza $ CD.componentNameToComponent cname of -- it is not an optional stanza, so a library, exe or foreign lib @@ -3257,7 +3368,7 @@ availableSourceTargets elab = | not buildable -> TargetNotBuildable | otherwise -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetRequestedByDefault -- it is not an optional stanza, so a testsuite or benchmark Just stanza -> @@ -3270,11 +3381,11 @@ availableSourceTargets elab = _ | not buildable -> TargetNotBuildable (Just True, True) -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetRequestedByDefault (Nothing, True) -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetNotRequestedByDefault (Just True, False) -> error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname @@ -3383,13 +3494,13 @@ data TargetAction -- will prune differently depending on what is already installed (to -- implement "sticky" test suite enabling behavior). pruneInstallPlanToTargets - :: TargetAction - -> Map UnitId [ComponentTarget] - -> ElaboratedInstallPlan + :: HasCallStack + => TargetAction + -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) - . Graph.fromDistinctList + InstallPlan.new -- We have to do the pruning in two passes . pruneInstallPlanPass2 . pruneInstallPlanPass1 @@ -3405,16 +3516,16 @@ pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = -- -- For 'ElaboratedComponent', this the cached unit IDs always -- coincide with the real thing. -data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] +data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [WithStage UnitId] instance Package PrunedPackage where packageId (PrunedPackage elab _) = packageId elab instance HasUnitId PrunedPackage where - installedUnitId = Graph.nodeKey + installedUnitId (PrunedPackage elab _) = installedUnitId elab instance Graph.IsNode PrunedPackage where - type Key PrunedPackage = UnitId + type Key PrunedPackage = WithStage UnitId nodeKey (PrunedPackage elab _) = Graph.nodeKey elab nodeNeighbors (PrunedPackage _ deps) = deps @@ -3425,7 +3536,7 @@ fromPrunedPackage (PrunedPackage elab _) = elab -- This is required before we can prune anything. setRootTargets :: TargetAction - -> Map UnitId [ComponentTarget] + -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> [ElaboratedPlanPackage] -> [ElaboratedPlanPackage] setRootTargets targetAction perPkgTargetsMap = @@ -3438,7 +3549,7 @@ setRootTargets targetAction perPkgTargetsMap = -- dependencies. Those comes in the second pass once we know the rev deps. -- setElabBuildTargets elab = - case ( Map.lookup (installedUnitId elab) perPkgTargetsMap + case ( Map.lookup (Graph.nodeKey elab) perPkgTargetsMap , targetAction ) of (Nothing, _) -> elab @@ -3479,7 +3590,8 @@ setRootTargets targetAction perPkgTargetsMap = -- are used only by unneeded optional stanzas. These pruned deps are only -- used for the dependency closure and are not persisted in this pass. pruneInstallPlanPass1 - :: [ElaboratedPlanPackage] + :: HasCallStack + => [ElaboratedPlanPackage] -> [ElaboratedPlanPackage] pruneInstallPlanPass1 pkgs -- if there are repl targets, we need to do a bit more work @@ -3488,7 +3600,7 @@ pruneInstallPlanPass1 pkgs -- otherwise we'll do less | otherwise = pruned_packages where - pkgs' :: [InstallPlan.GenericPlanPackage IPI.InstalledPackageInfo PrunedPackage] + pkgs' :: [InstallPlan.GenericPlanPackage (WithStage IPI.InstalledPackageInfo) PrunedPackage] pkgs' = map (mapConfiguredPackage prune) pkgs prune :: ElaboratedConfiguredPackage -> PrunedPackage @@ -3498,8 +3610,8 @@ pruneInstallPlanPass1 pkgs graph = Graph.fromDistinctList pkgs' - roots :: [UnitId] - roots = mapMaybe find_root pkgs' + roots :: [Graph.Key ElaboratedPlanPackage] + roots = map Graph.nodeKey (filter is_root pkgs') -- Make a closed graph by calculating the closure from the roots pruned_packages :: [ElaboratedPlanPackage] @@ -3538,25 +3650,21 @@ pruneInstallPlanPass1 pkgs | anyMultiReplTarget = map (mapConfiguredPackage add_repl_target) (Graph.toList closed_graph) | otherwise = Graph.toList closed_graph - is_root :: PrunedPackage -> Maybe UnitId - is_root (PrunedPackage elab _) = - if not $ - and - [ null (elabConfigureTargets elab) - , null (elabBuildTargets elab) - , null (elabTestTargets elab) - , null (elabBenchTargets elab) - , null (elabReplTarget elab) - , null (elabHaddockTargets elab) - ] - then Just (installedUnitId elab) - else Nothing - - find_root (InstallPlan.Configured pkg) = is_root pkg - -- When using the extra-packages stanza we need to - -- look at installed packages as well. - find_root (InstallPlan.Installed pkg) = is_root pkg - find_root _ = Nothing + is_root :: InstallPlan.GenericPlanPackage (WithStage IPI.InstalledPackageInfo) PrunedPackage -> Bool + is_root = + foldPlanPackage + (const False) + ( \(PrunedPackage elab _) -> + not $ + and + [ null (elabConfigureTargets elab) + , null (elabBuildTargets elab) + , null (elabTestTargets elab) + , null (elabBenchTargets elab) + , null (elabReplTarget elab) + , null (elabHaddockTargets elab) + ] + ) -- Note [Sticky enabled testsuites] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3606,7 +3714,7 @@ pruneInstallPlanPass1 pkgs -- the optional stanzas and we'll make further tweaks to the optional -- stanzas in the next pass. -- - pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] + pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [Graph.Key ElaboratedConfiguredPackage] pruneOptionalDependencies elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _} = InstallPlan.depends elab -- no pruning pruneOptionalDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = @@ -3637,7 +3745,7 @@ pruneInstallPlanPass1 pkgs availablePkgs = Set.fromList - [ installedUnitId pkg + [ Graph.nodeKey pkg | InstallPlan.PreExisting pkg <- pkgs ] @@ -3673,7 +3781,7 @@ into the repl to uphold the closure property. -- all of the deps needed for the test suite, we go ahead and -- enable it always. optionalStanzasWithDepsAvailable - :: Set UnitId + :: Set (Graph.Key ElaboratedPlanPackage) -> ElaboratedConfiguredPackage -> ElaboratedPackage -> OptionalStanzaSet @@ -3681,8 +3789,7 @@ optionalStanzasWithDepsAvailable availablePkgs elab pkg = optStanzaSetFromList [ stanza | stanza <- optStanzaSetToList (elabStanzasAvailable elab) - , let deps :: [UnitId] - deps = + , let deps = CD.select (optionalStanzaDeps stanza) -- TODO: probably need to select other @@ -3775,7 +3882,7 @@ pruneInstallPlanPass2 pkgs = libTargetsRequiredForRevDeps = [ c - | installedUnitId elab `Set.member` hasReverseLibDeps + | Graph.nodeKey elab `Set.member` hasReverseLibDeps , let c = ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent , -- Don't enable building for anything which is being build in memory elabBuildStyle elab /= BuildInplaceOnly InMemory @@ -3790,11 +3897,10 @@ pruneInstallPlanPass2 pkgs = elabPkgSourceId elab ) WholeComponent - | installedUnitId elab `Set.member` hasReverseExeDeps + | Graph.nodeKey elab `Set.member` hasReverseExeDeps ] - availablePkgs :: Set UnitId - availablePkgs = Set.fromList (map installedUnitId pkgs) + availablePkgs = Set.fromList (map Graph.nodeKey pkgs) inMemoryTargets :: Set ConfiguredId inMemoryTargets = do @@ -3804,7 +3910,6 @@ pruneInstallPlanPass2 pkgs = , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] ] - hasReverseLibDeps :: Set UnitId hasReverseLibDeps = Set.fromList [ depid @@ -3812,7 +3917,6 @@ pruneInstallPlanPass2 pkgs = , depid <- elabOrderLibDependencies pkg ] - hasReverseExeDeps :: Set UnitId hasReverseExeDeps = Set.fromList [ depid @@ -3839,21 +3943,21 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = -- -- This is not always possible. pruneInstallPlanToDependencies - :: Set UnitId + :: HasCallStack + => Set (Graph.Key ElaboratedPlanPackage) -> ElaboratedInstallPlan -> Either CannotPruneDependencies - ElaboratedInstallPlan + (Graph.Graph ElaboratedPlanPackage) pruneInstallPlanToDependencies pkgTargets installPlan = assert ( all (isJust . InstallPlan.lookup installPlan) (Set.toList pkgTargets) ) - $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) - . checkBrokenDeps + $ checkBrokenDeps . Graph.fromDistinctList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . filter (\pkg -> Graph.nodeKey pkg `Set.notMember` pkgTargets) . InstallPlan.toList $ installPlan where @@ -3873,7 +3977,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = CannotPruneDependencies [ (pkg, missingDeps) | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = mapMaybe lookupDep missingDepIds + , let missingDeps = NE.map (fromMaybe (error "should not happen") . lookupDep) missingDepIds ] where -- lookup in the original unpruned graph @@ -3888,7 +3992,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = newtype CannotPruneDependencies = CannotPruneDependencies [ ( ElaboratedPlanPackage - , [ElaboratedPlanPackage] + , NonEmpty ElaboratedPlanPackage ) ] deriving (Show) @@ -3932,18 +4036,18 @@ setupHsScriptOptions -- - if we commit to a Cabal version, the logic in Nothing else Just elabSetupScriptCliVersion - , useCompiler = Just pkgConfigCompiler - , usePlatform = Just pkgConfigPlatform + , useCompiler = Just toolchainCompiler + , usePlatform = Just toolchainPlatform + , useProgramDb = toolchainProgramDb , usePackageDB = elabSetupPackageDBStack , usePackageIndex = Nothing , useDependencies = - [ (uid, srcid) - | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) <- - elabSetupDependencies elab + [ (confInstId cid, confSrcId cid) + | -- TODO: we should filter for dependencies on libraries but that should be implicit in elabSetupLibDependencies + (WithStage _ cid) <- elabSetupLibDependencies elab ] , useDependenciesExclusive = True , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps - , useProgramDb = pkgConfigCompilerProgs , useDistPref = builddir , useLoggingHandle = Nothing -- this gets set later , useWorkingDir = Just srcdir @@ -3966,6 +4070,10 @@ setupHsScriptOptions -- everything else is not a main lib or exe component ElabComponent _ -> False } + where + Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} = + -- TODO: It is disappointing that we have to change the stage here + getStage pkgConfigToolchains (prevStage elabStage) -- | To be used for the input for elaborateInstallPlan. -- @@ -4028,20 +4136,21 @@ storePackageInstallDirs' computeInstallDirs :: StoreDirLayout - -> InstallDirs.InstallDirTemplates + -> Staged InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab - | isInplaceBuildStyle (elabBuildStyle elab) = - -- use the ordinary default install dirs +computeInstallDirs storeDirLayout defaultInstallDirs sharedConfig elab = + if isInplaceBuildStyle (elabBuildStyle elab) + then -- use the ordinary default install dirs + ( InstallDirs.absoluteInstallDirs (elabPkgSourceId elab) (elabUnitId elab) - (compilerInfo (pkgConfigCompiler elaboratedShared)) + (compilerInfo toolchainCompiler) InstallDirs.NoCopyDest - (pkgConfigPlatform elaboratedShared) - defaultInstallDirs + toolchainPlatform + defaultInstallDirs' ) { -- absoluteInstallDirs sets these as 'undefined' but we have -- to use them as "Setup.hs configure" args @@ -4049,12 +4158,15 @@ computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab , InstallDirs.libexecsubdir = "" , InstallDirs.datasubdir = "" } - | otherwise = - -- use special simplified install dirs + else -- use special simplified install dirs + storePackageInstallDirs' storeDirLayout - (pkgConfigCompiler elaboratedShared) + toolchainCompiler (elabUnitId elab) + where + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) (elabStage elab) + defaultInstallDirs' = getStage defaultInstallDirs (elabStage elab) -- TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, @@ -4072,9 +4184,9 @@ setupHsConfigureFlags -> m Cabal.ConfigFlags setupHsConfigureFlags mkSymbolicPath - plan + _plan (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig@ElaboratedSharedConfig{..} + sharedConfig configCommonFlags = do -- explicitly clear, then our package db stack -- TODO: [required eventually] have to do this differently for older Cabal versions @@ -4085,6 +4197,8 @@ setupHsConfigureFlags elab Cabal.ConfigFlags{..} where + Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains sharedConfig) elabStage + Cabal.ConfigFlags { configVanillaLib , configSharedLib @@ -4112,7 +4226,9 @@ setupHsConfigureFlags configProfExe = mempty configProf = toFlag $ LBC.withProfExe elabBuildOptions - configInstantiateWith = Map.toList elabInstantiatedWith + configInstantiateWith = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent comp -> Map.toList (compInstantiatedWith comp) configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese configIPID = case elabPkgOrComp of @@ -4125,7 +4241,7 @@ setupHsConfigureFlags configProgramPaths = Map.toList elabProgramPaths configProgramArgs = Map.toList elabProgramArgs configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcFlavor = toFlag (compilerFlavor toolchainCompiler) configHcPath = mempty -- we use configProgramPaths instead configHcPkg = mempty -- we use configProgramPaths instead configDumpBuildInfo = toFlag elabDumpBuildInfo @@ -4150,29 +4266,33 @@ setupHsConfigureFlags -- dependencies which should NOT be fed in here (also you don't have -- enough info anyway) -- + -- FIXME: stage? configDependencies = [ cidToGivenComponent cid - | (cid, is_internal) <- elabLibDependencies elab + | (WithStage _stage cid, is_internal) <- elabLibDependencies elab , not is_internal ] + -- FIXME: stage? configPromisedDependencies = [ cidToPromisedComponent cid - | (cid, is_internal) <- elabLibDependencies elab + | (WithStage _stage cid, is_internal) <- elabLibDependencies elab , is_internal ] + -- FIXME: stage? configConstraints = case elabPkgOrComp of ElabPackage _ -> [ thisPackageVersionConstraint srcid - | (ConfiguredId srcid _ _uid, _) <- elabLibDependencies elab + | (WithStage _stage (ConfiguredId srcid _ _uid), _) <- elabLibDependencies elab ] ElabComponent _ -> [] configTests = case elabPkgOrComp of ElabPackage pkg -> toFlag (TestStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) ElabComponent _ -> mempty + configBenchmarks = case elabPkgOrComp of ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) ElabComponent _ -> mempty @@ -4183,7 +4303,7 @@ setupHsConfigureFlags configUserInstall = mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist configUseResponseFiles = mempty - configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler + configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported toolchainCompiler configIgnoreBuildTools = mempty cidToGivenComponent :: ConfiguredId -> GivenComponent @@ -4194,7 +4314,9 @@ setupHsConfigureFlags Just _ -> error "non-library dependency" Nothing -> LMainLibName - configCoverageFor = determineCoverageFor elab plan + -- FIXME: whathever + -- configCoverageFor = determineCoverageFor elab plan + configCoverageFor = NoFlag cidToPromisedComponent :: ConfiguredId -> PromisedComponent cidToPromisedComponent (ConfiguredId srcid mb_cn cid) = @@ -4359,13 +4481,13 @@ setupHsHaddockFlags -> Cabal.HaddockFlags setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) - (ElaboratedSharedConfig{..}) + sharedConfig _buildTimeSettings common = Cabal.HaddockFlags { haddockCommonFlags = common , haddockProgramPaths = - case lookupProgram haddockProgram pkgConfigCompilerProgs of + case lookupProgram haddockProgram toolchainProgramDb of Nothing -> mempty Just prg -> [ @@ -4394,6 +4516,8 @@ setupHsHaddockFlags , haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir , haddockUseUnicode = toFlag elabHaddockUseUnicode } + where + Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains sharedConfig) elabStage setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] -- TODO: Does the issue #3335 affects test as well @@ -4456,33 +4580,39 @@ packageHashInputs ) = PackageHashInputs { pkgHashPkgId = packageId elab - , pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp) + , pkgHashComponent , pkgHashSourceHash = srchash , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab) - , pkgHashDirectDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList $ - [ confInstId dep - | (dep, _) <- CD.select relevantDeps pkgLibDependencies - ] - ++ [ confInstId dep - | dep <- CD.select relevantDeps pkgExeDependencies - ] - ElabComponent comp -> - Set.fromList - ( map - confInstId - ( map fst (compLibDependencies comp) - ++ compExeDependencies comp - ) - ) + , pkgHashLibDeps + , pkgHashExeDeps , pkgHashOtherConfig = packageHashConfigInputs pkgshared elab } where + pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp) + pkgHashLibDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList + [confInstId c | (c, _promised) <- CD.select relevantDeps pkgLibDependencies] + ElabComponent comp -> + Set.fromList + [confInstId c | (c, _promised) <- compLibDependencies comp] + pkgHashExeDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList + [ confInstId c + | WithStage _stage c <- CD.select relevantDeps pkgExeDependencies + ] + ElabComponent comp -> + Set.fromList + [ confInstId c + | WithStage _stage c <- compExeDependencies comp + ] + -- Obviously the main deps are relevant relevantDeps CD.ComponentLib = True relevantDeps (CD.ComponentSubLib _) = True @@ -4503,11 +4633,11 @@ packageHashConfigInputs :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> PackageHashConfigInputs -packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = +packageHashConfigInputs sharedConfig pkg = PackageHashConfigInputs - { pkgHashCompilerId = compilerId pkgConfigCompiler - , pkgHashCompilerABI = compilerAbiTag pkgConfigCompiler - , pkgHashPlatform = pkgConfigPlatform + { pkgHashCompilerId = compilerId toolchainCompiler + , pkgHashCompilerABI = compilerAbiTag toolchainCompiler + , pkgHashPlatform = toolchainPlatform , pkgHashFlagAssignment = elabFlagAssignment , pkgHashConfigureScriptArgs = elabConfigureScriptArgs , pkgHashVanillaLib = withVanillaLib @@ -4555,22 +4685,10 @@ packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = , pkgHashHaddockUseUnicode = elabHaddockUseUnicode } where - ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) elabStage + ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage sharedConfig pkg LBC.BuildOptions{..} = elabBuildOptions --- | Given the 'InstalledPackageIndex' for a nix-style package store, and an --- 'ElaboratedInstallPlan', replace configured source packages by installed --- packages from the store whenever they exist. -improveInstallPlanWithInstalledPackages - :: Set UnitId - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -improveInstallPlanWithInstalledPackages installedPkgIdSet = - InstallPlan.installed canPackageBeImproved - where - canPackageBeImproved pkg = - installedUnitId pkg `Set.member` installedPkgIdSet - -- TODO: sanity checks: -- \* the installed package must have the expected deps etc -- \* the installed package must not be broken, valid dep closure @@ -4612,43 +4730,121 @@ inplaceBinRoot layout config package = distBuildDirectory layout (elabDistDirParams config package) "build" --------------------------------------------------------------------------------- --- Configure --coverage-for flags +-- FIXME: whathever +-- -------------------------------------------------------------------------------- +-- -- Configure --coverage-for flags -- The list of non-pre-existing libraries without module holes, i.e. the -- main library and sub-libraries components of all the local packages in -- the project that are dependencies of the components being built and that do -- not require instantiations or are instantiations. -determineCoverageFor - :: ElaboratedConfiguredPackage - -- ^ The package or component being configured - -> ElaboratedInstallPlan - -> Flag [UnitId] -determineCoverageFor configuredPkg plan = - Flag - $ mapMaybe - ( \case - InstallPlan.Installed elab - | shouldCoverPkg elab -> Just $ elabUnitId elab - InstallPlan.Configured elab - | shouldCoverPkg elab -> Just $ elabUnitId elab - _ -> Nothing - ) - $ Graph.toList - $ InstallPlan.toGraph plan - where - libDeps = elabLibDependencies configuredPkg - shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} = - elabLocalToProject - && not (isIndefiniteOrInstantiation elabModuleShape) - -- TODO(#9493): We can only cover libraries in the same package - -- as the testsuite - && elabPkgSourceId configuredPkg == pkgSID - -- Libraries only! We don't cover testsuite modules, so we never need - -- the paths to their mix dirs. Furthermore, we do not install testsuites... - && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab) - -- We only want coverage for libraries which are dependencies of the given one - && pkgSID `elem` map (confSrcId . fst) libDeps - - isIndefiniteOrInstantiation :: ModuleShape -> Bool - isIndefiniteOrInstantiation = not . Set.null . modShapeRequires +-- determineCoverageFor +-- :: ElaboratedConfiguredPackage +-- -- ^ The package or component being configured +-- -> ElaboratedInstallPlan +-- -> Flag [UnitId] +-- determineCoverageFor configuredPkg plan = +-- Flag +-- $ mapMaybe +-- ( \case +-- InstallPlan.Installed elab +-- | shouldCoverPkg elab -> Just $ elabUnitId elab +-- InstallPlan.Configured elab +-- | shouldCoverPkg elab -> Just $ elabUnitId elab +-- _ -> Nothing +-- ) +-- $ Graph.toList +-- $ InstallPlan.toGraph plan +-- where +-- libDeps = elabLibDependencies configuredPkg +-- shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} = +-- elabLocalToProject +-- && not (isIndefiniteOrInstantiation elabModuleShape) +-- -- TODO(#9493): We can only cover libraries in the same package +-- -- as the testsuite +-- && elabPkgSourceId configuredPkg == pkgSID +-- -- Libraries only! We don't cover testsuite modules, so we never need +-- -- the paths to their mix dirs. Furthermore, we do not install testsuites... +-- && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab) +-- -- We only want coverage for libraries which are dependencies of the given one +-- && pkgSID `elem` map (confSrcId . fst) libDeps + +-- isIndefiniteOrInstantiation :: ModuleShape -> Bool +-- isIndefiniteOrInstantiation = not . Set.null . modShapeRequires + +-- While we can talk to older Cabal versions (we need to be able to +-- do so for custom Setup scripts that require older Cabal lib +-- versions), we have problems talking to some older versions that +-- don't support certain features. +-- +-- For example, Cabal-1.16 and older do not know about build targets. +-- Even worse, 1.18 and older only supported the --constraint flag +-- with source package ids, not --dependency with installed package +-- ids. That is bad because we cannot reliably select the right +-- dependencies in the presence of multiple instances (i.e. the +-- store). See issue #3932. So we require Cabal 1.20 as a minimum. +-- +-- Moreover, lib:Cabal generally only supports the interface of +-- current and past compilers; in fact recent lib:Cabal versions +-- will warn when they encounter a too new or unknown GHC compiler +-- version (c.f. #415). To avoid running into unsupported +-- configurations we encode the compatibility matrix as lower +-- bounds on lib:Cabal here (effectively corresponding to the +-- respective major Cabal version bundled with the respective GHC +-- release). +-- +-- GHC 9.2 needs Cabal >= 3.6 +-- GHC 9.0 needs Cabal >= 3.4 +-- GHC 8.10 needs Cabal >= 3.2 +-- GHC 8.8 needs Cabal >= 3.0 +-- GHC 8.6 needs Cabal >= 2.4 +-- GHC 8.4 needs Cabal >= 2.2 +-- GHC 8.2 needs Cabal >= 2.0 +-- GHC 8.0 needs Cabal >= 1.24 +-- GHC 7.10 needs Cabal >= 1.22 +-- +-- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is +-- the absolute lower bound) +-- +-- TODO: long-term, this compatibility matrix should be +-- stored as a field inside 'Distribution.Compiler.Compiler' +-- +-- setupMinCabalVersionConstraint :: Compiler -> Version +-- setupMinCabalVersionConstraint compiler +-- | isGHC, compVer >= mkVersion [9, 10] = mkVersion [3, 12] +-- | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10] +-- | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8] +-- | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6] +-- | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4] +-- | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2] +-- | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0] +-- | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4] +-- | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2] +-- | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0] +-- | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24] +-- | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22] +-- | otherwise = mkVersion [1, 20] +-- where +-- isGHC = compFlav `elem` [GHC, GHCJS] +-- compFlav = compilerFlavor compiler +-- compVer = compilerVersion compiler + +-- As we can't predict the future, we also place a global upper +-- bound on the lib:Cabal version we know how to interact with: +-- +-- The upper bound is computed by incrementing the current major +-- version twice in order to allow for the current version, as +-- well as the next adjacent major version (one of which will not +-- be released, as only "even major" versions of Cabal are +-- released to Hackage or bundled with proper GHC releases). +-- +-- For instance, if the current version of cabal-install is an odd +-- development version, e.g. Cabal-2.1.0.0, then we impose an +-- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a +-- stable/release even version, e.g. Cabal-2.2.1.0, the upper +-- bound is `setup.Cabal < 2.4`. This gives us enough flexibility +-- when dealing with development snapshots of Cabal and cabal-install. +-- +-- setupMaxCabalVersionConstraint :: Version +-- setupMaxCabalVersionConstraint = +-- alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs new file mode 100644 index 00000000000..d2a5f186e18 --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.ProjectPlanning.Stage + ( WithStage (..) + , Stage (..) + , HasStage (..) + , Staged (..) + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types.ConfiguredId (HasConfiguredId (..)) +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (HasUnitId (..), Package (..)) +import Distribution.Solver.Types.Stage (Stage (..), Staged (..)) +import Text.PrettyPrint (colon) + +-- FIXME: blaaah +data WithStage a = WithStage Stage a + deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) + +instance Binary a => Binary (WithStage a) +instance Structured a => Structured (WithStage a) + +instance Package pkg => Package (WithStage pkg) where + packageId (WithStage _stage pkg) = packageId pkg + +instance IsNode a => IsNode (WithStage a) where + type Key (WithStage a) = WithStage (Key a) + nodeKey = fmap nodeKey + nodeNeighbors = traverse nodeNeighbors + +instance HasUnitId a => HasUnitId (WithStage a) where + installedUnitId (WithStage _stage pkg) = installedUnitId pkg + +instance HasConfiguredId a => HasConfiguredId (WithStage a) where + configuredId (WithStage _stage pkg) = configuredId pkg + +instance Pretty a => Pretty (WithStage a) where + pretty (WithStage s pkg) = pretty s <> colon <> pretty pkg + +class HasStage a where + stageOf :: a -> Stage + +instance HasStage (WithStage a) where + stageOf (WithStage s _) = s diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index adbd8a85f5e..3588d0719ff 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} @@ -14,6 +15,7 @@ module Distribution.Client.ProjectPlanning.Types -- * Elaborated install plan types , ElaboratedInstallPlan , normaliseConfiguredPackage + , ElaboratedInstalledPackageInfo , ElaboratedConfiguredPackage (..) , showElaboratedInstallPlan , elabDistDirParams @@ -22,7 +24,7 @@ module Distribution.Client.ProjectPlanning.Types , elabOrderLibDependencies , elabExeDependencies , elabOrderExeDependencies - , elabSetupDependencies + , elabSetupLibDependencies , elabPkgConfigDependencies , elabInplaceDependencyBuildCacheFiles , elabRequiresRegistration @@ -59,6 +61,15 @@ module Distribution.Client.ProjectPlanning.Types , componentOptionalStanza , componentTargetName + -- * Toolchain + , Toolchain (..) + , Toolchains + , Stage (..) + , Staged (..) + , WithStage (..) + , withStage + , HasStage (..) + -- * Setup script , SetupScriptStyle (..) ) where @@ -77,9 +88,11 @@ import Distribution.Client.InstallPlan , GenericPlanPackage (..) ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectPlanning.Stage import Distribution.Client.SolverInstallPlan ( SolverInstallPlan ) +import Distribution.Client.Toolchain import Distribution.Client.Types import Distribution.Backpack @@ -110,22 +123,21 @@ import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.OptionalStanza -import Distribution.System import Distribution.Types.ComponentRequestedSpec import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription (PackageDescription (..)) import Distribution.Types.PkgconfigVersion import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import Distribution.Version import qualified Data.ByteString.Lazy as LBS import Data.Foldable (fold) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import qualified Data.Monoid as Mon -import Distribution.Verbosity +import qualified Distribution.Compat.Graph as Graph import System.FilePath (()) -import Text.PrettyPrint (hsep, parens, text) +import Text.PrettyPrint (colon, hsep, parens, text) -- | The combination of an elaborated install plan plus a -- 'ElaboratedSharedConfig' contains all the details necessary to be able @@ -135,14 +147,27 @@ import Text.PrettyPrint (hsep, parens, text) -- connections). type ElaboratedInstallPlan = GenericInstallPlan - InstalledPackageInfo + ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage type ElaboratedPlanPackage = GenericPlanPackage - InstalledPackageInfo + ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage +instance HasStage ElaboratedPlanPackage where + stageOf (PreExisting ipkg) = stageOf ipkg + stageOf (Configured srcpkg) = stageOf srcpkg + stageOf (Installed srcpkg) = stageOf srcpkg + +instance HasStage ElaboratedPackage where + stageOf = pkgStage + +withStage :: HasStage a => a -> WithStage a +withStage a = WithStage (stageOf a) a + +type ElaboratedInstalledPackageInfo = WithStage InstalledPackageInfo + -- | User-friendly display string for an 'ElaboratedPlanPackage'. elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String elabPlanPackageName verbosity (PreExisting ipkg) @@ -156,6 +181,7 @@ elabPlanPackageName verbosity (Installed elab) = showElaboratedInstallPlan :: ElaboratedInstallPlan -> String showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode where + showNode :: ElaboratedPlanPackage -> InstallPlan.ShowPlanNode showNode pkg = InstallPlan.ShowPlanNode { InstallPlan.showPlanHerald = herald @@ -164,7 +190,7 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode where herald = ( hsep - [ text (InstallPlan.showPlanPackageTag pkg) + [ InstallPlan.renderPlanPackageTag pkg , InstallPlan.foldPlanPackage (const mempty) in_mem pkg , pretty (packageId pkg) , parens (pretty (nodeKey pkg)) @@ -179,15 +205,16 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode installed_deps = map pretty . nodeNeighbors - local_deps cfg = [(if internal then text "+" else mempty) <> pretty (confInstId uid) | (uid, internal) <- elabLibDependencies cfg] + local_deps cfg = + [ (if internal then text "+" else mempty) <> pretty s <> colon <> pretty (confInstId uid) + | (WithStage s uid, internal) <- elabLibDependencies cfg + ] -- TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things -- like a server + client with ghc + ghcjs data ElaboratedSharedConfig = ElaboratedSharedConfig - { pkgConfigPlatform :: Platform - , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo - , pkgConfigCompilerProgs :: ProgramDb + { pkgConfigToolchains :: Toolchains -- ^ The programs that the compiler configured (e.g. for GHC, the progs -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are -- used. @@ -204,8 +231,6 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage { elabUnitId :: UnitId -- ^ The 'UnitId' which uniquely identifies this item in a build plan , elabComponentId :: ComponentId - , elabInstantiatedWith :: Map ModuleName Module - , elabLinkedInstantiatedWith :: Map ModuleName OpenModule , elabIsCanonical :: Bool -- ^ This is true if this is an indefinite package, or this is a -- package with no signatures. (Notably, it's not true for instantiated @@ -250,21 +275,21 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage -- to disable. This tells us which ones we build by default, and -- helps with error messages when the user asks to build something -- they explicitly disabled. - -- - -- TODO: The 'Bool' here should be refined into an ADT with three - -- cases: NotRequested, ExplicitlyRequested and - -- ImplicitlyRequested. A stanza is explicitly requested if - -- the user asked, for this *specific* package, that the stanza - -- be enabled; it's implicitly requested if the user asked for - -- all global packages to have this stanza enabled. The - -- difference between an explicit and implicit request is - -- error reporting behavior: if a user asks for tests to be - -- enabled for a specific package that doesn't have any tests, - -- we should warn them about it, but we shouldn't complain - -- that a user enabled tests globally, and some local packages - -- just happen not to have any tests. (But perhaps we should - -- warn if ALL local packages don't have any tests.) - , elabPackageDbs :: [Maybe PackageDBCWD] + , elabStage :: Stage + , -- TODO: The 'Bool' here should be refined into an ADT with three + -- cases: NotRequested, ExplicitlyRequested and + -- ImplicitlyRequested. A stanza is explicitly requested if + -- the user asked, for this *specific* package, that the stanza + -- be enabled; it's implicitly requested if the user asked for + -- all global packages to have this stanza enabled. The + -- difference between an explicit and implicit request is + -- error reporting behavior: if a user asks for tests to be + -- enabled for a specific package that doesn't have any tests, + -- we should warn them about it, but we shouldn't complain + -- that a user enabled tests globally, and some local packages + -- just happen not to have any tests. (But perhaps we should + -- warn if ALL local packages don't have any tests.) + elabPackageDbs :: [PackageDBCWD] , elabSetupPackageDBStack :: PackageDBStackCWD , elabBuildPackageDBStack :: PackageDBStackCWD , elabRegisterPackageDBStack :: PackageDBStackCWD @@ -347,10 +372,11 @@ normaliseConfiguredPackage :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage -normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = +normaliseConfiguredPackage shared pkg = pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)} where - knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs + Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains shared) (elabStage pkg) + knownProgramDb = addKnownPrograms builtinPrograms toolchainProgramDb pkgDesc :: PackageDescription pkgDesc = elabPkgDescription pkg @@ -496,10 +522,14 @@ instance HasUnitId ElaboratedConfiguredPackage where installedUnitId = elabUnitId instance IsNode ElaboratedConfiguredPackage where - type Key ElaboratedConfiguredPackage = UnitId - nodeKey = elabUnitId + type Key ElaboratedConfiguredPackage = WithStage UnitId + nodeKey elab = WithStage (elabStage elab) (elabUnitId elab) nodeNeighbors = elabOrderDependencies +instance HasStage ElaboratedConfiguredPackage where + stageOf :: ElaboratedConfiguredPackage -> Stage + stageOf = elabStage + instance Binary ElaboratedConfiguredPackage instance Structured ElaboratedConfiguredPackage @@ -529,23 +559,35 @@ elabConfiguredName verbosity elab Just (CLibName LMainLibName) -> "" Just cname -> prettyShow cname ++ " from " ) - ++ prettyShow (packageId elab) + ++ prettyShow (Graph.nodeKey elab) | otherwise = prettyShow (elabUnitId elab) elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams elabDistDirParams shared elab = DistDirParams - { distParamUnitId = installedUnitId elab + { distParamStage = elabStage elab + , distParamUnitId = installedUnitId elab , distParamComponentId = elabComponentId elab , distParamPackageId = elabPkgSourceId elab , distParamComponentName = case elabPkgOrComp elab of ElabComponent comp -> compComponentName comp ElabPackage _ -> Nothing - , distParamCompilerId = compilerId (pkgConfigCompiler shared) - , distParamPlatform = pkgConfigPlatform shared + , distParamCompilerId = compilerId toolchainCompiler + , distParamPlatform = toolchainPlatform , distParamOptimization = LBC.withOptimization $ elabBuildOptions elab } + where + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains shared) (elabStage elab) + +-- +-- Order dependencies +-- +-- Order dependencies are identified by their 'UnitId' and only used to define the +-- dependency relationships in the build graph. In particular they do not provide +-- any other information needed to build the component or package. We can consider +-- UnitId as a opaque identifier. +-- -- | The full set of dependencies which dictate what order we -- need to build things in the install plan: "order dependencies" @@ -555,49 +597,81 @@ elabDistDirParams shared elab = -- use 'elabLibDependencies'. This method is the same as -- 'nodeNeighbors'. -- --- NB: this method DOES include setup deps. -elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] +-- Note: this method DOES include setup deps. +elabOrderDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderDependencies elab = - case elabPkgOrComp elab of - -- Important not to have duplicates: otherwise InstallPlan gets - -- confused. - ElabPackage pkg -> ordNub (fold (pkgOrderDependencies pkg)) - ElabComponent comp -> compOrderDependencies comp - --- | Like 'elabOrderDependencies', but only returns dependencies on --- libraries. -elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] + elabOrderLibDependencies elab <> elabOrderExeDependencies elab + +-- | The result includes setup dependencies +elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderLibDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> - map (newSimpleUnitId . confInstId) $ - ordNub $ - fold (map fst <$> pkgLibDependencies pkg) - ElabComponent comp -> compOrderLibDependencies comp - --- | The library dependencies (i.e., the libraries we depend on, NOT --- the dependencies of the library), NOT including setup dependencies. --- These are passed to the @Setup@ script via @--dependency@ or @--promised-dependency@. -elabLibDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] -elabLibDependencies elab = + -- Note: flatDeps include the setup dependencies too + ordNub $ concatMap snd . CD.toList $ (pkgOrderLibDependencies pkg) + ElabComponent comp -> + map (WithStage (elabStage elab)) (compOrderLibDependencies comp) + +-- | The result includes setup dependencies +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] +elabOrderExeDependencies elab = case elabPkgOrComp elab of - ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) - ElabComponent comp -> compLibDependencies comp + ElabPackage pkg -> + ordNub $ concatMap snd . CD.toList $ (pkgOrderExeDependencies pkg) + ElabComponent comp -> + map (fmap fromConfiguredId) (compExeDependencies comp) --- | Like 'elabOrderDependencies', but only returns dependencies on --- executables. (This coincides with 'elabExeDependencies'.) -elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] -elabOrderExeDependencies = - map newSimpleUnitId . elabExeDependencies +-- | See 'elabOrderDependencies'. This gives the unflattened version, +-- which can be useful in some circumstances. +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderDependencies pkg = + pkgOrderLibDependencies pkg <> pkgOrderExeDependencies pkg + +pkgOrderLibDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderLibDependencies pkg = + CD.fromList + [ (comp, map (WithStage stage . fromConfiguredId . fst) deps) + | (comp, deps) <- CD.toList (pkgLibDependencies pkg) + , let stage = + if comp == CD.ComponentSetup + then prevStage (pkgStage pkg) + else pkgStage pkg + ] + +pkgOrderExeDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderExeDependencies pkg = + fmap (map (fmap fromConfiguredId)) $ + pkgExeDependencies pkg + +fromConfiguredId :: ConfiguredId -> UnitId +fromConfiguredId = newSimpleUnitId . confInstId + +--- | Library dependencies. +--- +--- These are identified by their 'ConfiguredId' and are passed to the @Setup@ +--- script via @--dependency@ or @--promised-dependency@. +--- Note that setup dependencies (meaning the library dependencies of the setup +-- script) are not included here, they are handled separately. +elabLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] +elabLibDependencies elab = + -- Library dependencies are always in the same stage as the component/package we are + -- building. + map (\(cid, promised) -> (WithStage (elabStage elab) cid, promised)) $ + case elabPkgOrComp elab of + ElabPackage pkg -> + ordNub $ CD.nonSetupDeps (pkgLibDependencies pkg) + ElabComponent comp -> + compLibDependencies comp -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke -- the setup script. -elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] -elabExeDependencies elab = map confInstId $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp +elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] +elabExeDependencies elab = + map (fmap confInstId) $ + case elabPkgOrComp elab of + ElabPackage pkg -> ordNub $ CD.nonSetupDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp -- | This returns the paths of all the executables we depend on; we -- must add these paths to PATH before invoking the setup script. @@ -606,25 +680,33 @@ elabExeDependencies elab = map confInstId $ elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] elabExeDependencyPaths elab = case elabPkgOrComp elab of - ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabPackage pkg -> ordNub $ map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) ElabComponent comp -> map snd (compExeDependencyPaths comp) --- | The setup dependencies (the library dependencies of the setup executable; --- note that it is not legal for setup scripts to have executable --- dependencies at the moment.) -elabSetupDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] -elabSetupDependencies elab = +elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] +elabPkgConfigDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> pkgPkgConfigDependencies pkg + ElabComponent comp -> compPkgConfigDependencies comp + +-- | The setup dependencies (i.e. the library dependencies of the setup executable) +-- Note that it is not legal for setup scripts to have executable dependencies. +-- TODO: In that case we should probably not have this function at all, and +-- only use pkgSetupLibDependencies +elabSetupLibDependencies :: ElaboratedConfiguredPackage -> [WithStage ConfiguredId] +elabSetupLibDependencies elab = case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently + ElabPackage pkg -> pkgSetupLibDependencies pkg + -- Custom setups not supported for components. ElabComponent _ -> [] -elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] -elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = - pkgPkgConfigDependencies pkg -elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} = - compPkgConfigDependencies comp +pkgSetupLibDependencies :: ElaboratedPackage -> [WithStage ConfiguredId] +pkgSetupLibDependencies pkg = + map (WithStage stage . fst) $ + ordNub $ + CD.setupDeps (pkgLibDependencies pkg) + where + stage = prevStage (pkgStage pkg) -- | The cache files of all our inplace dependencies which, -- when updated, require us to rebuild. See #4202 for @@ -686,18 +768,20 @@ data ElaboratedComponent = ElaboratedComponent -- instantiation phase. It's more precise than -- 'compLibDependencies', and also stores information about internal -- dependencies. - , compExeDependencies :: [ConfiguredId] + , compInstantiatedWith :: Map ModuleName Module + , compLinkedInstantiatedWith :: Map ModuleName OpenModule + , compExeDependencies :: [WithStage ConfiguredId] -- ^ The executable dependencies of this component (including -- internal executables). , compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] -- ^ The @pkg-config@ dependencies of the component - , compExeDependencyPaths :: [(ConfiguredId, FilePath)] + , compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] -- ^ The paths all our executable dependencies will be installed -- to once they are installed. , compOrderLibDependencies :: [UnitId] -- ^ The UnitIds of the libraries (identifying elaborated packages/ -- components) that must be built before this project. This - -- is used purely for ordering purposes. It can contain both + -- is used purely for ordering purposes. It can contain both -- references to definite and indefinite packages; an indefinite -- UnitId indicates that we must typecheck that indefinite package -- before we can build this one. @@ -707,18 +791,9 @@ data ElaboratedComponent = ElaboratedComponent instance Binary ElaboratedComponent instance Structured ElaboratedComponent --- | See 'elabOrderDependencies'. -compOrderDependencies :: ElaboratedComponent -> [UnitId] -compOrderDependencies comp = - compOrderLibDependencies comp - ++ compOrderExeDependencies comp - --- | See 'elabOrderExeDependencies'. -compOrderExeDependencies :: ElaboratedComponent -> [UnitId] -compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies - data ElaboratedPackage = ElaboratedPackage - { pkgInstalledId :: InstalledPackageId + { pkgStage :: Stage + , pkgInstalledId :: InstalledPackageId , pkgLibDependencies :: ComponentDeps [(ConfiguredId, Bool)] -- ^ The exact dependencies (on other plan packages) -- The boolean value indicates whether the dependency is a promised dependency @@ -728,9 +803,9 @@ data ElaboratedPackage = ElaboratedPackage -- defined library. These are used by 'elabRequiresRegistration', -- to determine if a user-requested build is going to need -- a library registration - , pkgExeDependencies :: ComponentDeps [ConfiguredId] + , pkgExeDependencies :: ComponentDeps [WithStage ConfiguredId] -- ^ Dependencies on executable packages. - , pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)] + , pkgExeDependencyPaths :: ComponentDeps [(WithStage ConfiguredId, FilePath)] -- ^ Paths where executable dependencies live. , pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] -- ^ Dependencies on @pkg-config@ packages. @@ -789,13 +864,6 @@ whyNotPerComponent = \case CuzNoBuildableComponents -> "there are no buildable components" CuzDisablePerComponent -> "you passed --disable-per-component" --- | See 'elabOrderDependencies'. This gives the unflattened version, --- which can be useful in some circumstances. -pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] -pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (map fst <$> pkgLibDependencies pkg) - `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) - -- | This is used in the install plan to indicate how the package will be -- built. data BuildStyle diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index 14e2b4946bb..2ba8b65aca2 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -75,6 +75,7 @@ import Control.Monad import Control.Monad.Reader as Reader import Control.Monad.State as State import qualified Data.Map.Strict as Map +import System.Environment (getExecutablePath) import System.Directory import System.FilePath @@ -133,6 +134,13 @@ rerunIfChanged verbosity monitor key action = do [x] -> return x _ -> error "rerunIfChanged: impossible!" +-- | Monitor our current executable file for changes. This is useful to prevent +-- stale cache when upgrading the cabal executable itself or while developing. +monitorOurselves :: Rebuild () +monitorOurselves = do + self <- liftIO getExecutablePath + monitorFiles [monitorFile self] + -- | Like 'rerunIfChanged' meets 'mapConcurrently': For when we want multiple actions -- that need to do be re-run-if-changed asynchronously. The function returns -- when all values have finished computing. @@ -143,6 +151,8 @@ rerunConcurrentlyIfChanged -> [(FileMonitor a b, a, Rebuild b)] -> Rebuild [b] rerunConcurrentlyIfChanged verbosity mkJobControl triples = do + -- Implicitly add a monitor on our own executable file + monitorOurselves rootDir <- askRoot dacts <- forM triples $ \(monitor, key, action) -> do let monitorName = takeFileName (fileMonitorCacheFile monitor) diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index c4f2925651e..68d4b48e48d 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -71,7 +71,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedSharedConfig (..) - , configureCompiler + , configureToolchains ) import Distribution.Client.RebuildMonad ( runRebuild @@ -83,6 +83,9 @@ import Distribution.Client.TargetSelector ( TargetSelectorProblem (..) , TargetString (..) ) +import Distribution.Client.Toolchain + ( Toolchain (..) + ) import Distribution.Client.Types ( PackageLocation (..) , PackageSpecifier (..) @@ -191,6 +194,7 @@ import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy () import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Solver.Types.Stage (Stage (..), getStage) import Distribution.Utils.Path ( unsafeMakeSymbolicPath ) @@ -359,9 +363,9 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS exists <- doesFileExist script if exists then do - ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) + baseCtx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) - let projectRoot = distProjectRootDirectory $ distDirLayout ctx + let projectRoot = distProjectRootDirectory $ distDirLayout baseCtx writeFile (projectRoot "scriptlocation") =<< canonicalizePath script scriptContents <- BS.readFile script @@ -373,16 +377,20 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) - projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents + projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout baseCtx) (takeFileName script) scriptContents + + createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout baseCtx) + + toolchains <- + runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (snd (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx) - createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) - (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (snd (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + let Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} = getStage toolchains Host - (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton + (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, toolchainCompiler)) mempty projectCfgSkeleton - let ctx' = ctx & lProjectConfig %~ (<> projectCfg) + let ctx' = baseCtx & lProjectConfig %~ (<> projectCfg) - build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform + build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' toolchainCompiler toolchainPlatform exePath = build_dir "bin" scriptExeFileName script exePathRel = makeRelative (normalise projectRoot) exePath @@ -425,7 +433,8 @@ scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams scriptDistDirParams scriptPath ctx compiler platform = DistDirParams - { distParamUnitId = newSimpleUnitId cid + { distParamStage = Host + , distParamUnitId = newSimpleUnitId cid , distParamPackageId = fakePackageId , distParamComponentId = cid , distParamComponentName = Just $ CExeName cn @@ -468,14 +477,13 @@ updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do let projectRoot = distProjectRootDirectory $ distDirLayout ctx absScript <- unsafeMakeSymbolicPath . makeRelative (normalise projectRoot) <$> canonicalizePath scriptPath - let - sourcePackage = - fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condExecutables - .~ [(scriptComponentName scriptPath, CondNode executable [])] - executable = - scriptExecutable - & L.modulePath .~ absScript + let sourcePackage = + fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condExecutables + .~ [(scriptComponentName scriptPath, CondNode executable [])] + executable = + scriptExecutable + & L.modulePath .~ absScript updateContextAndWriteProjectFile' ctx sourcePackage @@ -586,10 +594,12 @@ fakeProjectSourcePackage projectRoot = sourcePackage movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath movedExePath selectedComponent distDirLayout elabShared elabConfigured = do exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured - let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared + let CompilerId flavor _ = compilerId toolchainCompiler opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe) let projectRoot = distProjectRootDirectory distDirLayout fmap (projectRoot ) . lookup "-o" $ reverse (zip opts (drop 1 opts)) + where + Toolchain{..} = getStage (pkgConfigToolchains elabShared) (elabStage elabConfigured) -- Lenses diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index c2651a33331..f1349844489 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -164,7 +164,7 @@ import Distribution.ReadE ) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler (Compiler, PackageDB, PackageDBStack) +import Distribution.Simple.Compiler (Compiler, CompilerFlavor (..), PackageDB, PackageDBStack) import Distribution.Simple.Configure ( computeEffectiveProfiling , configCompilerAuxEx @@ -915,6 +915,10 @@ data ConfigExFlags = ConfigExFlags , configAllowOlder :: Maybe AllowOlder , configWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor :: Flag CompilerFlavor + , configBuildHcPath :: Flag FilePath + , configBuildHcPkg :: Flag FilePath + , configBuildPackageDBs :: [Maybe PackageDB] } deriving (Eq, Show, Generic) @@ -1042,6 +1046,20 @@ configureExOptions _showOrParseArgs src = writeGhcEnvironmentFilesPolicyParser writeGhcEnvironmentFilesPolicyPrinter ) + , option + "W" + ["with-build-compiler", "with-build-hc"] + "give the path to the compiler for the build stage" + configBuildHcPath + (\v flags -> flags{configBuildHcPath = v}) + (reqArgFlag "PATH") + , option + "" + ["with-build-hc-pkg"] + "give the path to the package tool for the build stage" + configBuildHcPkg + (\v flags -> flags{configBuildHcPkg = v}) + (reqArgFlag "PATH") ] writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 52f0a7774db..bf2748b4ff3 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -59,6 +59,7 @@ import Distribution.PackageDescription , buildType , specVersion ) +import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Simple.Build.Macros ( generatePackageVersionMacros @@ -118,6 +119,9 @@ import Distribution.Client.Utils #endif , moreRecentFile , tryCanonicalizePath + , withEnv + , withEnvOverrides + , withExtraPathEnv ) import Distribution.Utils.Path hiding ( (), (<.>) ) @@ -178,6 +182,7 @@ import qualified Data.Map.Lazy as Map import Data.Type.Equality ( type (==) ) import Data.Type.Bool ( If ) import System.Directory (doesFileExist) +import System.Environment (getExecutablePath) import System.FilePath ((<.>), ()) import System.IO (Handle, hPutStr) import System.Process (StdStream (..)) @@ -655,7 +660,7 @@ setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs wra setupProgDb <- configCompilerProgDb verbosity - (pkgConfigCompiler elabSharedConfig) + (toolchainCompiler $ getStage (pkgConfigToolchains elabSharedConfig) Host) baseProgDb Nothing -- we use configProgramPaths instead lbi0 <- @@ -738,6 +743,37 @@ things: -- ------------------------------------------------------------ +-- | Run a Setup script by directly invoking the @Cabal@ library. +internalSetupMethod :: SetupRunner UseGeneralSetup +internalSetupMethod verbosity options bt args NotInLibrary = do + info verbosity $ + "Using internal setup method with build-type " + ++ show bt + ++ " and args:\n " + ++ unwords args + -- NB: we do not set the working directory of the process here, because + -- we will instead pass the -working-dir flag when invoking the Setup script. + -- Note that the Setup script is guaranteed to support this flag, because + -- the logic in 'getSetupMethod' guarantees we have an up-to-date Cabal version. + -- + -- In the future, it would be desirable to also stop relying on the following + -- pieces of process-global state, as this would allow us to use this internal + -- setup method in concurrent contexts. + withEnv "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $ + withExtraPathEnv (useExtraPathEnv options) $ + withEnvOverrides (useExtraEnvOverrides options) $ + buildTypeAction bt args + +buildTypeAction :: BuildType -> ([String] -> IO ()) +buildTypeAction Simple = Simple.defaultMainArgs +buildTypeAction Configure = + Simple.defaultMainWithSetupHooksArgs + Simple.autoconfSetupHooks + defaultVerbosityHandles +buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Hooks = error "buildTypeAction Hooks" +buildTypeAction Custom = error "buildTypeAction Custom" + invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () invoke verbosity path args options = do info verbosity $ unwords (path : args) @@ -770,6 +806,28 @@ invoke verbosity path args options = do -- ------------------------------------------------------------ +-- * Self-Exec SetupMethod + +-- ------------------------------------------------------------ + +selfExecSetupMethod :: SetupRunner UseGeneralSetup +selfExecSetupMethod verbosity options bt args0 NotInLibrary = do + let args = + [ "act-as-setup" + , "--build-type=" ++ prettyShow bt + , "--" + ] + ++ args0 + info verbosity $ + "Using self-exec internal setup method with build-type " + ++ show bt + ++ " and args:\n " + ++ unwords args + path <- getExecutablePath + invoke verbosity path args options + +-- ------------------------------------------------------------ + -- * External SetupMethod -- ------------------------------------------------------------ @@ -1062,8 +1120,6 @@ cachedSetupDirAndProg platform bt options' cabalLibVersion = do useCompiler options' platformString = prettyShow platform --- | Look up the executable in the cache; update the cache if the executable --- is not found. getCachedSetupExecutable :: Verbosity -> Platform @@ -1071,7 +1127,7 @@ getCachedSetupExecutable -> BuildType -> SetupScriptOptions -> Version - -> Maybe InstalledPackageId + -> Maybe ComponentId -> IO FilePath getCachedSetupExecutable verbosity @@ -1110,10 +1166,7 @@ getCachedSetupExecutable True createDirectoryIfMissingVerbose verbosity True setupCacheDir installExecutableFile verbosity src cachedSetupProgFile - -- Do not strip if we're using GHCJS, since the result may be a script when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do - -- Add the relevant PATH overrides for the package to the - -- program database. setupProgDb <- prependProgramSearchPath verbosity (useExtraPathEnv options') @@ -1180,19 +1233,21 @@ compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile = setupDir :: SetupScriptOptions -> SymbolicPath Pkg (Dir setup) setupDir opts = useDistPref opts Cabal.Path. makeRelativePathEx "setup" + setupVersionFile :: SetupScriptOptions -> SymbolicPath Pkg File -setupVersionFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> "version" ) +setupVersionFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> "version") + setupHs, hooksHs, setupHooks, setupProgFile, hooksProgFile :: SetupScriptOptions -> SymbolicPath Pkg File -setupHs opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> "hs" ) -hooksHs opts = setupDir opts Cabal.Path. makeRelativePathEx ( "hooks" <.> "hs" ) -setupHooks opts = setupDir opts Cabal.Path. makeRelativePathEx ( "SetupHooks" <.> "hs" ) -setupProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> exeExtension buildPlatform ) -hooksProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "hooks" <.> exeExtension buildPlatform ) +setupHs opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> "hs") +hooksHs opts = setupDir opts Cabal.Path. makeRelativePathEx ("hooks" <.> "hs") +setupHooks opts = setupDir opts Cabal.Path. makeRelativePathEx ("SetupHooks" <.> "hs") +setupProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> exeExtension buildPlatform) +hooksProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("hooks" <.> exeExtension buildPlatform) compileSetupX :: String - -> [SymbolicPath Pkg File] -- input files - -> SymbolicPath Pkg File -- output file + -> [SymbolicPath Pkg File] + -> SymbolicPath Pkg File -> Verbosity -> Platform -> PackageIdentifier @@ -1214,7 +1269,7 @@ compileSetupX maybeCabalLibInstalledPkgId forceCompile = do setupXHsNewer <- - or <$> for inPaths (\ inPath -> i inPath `moreRecentFile` i outPath) + or <$> for inPaths (\inPath -> i inPath `moreRecentFile` i outPath) cabalVersionNewer <- i (setupVersionFile options') `moreRecentFile` i outPath let outOfDate = setupXHsNewer || cabalVersionNewer when (outOfDate || forceCompile) $ do @@ -1231,31 +1286,20 @@ compileSetupX [] (\ipkgid -> [(ipkgid, cabalPkgid)]) maybeCabalLibInstalledPkgId - - -- With 'useDependenciesExclusive' and Custom build type, - -- we enforce the deps specified, so only the given ones can be used. - -- Otherwise we add on a dep on the Cabal library - -- (unless 'useDependencies' already contains one). selectedDeps | (useDependenciesExclusive options' && (bt /= Hooks)) - -- NB: to compile build-type: Hooks packages, we need Cabal - -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. || any (isCabalPkgId . snd) (useDependencies options') = useDependencies options' | otherwise = useDependencies options' ++ cabalDep addRenaming (ipid, _) = - -- Assert 'DefUnitId' invariant ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) , defaultRenaming ) cppMacrosFile = setupDir options' Cabal.Path. makeRelativePathEx "setup_macros.h" ghcOptions = mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use - -- --ghc-option=-v instead! - ghcOptVerbosity = Flag $ min (verbosityLevel verbosity) Normal + { ghcOptVerbosity = Flag $ min (verbosityLevel verbosity) Normal , ghcOptMode = Flag GhcModeMake , ghcOptInputFiles = toNubListR inPaths , ghcOptOutputFile = Flag outPath @@ -1270,7 +1314,6 @@ compileSetupX , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') , ghcOptCabal = Flag (useDependenciesExclusive options') , ghcOptPackages = toNubListR $ map addRenaming selectedDeps - -- With 'useVersionMacros', use a version CPP macros .h file. , ghcOptCppIncludes = toNubListR [ cppMacrosFile @@ -1281,8 +1324,6 @@ compileSetupX [ Simple.DisableExtension Simple.ImplicitPrelude | not $ bt == Custom || any (isBasePkgId . snd) selectedDeps ] - -- Pass -WNoImplicitPrelude to avoid depending on base - -- when compiling a simple Setup.hs file. , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler } let ghcCmdLine = renderGhcOptions compiler platform ghcOptions @@ -1291,8 +1332,6 @@ compileSetupX generatePackageVersionMacros (pkgVersion pkgId) (map snd selectedDeps) case useLoggingHandle options' of Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine - -- If build logging is enabled, redirect compiler output to - -- the log file. Just logHandle -> do output <- getDbProgramOutputCwd @@ -1305,7 +1344,6 @@ compileSetupX return $ i outPath where mbWorkDir = useWorkingDir options' - -- See Note [Symbolic paths] in Distribution.Utils.Path i :: SymbolicPathX allowAbs Pkg to -> FilePath i = interpretSymbolicPath mbWorkDir diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index a53108f4128..b1f04f0e57e 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -56,11 +56,7 @@ import Prelude () import Distribution.Package ( HasUnitId (..) , Package (..) - , PackageId , PackageIdentifier (..) - , PackageName - , packageName - , packageVersion ) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Types.Flag (nullFlagAssignment) @@ -68,10 +64,8 @@ import Distribution.Types.Flag (nullFlagAssignment) import Distribution.Client.Types ( UnresolvedPkgLoc ) -import Distribution.Version - ( Version - ) +import Distribution.Solver.Types.PackagePath (QPN) import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId @@ -80,9 +74,11 @@ import Distribution.Solver.Types.SolverPackage import Data.Array ((!)) import qualified Data.Foldable as Foldable import qualified Data.Graph as OldGraph +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack (HasCallStack) type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc @@ -150,7 +146,8 @@ toMap = Graph.toMap . planIndex -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. remove - :: (SolverPlanPackage -> Bool) + :: HasCallStack + => (SolverPlanPackage -> Bool) -> SolverInstallPlan -> Either [SolverPlanProblem] @@ -183,9 +180,9 @@ valid indepGoals index = data SolverPlanProblem = PackageMissingDeps SolverPlanPackage - [PackageIdentifier] + (NE.NonEmpty PackageIdentifier) | PackageCycle [SolverPlanPackage] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageInconsistency QPN [(SolverId, SolverId)] | PackageStateInvalid SolverPlanPackage SolverPlanPackage showPlanProblem :: SolverPlanProblem -> String @@ -193,7 +190,7 @@ showPlanProblem (PackageMissingDeps pkg missingDeps) = "Package " ++ prettyShow (packageId pkg) ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) + ++ intercalate ", " (map prettyShow (NE.toList missingDeps)) showPlanProblem (PackageCycle cycleGroup) = "The following packages are involved in a dependency cycle " ++ intercalate ", " (map (prettyShow . packageId) cycleGroup) @@ -206,7 +203,7 @@ showPlanProblem (PackageInconsistency name inconsistencies) = [ " package " ++ prettyShow pkg ++ " requires " - ++ prettyShow (PackageIdentifier name ver) + ++ prettyShow ver | (pkg, ver) <- inconsistencies ] showPlanProblem (PackageStateInvalid pkg pkg') = @@ -230,13 +227,14 @@ problems :: IndependentGoals -> SolverPlanIndex -> [SolverPlanProblem] -problems indepGoals index = +problems _indepGoals index = [ PackageMissingDeps pkg - ( mapMaybe - (fmap packageId . flip Graph.lookup index) - missingDeps - ) + -- ( mapMaybe + -- (fmap packageId . flip Graph.lookup index) + -- missingDeps + -- ) + (NE.map (packageId . fromMaybe (error "should not happen") . flip Graph.lookup index) missingDeps) | (pkg, missingDeps) <- Graph.broken index ] ++ [ PackageCycle cycleGroup @@ -244,7 +242,7 @@ problems indepGoals index = ] ++ [ PackageInconsistency name inconsistencies | (name, inconsistencies) <- - dependencyInconsistencies indepGoals index + dependencyInconsistencies index ] ++ [ PackageStateInvalid pkg pkg' | pkg <- Foldable.toList index @@ -263,10 +261,9 @@ problems indepGoals index = -- cycle. Such cycles may or may not be an issue; either way, we don't check -- for them here. dependencyInconsistencies - :: IndependentGoals - -> SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies indepGoals index = + :: SolverPlanIndex + -> [(QPN, [(SolverId, SolverId)])] +dependencyInconsistencies index = concatMap dependencyInconsistencies' subplans where subplans :: [SolverPlanIndex] @@ -274,7 +271,7 @@ dependencyInconsistencies indepGoals index = -- Not Graph.closure!! map (nonSetupClosure index) - (rootSets indepGoals index) + (rootSets (IndependentGoals False) index) -- NB: When we check for inconsistencies, packages from the setup -- scripts don't count as part of the closure (this way, we @@ -323,6 +320,8 @@ rootSets (IndependentGoals indepGoals) index = -- -- The library roots are the set of packages with no reverse dependencies -- (no reverse library dependencies but also no reverse setup dependencies). +-- +-- FIXME: misleading name, this includes executables too! libraryRoots :: SolverPlanIndex -> [SolverId] libraryRoots index = map (nodeKey . toPkgId) roots @@ -350,9 +349,14 @@ setupRoots = -- distinct. dependencyInconsistencies' :: SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] + -> [(QPN, [(SolverId, SolverId)])] dependencyInconsistencies' index = - [ (name, [(pid, packageVersion dep) | (dep, pids) <- uses, pid <- pids]) + [ ( name + , [ (sid, solverId dep) + | (dep, sids) <- uses + , sid <- sids + ] + ) | (name, ipid_map) <- Map.toList inverseIndex , let uses = Map.elems ipid_map , reallyIsInconsistent (map fst uses) @@ -362,11 +366,11 @@ dependencyInconsistencies' index = -- and each installed ID of that package -- the associated package instance -- and a list of reverse dependencies (as source IDs) - inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId])) + inverseIndex :: Map QPN (Map SolverId (SolverPlanPackage, [SolverId])) inverseIndex = Map.fromListWith (Map.unionWith (\(a, b) (_, b') -> (a, b ++ b'))) - [ (packageName dep, Map.fromList [(sid, (dep, [packageId pkg]))]) + [ (solverQPN dep, Map.fromList [(sid, (dep, [solverId pkg]))]) | -- For each package @pkg@ pkg <- Foldable.toList index , -- Find out which @sid@ @pkg@ depends on @@ -422,7 +426,7 @@ closed = null . Graph.broken -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to -- find out which packages are. consistent :: SolverPlanIndex -> Bool -consistent = null . dependencyInconsistencies (IndependentGoals False) +consistent = null . dependencyInconsistencies -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index 05fa5d09516..d5db171187c 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -34,7 +35,8 @@ module Distribution.Client.Targets -- * User constraints , UserQualifier (..) , UserConstraintScope (..) - , UserConstraint (..) + , UserConstraintQualifier (..) + , UserConstraint (UserConstraint, UserConstraintStaged) , userConstraintPackageName , readUserConstraint , userToPackageConstraint @@ -99,6 +101,7 @@ import qualified Data.Map as Map import Distribution.Client.Errors import qualified Distribution.Client.GZipUtils as GZipUtils import qualified Distribution.Compat.CharParsing as P +import Distribution.Solver.Types.Stage (Stage) import Distribution.Utils.Path (makeSymbolicPath) import Network.URI ( URI (..) @@ -611,18 +614,27 @@ instance Structured UserQualifier -- | Version of 'ConstraintScope' that a user may specify on the -- command line. -data UserConstraintScope +data UserConstraintScope = UserConstraintScope (Maybe Stage) UserConstraintQualifier + deriving (Eq, Show, Generic) + +instance Binary UserConstraintScope +instance Structured UserConstraintScope +instance NFData UserConstraintScope + +data UserConstraintQualifier = -- | Scope that applies to the package when it has the specified qualifier. UserQualified UserQualifier PackageName | -- | Scope that applies to the package when it has a setup qualifier. UserAnySetupQualifier PackageName + | -- | Scope that applies to the package when it has a setup qualifier. + UserAnyExeQualifier PackageName | -- | Scope that applies to the package when it has any qualifier. UserAnyQualifier PackageName deriving (Eq, Show, Generic) -instance Binary UserConstraintScope -instance NFData UserConstraintScope -instance Structured UserConstraintScope +instance Binary UserConstraintQualifier +instance Structured UserConstraintQualifier +instance NFData UserConstraintQualifier fromUserQualifier :: UserQualifier -> Qualifier fromUserQualifier UserQualToplevel = QualToplevel @@ -630,30 +642,41 @@ fromUserQualifier (UserQualSetup name) = QualSetup name fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 fromUserConstraintScope :: UserConstraintScope -> ConstraintScope -fromUserConstraintScope (UserQualified q pn) = - ScopeQualified (fromUserQualifier q) pn -fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn -fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn +fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) = + ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) = + ConstraintScope mstage (ScopeAnySetupQualifier pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnyExeQualifier pn)) = + ConstraintScope mstage (ScopeAnyExeQualifier pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) = + ConstraintScope mstage (ScopeAnyQualifier pn) -- | Version of 'PackageConstraint' that the user can specify on -- the command line. data UserConstraint - = UserConstraint UserConstraintScope PackageProperty + = UserConstraintX UserConstraintScope PackageProperty deriving (Eq, Show, Generic) instance Binary UserConstraint instance NFData UserConstraint instance Structured UserConstraint +pattern UserConstraint :: UserConstraintQualifier -> PackageProperty -> UserConstraint +pattern UserConstraint qualifier prop = UserConstraintX (UserConstraintScope Nothing qualifier) prop + +pattern UserConstraintStaged :: Stage -> UserConstraintQualifier -> PackageProperty -> UserConstraint +pattern UserConstraintStaged stage qualifier prop = UserConstraintX (UserConstraintScope (Just stage) qualifier) prop + userConstraintPackageName :: UserConstraint -> PackageName -userConstraintPackageName (UserConstraint scope _) = scopePN scope +userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier) _) = scopePN qualifier where scopePN (UserQualified _ pn) = pn scopePN (UserAnyQualifier pn) = pn scopePN (UserAnySetupQualifier pn) = pn + scopePN (UserAnyExeQualifier pn) = pn userToPackageConstraint :: UserConstraint -> PackageConstraint -userToPackageConstraint (UserConstraint scope prop) = +userToPackageConstraint (UserConstraintX scope prop) = PackageConstraint (fromUserConstraintScope scope) prop readUserConstraint :: String -> Either String UserConstraint @@ -668,7 +691,7 @@ readUserConstraint str = ++ "'source', 'test', 'bench', or flags. " instance Pretty UserConstraint where - pretty (UserConstraint scope prop) = + pretty (UserConstraintX scope prop) = pretty $ PackageConstraint (fromUserConstraintScope scope) prop instance Parsec UserConstraint where @@ -684,25 +707,60 @@ instance Parsec UserConstraint where , PackagePropertyStanzas [TestStanzas] <$ P.string "test" , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" ] - return (UserConstraint scope prop) + return (UserConstraintX scope prop) where parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope parseConstraintScope = do + mstage <- P.optional (P.try (parsec <* P.char ':')) pn <- parsec - P.choice - [ P.char '.' *> withDot pn - , P.char ':' *> withColon pn - , return (UserQualified UserQualToplevel pn) - ] + c <- + P.choice + [ P.char '.' *> withDot pn + , P.char ':' *> withColon pn + , return (UserQualified UserQualToplevel pn) + ] + return $ UserConstraintScope mstage c where - withDot :: PackageName -> m UserConstraintScope + withDot :: PackageName -> m UserConstraintQualifier withDot pn | pn == mkPackageName "any" = UserAnyQualifier <$> parsec | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec + | pn == mkPackageName "exe" = UserAnyExeQualifier <$> parsec | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn - withColon :: PackageName -> m UserConstraintScope + withColon :: PackageName -> m UserConstraintQualifier withColon pn = - UserQualified (UserQualSetup pn) - <$ P.string "setup." - <*> parsec + P.choice + [ UserQualified (UserQualSetup pn) <$> (P.string "setup." *> parsec) + , UserQualified . UserQualExe pn <$> (P.string "exe:" *> parsec) <*> (P.char '.' *> parsec) + ] + +-- >>> eitherParsec "foo > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "foo ^>= 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (MajorBoundVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "any.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "setup.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "exe.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyExeQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "foo:setup.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualSetup (PackageName "foo")) (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "build:rts source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource) +-- +-- >>> eitherParsec "build:any.rts source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserAnyQualifier (PackageName "rts"))) PackagePropertySource) +-- +-- >>> eitherParsec "setup.ghc-internal installed" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "ghc-internal"))) PackagePropertyInstalled) +-- +-- >>> eitherParsec "foo:exe:bar.baz > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualExe (PackageName "foo") (PackageName "bar")) (PackageName "baz"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs new file mode 100644 index 00000000000..f64c85a2221 --- /dev/null +++ b/cabal-install/src/Distribution/Client/Toolchain.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Client.Toolchain + ( Stage (..) + , Staged (..) + , Toolchain (..) + , mkProgramDb + , configToolchain + , configToolchains + , module Distribution.Solver.Types.Stage + , module Distribution.Solver.Types.Toolchain + ) +where + +import Distribution.Client.Setup (ConfigExFlags (..)) +import Distribution.Simple (Compiler, CompilerFlavor) +import Distribution.Simple.Compiler (interpretPackageDBStack) +import Distribution.Simple.Configure hiding (mkProgramDb) +import Distribution.Simple.Program (ProgArg) +import Distribution.Simple.Program.Db +import Distribution.Simple.Setup +import Distribution.Solver.Types.Stage +import Distribution.Solver.Types.Toolchain +import Distribution.System (Platform) +import Distribution.Utils.NubList +import Distribution.Verbosity (Verbosity, defaultVerbosityHandles, mkVerbosity) + +mkProgramDb + :: Verbosity + -> [FilePath] + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> IO ProgramDb +mkProgramDb verbosity extraSearchPath extraPaths extraArgs = do + progdb <- prependProgramSearchPath verbosity extraSearchPath [] defaultProgramDb + -- ProgramDb with directly user specified paths + return $ + userSpecifyPaths extraPaths $ + userSpecifyArgss extraArgs progdb + +-- | Configure the toolchain +configToolchain :: ConfigFlags -> IO Toolchain +configToolchain configFlags@ConfigFlags{..} = do + programDb <- + mkProgramDb + verbosity + (fromNubList configProgramPathExtra) + configProgramPaths + configProgramArgs + + (toolchainCompiler, toolchainPlatform, progdb) <- + configCompilerEx + (flagToMaybe configHcFlavor) + (flagToMaybe configHcPath) + (flagToMaybe configHcPkg) + programDb + verbosity + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the + -- future. + toolchainProgramDb <- configureAllKnownPrograms verbosity progdb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + + return Toolchain{..} + where + -- FIXME + verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (configVerbosity configFlags)) + +configToolchains :: Verbosity -> ConfigFlags -> ConfigExFlags -> IO (Staged Toolchain) +configToolchains verbosity ConfigFlags{..} ConfigExFlags{..} = do + programDb <- + mkProgramDb + verbosity + (fromNubList configProgramPathExtra) + configProgramPaths + configProgramArgs + + hostToolchain <- do + (toolchainCompiler, toolchainPlatform, toolchainProgramDb) <- + configCompilerExSafe + verbosity + (flagToMaybe configHcFlavor) + (flagToMaybe configHcPath) + (flagToMaybe configHcPkg) + programDb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + return Toolchain{..} + + buildToolchain <- do + (toolchainCompiler, toolchainPlatform, toolchainProgramDb) <- + configCompilerExSafe + verbosity + (flagToMaybe configBuildHcFlavor) + (flagToMaybe configBuildHcPath) + (flagToMaybe configBuildHcPkg) + programDb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + return Toolchain{..} + + return $ Staged (\case Build -> buildToolchain; Host -> hostToolchain) + +configCompilerExSafe + :: Verbosity + -> Maybe CompilerFlavor + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Platform, ProgramDb) +configCompilerExSafe verbosity hcFlavor hcPath hcPkg progdb = do + (compiler, platform, progdb') <- + configCompilerEx + hcFlavor + hcPath + hcPkg + progdb + verbosity + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the future. + -- I think this should be fixed in configCompilerExAux or even configCompilerEx + progdb'' <- configureAllKnownPrograms verbosity progdb' + return (compiler, platform, progdb'') diff --git a/cabal-install/src/Distribution/Client/Types.hs b/cabal-install/src/Distribution/Client/Types.hs index 841a4dbc9d2..e8647b1edb5 100644 --- a/cabal-install/src/Distribution/Client/Types.hs +++ b/cabal-install/src/Distribution/Client/Types.hs @@ -22,7 +22,7 @@ module Distribution.Client.Types , module Distribution.Client.Types.BuildResults , module Distribution.Client.Types.PackageLocation , module Distribution.Client.Types.PackageSpecifier - , module Distribution.Client.Types.ReadyPackage + , module Distribution.Client.Types.GenericReadyPackage , module Distribution.Client.Types.Repo , module Distribution.Client.Types.RepoName , module Distribution.Client.Types.SourcePackageDb @@ -33,9 +33,9 @@ import Distribution.Client.Types.AllowNewer import Distribution.Client.Types.BuildResults import Distribution.Client.Types.ConfiguredId import Distribution.Client.Types.ConfiguredPackage +import Distribution.Client.Types.GenericReadyPackage import Distribution.Client.Types.PackageLocation import Distribution.Client.Types.PackageSpecifier -import Distribution.Client.Types.ReadyPackage import Distribution.Client.Types.Repo import Distribution.Client.Types.RepoName import Distribution.Client.Types.SourcePackageDb diff --git a/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs new file mode 100644 index 00000000000..a8b673cb36b --- /dev/null +++ b/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.Types.GenericReadyPackage + ( GenericReadyPackage (..) + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) + +import Distribution.Solver.Types.PackageFixedDeps + +-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be +-- installed already, hence itself ready to be installed. +newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. + deriving + ( Eq + , Show + , Generic + , Package + , PackageFixedDeps + , HasMungedPackageId + , HasUnitId + , PackageInstalled + , Binary + ) + +-- Can't newtype derive this +instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where + type Key (GenericReadyPackage srcpkg) = Key srcpkg + nodeKey (ReadyPackage spkg) = nodeKey spkg + nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg diff --git a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs index 6c8ac9b3966..c4f3362b4e3 100644 --- a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs +++ b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs @@ -52,7 +52,7 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) = where pc = PackageConstraint - (ScopeTarget $ packageName pkg) + (scopeToplevel (packageName pkg)) (PackagePropertyVersion $ thisVersion (packageVersion pkg)) mkNamedPackage :: PackageIdentifier -> PackageSpecifier pkg diff --git a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs index e04b5af79c8..5eeb8e5e194 100644 --- a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs +++ b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs @@ -1,41 +1,10 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - module Distribution.Client.Types.ReadyPackage ( GenericReadyPackage (..) , ReadyPackage ) where -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) - import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage) +import Distribution.Client.Types.GenericReadyPackage (GenericReadyPackage (..)) import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc) -import Distribution.Solver.Types.PackageFixedDeps - --- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be --- installed already, hence itself ready to be installed. -newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. - deriving - ( Eq - , Show - , Generic - , Package - , PackageFixedDeps - , HasMungedPackageId - , HasUnitId - , PackageInstalled - , Binary - ) - --- Can't newtype derive this -instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where - type Key (GenericReadyPackage srcpkg) = Key srcpkg - nodeKey (ReadyPackage spkg) = nodeKey spkg - nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 10ab16806ab..0cef2e00b32 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -30,7 +30,7 @@ import Distribution.Client.TargetSelector hiding (DirActions (..)) import qualified Distribution.Client.TargetSelector as TS (DirActions (..)) import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (UserAnyQualifier) + , UserConstraintQualifier (UserAnyQualifier) ) import Distribution.Client.Types ( PackageLocation (..) @@ -66,7 +66,8 @@ import qualified Distribution.Simple.Flag as Flag import Distribution.Simple.Setup (CommonSetupFlags (..), HaddockFlags (..), HaddockProjectFlags (..), defaultCommonSetupFlags, defaultHaddockFlags, defaultHaddockProjectFlags, toFlag) import Distribution.System import Distribution.Text -import Distribution.Utils.Path (unsafeMakeSymbolicPath) +import Distribution.Utils.LogProgress +import Distribution.Utils.Path (FileOrDir (File), Pkg, SymbolicPath, unsafeMakeSymbolicPath) import Distribution.Version import Data.List (isInfixOf) @@ -957,11 +958,11 @@ testTargetProblemsBuild config reportSubCase = do CmdBuild.selectPackageTargets CmdBuild.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "disabled component kinds" @@ -983,9 +984,9 @@ testTargetProblemsBuild config reportSubCase = do CmdBuild.selectPackageTargets CmdBuild.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "requested component kinds" @@ -1000,8 +1001,8 @@ testTargetProblemsBuild config reportSubCase = do [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + [ (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion @@ -1088,8 +1089,8 @@ testTargetProblemsRepl config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "libs-disabled" @@ -1158,7 +1159,7 @@ testTargetProblemsRepl config reportSubCase = do (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] Nothing] - [("p-0.1-inplace", (CLibName LMainLibName))] + [(WithStage Host "p-0.1-inplace", (CLibName LMainLibName))] -- When we select the package with an explicit filter then we get those -- components even though we did not explicitly enable tests/benchmarks assertProjectDistinctTargets @@ -1166,13 +1167,13 @@ testTargetProblemsRepl config reportSubCase = do (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)] - [("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")] + [(WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite")] assertProjectDistinctTargets elaboratedPlan (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)] - [("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")] + [(WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")] testTargetProblemsListBin :: ProjectConfig -> (String -> IO ()) -> Assertion testTargetProblemsListBin config reportSubCase = do @@ -1185,7 +1186,7 @@ testTargetProblemsListBin config reportSubCase = do CmdListBin.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] - [ ("p-0.1-inplace-p1", CExeName "p1") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") ] reportSubCase "multiple-exes" @@ -1222,8 +1223,8 @@ testTargetProblemsListBin config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "exes-disabled" @@ -1270,7 +1271,7 @@ testTargetProblemsRun config reportSubCase = do CmdRun.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] - [ ("p-0.1-inplace-p1", CExeName "p1") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") ] reportSubCase "multiple-exes" @@ -1307,8 +1308,8 @@ testTargetProblemsRun config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "exes-disabled" @@ -1711,11 +1712,11 @@ testTargetProblemsHaddock config reportSubCase = do (CmdHaddock.selectPackageTargets haddockFlags) CmdHaddock.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "disabled component kinds" @@ -1727,7 +1728,7 @@ testTargetProblemsHaddock config reportSubCase = do (CmdHaddock.selectPackageTargets haddockFlags) CmdHaddock.selectComponentTarget [mkTargetPackage "p-0.1"] - [("p-0.1-inplace", (CLibName LMainLibName))] + [(WithStage Host "p-0.1-inplace", (CLibName LMainLibName))] reportSubCase "requested component kinds" -- When we selecting the package with an explicit filter then it does not @@ -1742,10 +1743,10 @@ testTargetProblemsHaddock config reportSubCase = do , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] where mkHaddockFlags flib exe test bench = @@ -1763,7 +1764,7 @@ assertProjectDistinctTargets -> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k]) -> (forall k. SubComponentTarget -> AvailableTarget k -> Either (TargetProblem err) k) -> [TargetSelector] - -> [(UnitId, ComponentName)] + -> [(WithStage UnitId, ComponentName)] -> Assertion assertProjectDistinctTargets elaboratedPlan @@ -1914,11 +1915,16 @@ testSetupScriptStyles config reportSubCase = do plan0@(_, _, sharedConfig) <- planProject testdir1 config - let compilerVer = compilerVersion (pkgConfigCompiler sharedConfig) + let isOSX (Platform _ OSX) = True + isOSX _ = False + compilerVer = compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) -- Skip the Custom tests when the shipped Cabal library is buggy - -- 9.10 ships Cabal 3.12.0.0 affected by #9940 - unless (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11]) $ - do + unless + ( (isOSX (toolchainPlatform $ getStage (pkgConfigToolchains sharedConfig) Build) && (compilerVer < mkVersion [7, 10])) + -- 9.10 ships Cabal 3.12.0.0 affected by #9940 + || (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11]) + ) + $ do (plan1, res1) <- executePlan plan0 pkg1 <- expectPackageInstalled plan1 res1 pkgidA elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps @@ -1928,7 +1934,7 @@ testSetupScriptStyles config reportSubCase = do removeFileForcibly (basedir testdir1 "marker") -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later - when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8, 2]) $ do + when (compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) < mkVersion [8, 2]) $ do reportSubCase (show SetupCustomImplicitDeps) (plan2, res2) <- executePlan =<< planProject testdir2 config pkg2 <- expectPackageInstalled plan2 res2 pkgidA @@ -2247,7 +2253,7 @@ executePlan , elaboratedPlan , elaboratedShared ) = do - let targets :: Map.Map UnitId [ComponentTarget] + let targets :: Map.Map (WithStage UnitId) [ComponentTarget] targets = Map.fromList [ (unitid, [ComponentTarget cname WholeComponent]) @@ -2258,10 +2264,12 @@ executePlan ts ] elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + either (error . show) id $ + runLogProgress' $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan pkgsBuildStatus <- rebuildTargetsDryRun @@ -2312,7 +2320,8 @@ mkProjectConfig (GhcPath ghcPath) = mempty { projectConfigShared = mempty - { projectConfigHcPath = maybeToFlag ghcPath + { projectConfigToolchain = + mempty{projectConfigHcPath = maybeToFlag ghcPath} } , projectConfigBuildOnly = mempty @@ -2348,7 +2357,7 @@ expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO InstalledPackageInfo + -> IO (WithStage InstalledPackageInfo) expectPackagePreExisting plan buildOutcomes pkgid = do planpkg <- expectPlanPackage plan pkgid case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of @@ -2773,10 +2782,7 @@ testHaddockProjectDependencies config = do (_, _, sharedConfig) <- planProject testdir config -- `haddock-project` is only supported by `haddock-2.26.1` and above which is -- shipped with `ghc-9.4` - -- And doesn't work with older ghc on Windows for some reason (file in the - -- wrong place, perhaps?). - let safeMinor = if buildOS == Windows then 10 else 4 - when (compilerVersion (pkgConfigCompiler sharedConfig) > mkVersion [9, safeMinor]) $ do + when (compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) > mkVersion [9, 4]) $ do let dir = basedir testdir cleanHaddockProject testdir withCurrentDirectory dir $ do diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 5a8945eafe0..18242903c12 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -44,6 +44,7 @@ import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalSt import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) import Data.Coerce (Coercible, coerce) +import Distribution.Solver.Types.Stage (Stage) import Network.URI (URI (..), URIAuth (..), isUnreserved) import Test.QuickCheck ( Arbitrary (..) @@ -286,6 +287,10 @@ instance Arbitrary UserConstraintScope where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary UserConstraintQualifier where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary UserQualifier where arbitrary = oneof @@ -323,6 +328,10 @@ instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where TestStanzas -> x1 BenchStanzas -> x2 +instance Arbitrary Stage where + arbitrary = genericArbitrary + shrink = genericShrink + ------------------------------------------------------------------------------- -- BuildReport ------------------------------------------------------------------------------- diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index e9fce74c5fe..b3b2c4bd794 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} @@ -7,7 +9,7 @@ module UnitTests.Distribution.Client.InstallPlan (tests) where import Distribution.Client.Compat.Prelude -import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) +import Distribution.Client.InstallPlan (GenericInstallPlan) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.JobControl import Distribution.Client.Types @@ -30,6 +32,7 @@ import qualified Data.Set as Set import System.Random import Test.QuickCheck +import Distribution.Utils.LogProgress import Test.Tasty import Test.Tasty.QuickCheck @@ -225,8 +228,13 @@ arbitraryTestInstallPlan = do -- It takes generators for installed and source packages and the chance that -- each package is installed (for those packages with no prerequisites). arbitraryInstallPlan - :: ( IsUnit ipkg - , IsUnit srcpkg + :: forall ipkg srcpkg key + . ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + , Show key + , Pretty key ) => (Vertex -> [Vertex] -> Gen ipkg) -> (Vertex -> [Vertex] -> Gen srcpkg) @@ -250,24 +258,28 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do , let isRoot = n == 0 ] - ipkgs <- - sequenceA - [ mkIPkg pkgv depvs - | pkgv <- ipkgvs - , let depvs = graph ! pkgv - ] - srcpkgs <- - sequenceA - [ mkSrcPkg pkgv depvs - | pkgv <- srcpkgvs - , let depvs = graph ! pkgv - ] - let index = - Graph.fromDistinctList - ( map InstallPlan.PreExisting ipkgs - ++ map InstallPlan.Configured srcpkgs - ) - return $ InstallPlan.new (IndependentGoals False) index + let gen_plan :: Gen (Either ErrMsg (InstallPlan.GenericInstallPlan ipkg srcpkg)) + gen_plan = do + ipkgs <- + sequenceA + [ mkIPkg pkgv depvs + | pkgv <- ipkgvs + , let depvs = graph ! pkgv + ] + srcpkgs <- + sequenceA + [ mkSrcPkg pkgv depvs + | pkgv <- srcpkgvs + , let depvs = graph ! pkgv + ] + let index = + Graph.fromDistinctList + ( map InstallPlan.PreExisting ipkgs + ++ map InstallPlan.Configured srcpkgs + ) + return $ runLogProgress' $ InstallPlan.new' index + + gen_plan `suchThatMap` either (const Nothing) Just -- | Generate a random directed acyclic graph, based on the algorithm presented -- here diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 2b98aa05432..6a68d366507 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -587,6 +587,30 @@ instance Arbitrary ProjectConfigBuildOnly where preShrink_NumJobs = fmap (fmap Positive) postShrink_NumJobs = fmap (fmap getPositive) +instance Arbitrary ProjectConfigToolchain where + arbitrary = do + projectConfigHcFlavor <- arbitrary + projectConfigHcPath <- arbitraryFlag arbitraryShortToken + projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigPackageDBs <- shortListOf 2 arbitrary + projectConfigBuildHcFlavor <- arbitrary + projectConfigBuildHcPath <- arbitraryFlag arbitraryShortToken + projectConfigBuildHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigBuildPackageDBs <- shortListOf 2 arbitrary + return ProjectConfigToolchain{..} + + shrink ProjectConfigToolchain{..} = + runShrinker $ + pure ProjectConfigToolchain + <*> shrinker projectConfigHcFlavor + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinker projectConfigPackageDBs + <*> shrinker projectConfigBuildHcFlavor + <*> shrinkerAla (fmap NonEmpty) projectConfigBuildHcPath + <*> shrinkerAla (fmap NonEmpty) projectConfigBuildHcPkg + <*> shrinker projectConfigBuildPackageDBs + instance Arbitrary ProjectConfigShared where arbitrary = do projectConfigDistDir <- arbitraryFlag arbitraryShortToken @@ -595,12 +619,9 @@ instance Arbitrary ProjectConfigShared where projectConfigProjectFile <- arbitraryFlag arbitraryShortToken projectConfigProjectFileParser <- arbitraryFlag arbitrary projectConfigIgnoreProject <- arbitrary - projectConfigHcFlavor <- arbitrary - projectConfigHcPath <- arbitraryFlag arbitraryShortToken - projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigToolchain <- arbitrary projectConfigHaddockIndex <- arbitrary projectConfigInstallDirs <- fixInstallDirs <$> arbitrary - projectConfigPackageDBs <- shortListOf 2 arbitrary projectConfigRemoteRepos <- arbitrary projectConfigLocalNoIndexRepos <- arbitrary projectConfigActiveRepos <- arbitrary @@ -642,12 +663,9 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigProjectFile <*> shrinker projectConfigProjectFileParser <*> shrinker projectConfigIgnoreProject - <*> shrinker projectConfigHcFlavor - <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath - <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinker projectConfigToolchain <*> shrinker projectConfigHaddockIndex <*> shrinker projectConfigInstallDirs - <*> shrinker projectConfigPackageDBs <*> shrinker projectConfigRemoteRepos <*> shrinker projectConfigLocalNoIndexRepos <*> shrinker projectConfigActiveRepos diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs index ac6d96cc159..cbb16c49477 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs @@ -4,7 +4,7 @@ module UnitTests.Distribution.Client.Targets import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) , UserQualifier (..) , readUserConstraint ) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index ef4f9fb7c9f..b7db877562e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -9,6 +9,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ProjectConfigPath import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Stage import Distribution.Client.BuildReports.Types import Distribution.Client.CmdInstall.ClientInstallFlags @@ -63,6 +64,7 @@ instance ToExpr ProjectConfig instance ToExpr ProjectConfigBuildOnly instance ToExpr ProjectConfigProvenance instance ToExpr ProjectConfigShared +instance ToExpr ProjectConfigToolchain instance ToExpr ProjectFileParser instance ToExpr RelaxDepMod instance ToExpr RelaxDeps @@ -74,11 +76,13 @@ instance ToExpr ReorderGoals instance ToExpr RepoIndexState instance ToExpr RepoName instance ToExpr ReportLevel +instance ToExpr Stage instance ToExpr StrongFlags instance ToExpr Timestamp instance ToExpr TotalIndexState instance ToExpr UserConstraint instance ToExpr UserConstraintScope +instance ToExpr UserConstraintQualifier instance ToExpr UserQualifier instance ToExpr WriteGhcEnvironmentFilesPolicy diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index bf99906f6bd..aa7540b3e56 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -100,6 +100,7 @@ import qualified Distribution.Solver.Types.PkgConfigDb as PC import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Solver.Types.Variable import Distribution.Types.UnitId (UnitId) @@ -832,7 +833,11 @@ exResolve prefs verbosity enableAllTests = - resolveDependencies C.buildPlatform compiler pkgConfigDb params + resolveDependencies + (Stage.always (compiler, C.buildPlatform)) + (Stage.always pkgConfigDb) + (Stage.always instIdx) + params where defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag compiler = @@ -866,17 +871,16 @@ exResolve setCountConflicts countConflicts $ setFineGrainedConflicts fineGrainedConflicts $ setMinimizeConflictSet minimizeConflictSet $ - setIndependentGoals indepGoals $ - (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $ - setReorderGoals reorder $ - setMaxBackjumps mbj $ - setAllowBootLibInstalls allowBootLibInstalls $ - setOnlyConstrained onlyConstrained $ - setEnableBackjumping enableBj $ - setSolveExecutables solveExes $ - setGoalOrder goalOrder $ - setSolverVerbosity (C.verbosityLevel verbosity) $ - standardInstallPolicy instIdx avaiIdx targets' + (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $ + setReorderGoals reorder $ + setMaxBackjumps mbj $ + setAllowBootLibInstalls allowBootLibInstalls $ + setOnlyConstrained onlyConstrained $ + setEnableBackjumping enableBj $ + setSolveExecutables solveExes $ + setGoalOrder goalOrder $ + setSolverVerbosity (C.verbosityLevel verbosity) $ + standardInstallPolicy avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown toConstraint (ExVersionConstraint scope v) = diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs index 757aff758db..f0112ab71aa 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -51,6 +51,7 @@ import Distribution.Client.Dependency (foldProgress) import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList) import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Stage import Distribution.Solver.Types.Variable import Distribution.Types.UnitId (UnitId, mkUnitId) import UnitTests.Distribution.Solver.Modular.DSL @@ -323,20 +324,10 @@ runTest SolverTest{..} = withFrozenCallStack $ askOption $ \(OptionShowSolverLog toQPN q pn = P.Q pp (C.mkPackageName pn) where pp = case q of - QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel - QualIndep p -> - P.PackagePath - (P.Independent $ C.mkPackageName p) - P.QualToplevel + QualNone -> P.PackagePath Host P.QualToplevel QualSetup s -> - P.PackagePath - P.DefaultNamespace - (P.QualSetup (C.mkPackageName s)) - QualIndepSetup p s -> - P.PackagePath - (P.Independent $ C.mkPackageName p) - (P.QualSetup (C.mkPackageName s)) + P.PackagePath Host (P.QualSetup (C.mkPackageName s)) + QualIndepSetup _ s -> + P.PackagePath Host (P.QualSetup (C.mkPackageName s)) QualExe p1 p2 -> - P.PackagePath - P.DefaultNamespace - (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) + P.PackagePath Host (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index ab056c820c9..1ed0710709a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -43,6 +43,7 @@ import Distribution.Solver.Types.Variable import Distribution.Verbosity import Distribution.Version +import Distribution.Solver.Types.Stage (Stage) import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils ( ArbitraryOrd (..) @@ -499,8 +500,8 @@ arbitraryConstraint pkgs = do (PN pn, v) <- elements pkgs let anyQualifier = ScopeAnyQualifier (mkPackageName pn) oneof - [ ExVersionConstraint anyQualifier <$> arbitraryVersionRange v - , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas] + [ ExVersionConstraint (ConstraintScope Nothing anyQualifier) <$> arbitraryVersionRange v + , ExStanzaConstraint (ConstraintScope Nothing anyQualifier) <$> sublistOf [TestStanzas, BenchStanzas] ] arbitraryPreference :: [(PN, PV)] -> Gen ExPreference @@ -621,11 +622,16 @@ instance Arbitrary OptionalStanza where shrink BenchStanzas = [TestStanzas] shrink TestStanzas = [] +instance Arbitrary Stage where + arbitrary = elements [minBound .. maxBound] + + shrink stage = + [stage' | stage' <- [minBound .. maxBound], stage' /= stage] + instance ArbitraryOrd pn => ArbitraryOrd (Variable pn) instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a) instance ArbitraryOrd P.PackagePath instance ArbitraryOrd P.Qualifier -instance ArbitraryOrd P.Namespace instance ArbitraryOrd OptionalStanza instance ArbitraryOrd FlagName instance ArbitraryOrd PackageName @@ -633,12 +639,9 @@ instance ArbitraryOrd ShortText where arbitraryCompare = do strc <- arbitraryCompare pure $ \l r -> strc (fromShortText l) (fromShortText r) +instance ArbitraryOrd Stage deriving instance Generic (Variable pn) -deriving instance Generic (P.Qualified a) -deriving instance Generic P.PackagePath -deriving instance Generic P.Namespace -deriving instance Generic P.Qualifier randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index 9ea020bd512..5cccc11ee1a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -77,13 +77,13 @@ tests = any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)" in runTest $ setVerbose $ - constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ + constraints [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "true-dep")) V.noVersion] $ mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ -- TODO: We should check the summarized log instead of the full log -- for the manual flags error message, but it currently only -- appears in the full log. SolverResult checkFullLog (Left $ const True) - , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False] + , let cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "pkg")) "flag" False] in runTest $ constraints cs $ mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $ @@ -92,7 +92,7 @@ tests = , testGroup "Qualified manual flag constraints" [ let name = "Top-level flag constraint does not constrain setup dep's flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False] in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ @@ -105,8 +105,8 @@ tests = ] , let name = "Solver can toggle setup dep's flag to match top-level constraint" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False - , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False + , ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "b-2-true-dep")) V.noVersion ] in runTest $ constraints cs $ @@ -120,8 +120,8 @@ tests = ] , let name = "User can constrain flags separately with qualified constraints" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" True + , ExFlagConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "A") "B")) "flag" False ] in runTest $ constraints cs $ @@ -135,15 +135,15 @@ tests = ] , -- Regression test for #4299 let name = "Solver can link deps when only one has constrained manual flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False] in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ solverSuccess [("A", 1), ("B", 1), ("b-1-false-dep", 1)] , let name = "Solver cannot link deps that have conflicting manual flag constraints" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" True + , ExFlagConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "A") "B")) "flag" False ] failureReason = "(constraint from unknown source requires opposite flag selection)" checkFullLog lns = @@ -295,20 +295,20 @@ tests = [ runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $ solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)] - , let cs = [ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4] + , let cs = [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "D")) $ mkVersionRange 1 4] in runTest $ constraints cs $ mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] , let cs = - [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4 - , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7 + [ ExVersionConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "D")) $ mkVersionRange 1 4 + , ExVersionConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "B") "D")) $ mkVersionRange 4 7 ] in runTest $ constraints cs $ mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)] - , let cs = [ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4] + , let cs = [ExVersionConstraint (ConstraintScope Nothing (ScopeAnySetupQualifier "D")) $ mkVersionRange 1 4] in runTest $ constraints cs $ mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $ @@ -450,7 +450,7 @@ tests = `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ] in runTest $ - constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $ + constraints [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) "make-lib-private" True] $ mkTest db "reject package with sub-library made private by flag constraint" ["A"] $ solverFailure $ isInfixOf "rejecting: B-1 (library 'sub-lib' is private, but it is required by A)" @@ -563,7 +563,7 @@ tests = ] , -- tests for partial fix for issue #5325 testGroup "Components that are unbuildable in the current environment" $ - let flagConstraint = ExFlagConstraint . ScopeAnyQualifier + let flagConstraint = ExFlagConstraint . ConstraintScope Nothing . ScopeAnyQualifier in [ let db = [Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]] in runTest $ constraints [flagConstraint "A" "build-lib" False] $ @@ -2081,7 +2081,7 @@ dbIndepGoals78 = -- If you specify `any.A == 2`, then that should apply inside an independent goal. testIndepGoals8 :: String -> SolverTest testIndepGoals8 name = - constraints [ExVersionConstraint (ScopeAnyQualifier "A") (V.thisVersion (V.mkVersion [2]))] $ + constraints [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "A")) (V.thisVersion (V.mkVersion [2]))] $ independentGoals $ mkTest dbIndepGoals78 name ["A"] $ solverSuccess [("A", 2)] @@ -2502,7 +2502,7 @@ requireConsistentBuildToolVersions name = -- instead of missing. chooseUnbuildableExeAfterBuildToolsPackage :: String -> SolverTest chooseUnbuildableExeAfterBuildToolsPackage name = - constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $ + constraints [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) "build-bt2" False] $ goalOrder goals $ mkTest db name ["A"] $ solverFailure $ @@ -2618,7 +2618,7 @@ setupStanzaTest1 = constraints [ExStanzaConstraint (scopeToplevel "B") [TestStan -- With the "any" qualifier syntax setupStanzaTest2 :: SolverTest setupStanzaTest2 = - constraints [ExStanzaConstraint (ScopeAnyQualifier "B") [TestStanzas]] $ + constraints [ExStanzaConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) [TestStanzas]] $ mkTest dbSetupStanza "setupStanzaTest2" diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project new file mode 100644 index 00000000000..d2c5a6cfbb8 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project @@ -0,0 +1 @@ +packages: hello diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs new file mode 100644 index 00000000000..41aa448a408 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude + +-- Test that --with-build-compiler is accepted and the build succeeds. +-- Requires --with-build-compiler to be passed to the test runner; skipped otherwise. +main = cabalTest . recordMode DoNotRecord $ do + withBuildCompiler $ \bc -> + cabal "v2-build" ["--with-build-compiler=" ++ bc, "all"] diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs new file mode 100644 index 00000000000..98f25e48d5a --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, World!" diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal new file mode 100644 index 00000000000..c343c4c8790 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal @@ -0,0 +1,10 @@ +cabal-version: >= 1.10 +name: hello +version: 0.1.0.0 +license: BSD3 +build-type: Simple + +executable hello-world + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project new file mode 100644 index 00000000000..7c64e37f6d3 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project @@ -0,0 +1 @@ +packages: client diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs new file mode 100644 index 00000000000..1a6ec419128 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs @@ -0,0 +1,23 @@ +import Test.Cabal.Prelude + +main :: IO () +main = cabalTest . recordMode DoNotRecord $ do + withBuildCompiler $ \bc -> do + cabal "v2-build" ["--with-build-compiler=" ++ bc, "all"] + -- Ask the build compiler for its numeric version (e.g. "9.10.2") + -- and convert it to the __GLASGOW_HASKELL__ integer format (e.g. 910). + vr <- runM bc ["--numeric-version"] Nothing + let bcInt = ghcNumericVersionToGHC (head (lines (resultOutput vr))) + withPlan $ do + r <- runPlanExe' "client" "check-compiler" [] + assertOutputContains ("setup-ghc: " ++ show bcInt) r + +-- Convert a GHC numeric version string "M.N.P" to the __GLASGOW_HASKELL__ +-- integer M*100 + N (e.g. "9.10.2" -> 910). +ghcNumericVersionToGHC :: String -> Int +ghcNumericVersionToGHC s = major * 100 + minor + where + (majorStr, rest) = span (/= '.') s + (minorStr, _) = span (/= '.') (drop 1 rest) + major = read majorStr + minor = read minorStr diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs new file mode 100644 index 00000000000..c529d03ecb2 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module Main where + +main :: IO () +main = do + -- SETUP_GHC_VERSION is injected by Setup.hs using the build compiler's + -- __GLASGOW_HASKELL__ macro, so it reflects the build-stage GHC. + putStrLn $ "setup-ghc: " ++ show (SETUP_GHC_VERSION :: Int) + -- __GLASGOW_HASKELL__ here reflects the host compiler (the one compiling Main.hs). + putStrLn $ "self-ghc: " ++ show (__GLASGOW_HASKELL__ :: Int) diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs new file mode 100644 index 00000000000..f4a03e2b3ca --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup +import Distribution.PackageDescription +import Distribution.Types.BuildInfo + +main :: IO () +main = defaultMainWithHooks simpleUserHooks{confHook = myConfHook} + +myConfHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +myConfHook pkg flags = do + lbi <- confHook simpleUserHooks pkg flags + -- __GLASGOW_HASKELL__ is the version of GHC compiling this Setup.hs, + -- i.e. the build compiler in a cross-compile scenario. + let define = "-DSETUP_GHC_VERSION=" ++ show (__GLASGOW_HASKELL__ :: Int) + addDefine bi = bi{cppOptions = define : cppOptions bi} + pd = localPkgDescr lbi + exes' = map (\e -> e{buildInfo = addDefine (buildInfo e)}) (executables pd) + return lbi{localPkgDescr = pd{executables = exes'}} diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal new file mode 100644 index 00000000000..153a5b08af1 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal @@ -0,0 +1,14 @@ +cabal-version: 2.0 +name: client +version: 0.1.0.0 +build-type: Custom + +custom-setup + setup-depends: + base + , Cabal >= 2.0 + +executable check-compiler + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index 4fa81e2e069..47920a1a9e4 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -7,6 +7,7 @@ module Test.Cabal.Monad , setupTest , cabalTest , cabalTest' + , withBuildCompiler -- * The monad , TestM @@ -127,6 +128,7 @@ import Test.Cabal.Run data CommonArgs = CommonArgs { argCabalInstallPath :: Maybe FilePath , argGhcPath :: Maybe FilePath + , argBuildCompilerPath :: Maybe FilePath , argHackageRepoToolPath :: Maybe FilePath , argHaddockPath :: Maybe FilePath , argKeepTmpFiles :: Bool @@ -154,6 +156,14 @@ commonArgParser = <> metavar "PATH" ) ) + <*> optional + ( option + str + ( help "Path to the build compiler (cross-compile build stage). If omitted, tests requiring a separate build compiler are skipped." + <> long "with-build-compiler" + <> metavar "PATH" + ) + ) <*> optional ( option str @@ -184,6 +194,7 @@ renderCommonArgs :: CommonArgs -> [String] renderCommonArgs args = maybe [] (\x -> ["--with-cabal", x]) (argCabalInstallPath args) ++ maybe [] (\x -> ["--with-ghc", x]) (argGhcPath args) + ++ maybe [] (\x -> ["--with-build-compiler", x]) (argBuildCompilerPath args) ++ maybe [] (\x -> ["--with-haddock", x]) (argHaddockPath args) ++ maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args) ++ ["--accept" | argAccept args] @@ -329,6 +340,15 @@ cabalTest' mode m = runTestM mode $ do skipUnless "no cabal-install" =<< isAvailableProgram cabalProgram withReaderT (\nenv -> nenv{testCabalInstallAsSetup = True}) m +-- | Run a test only when @--with-build-compiler@ was supplied, passing the +-- build-compiler path to the action. Skips the test otherwise. +withBuildCompiler :: (FilePath -> TestM ()) -> TestM () +withBuildCompiler f = do + env <- getTestEnv + case testBuildCompilerPath env of + Nothing -> skip "no build compiler (pass --with-build-compiler)" + Just p -> f p + type TestM = ReaderT TestEnv IO gitProgram :: Program @@ -444,6 +464,7 @@ runTestM mode m = , testSetupPath = dist_dir "build" "setup" "setup" , testPackageDbPath = case testArgPackageDb args of [] -> Nothing; xs -> Just xs , testSkipSetupTests = argSkipSetupTests (testCommonArgs args) + , testBuildCompilerPath = argBuildCompilerPath cargs , testHaveCabalShared = runnerWithSharedLib senv , testEnvironment = -- Use UTF-8 output on all platforms. @@ -859,6 +880,8 @@ data TestEnv = TestEnv -- use when compiling custom setups, plus the store with possible dependencies of those setup packages. , testSkipSetupTests :: Bool -- ^ Skip Setup tests? + , testBuildCompilerPath :: Maybe FilePath + -- ^ Path to the build compiler for cross-compile tests; 'Nothing' means skip such tests. , testHaveCabalShared :: Bool -- ^ Do we have shared libraries for the Cabal-under-tests? -- This is used for example to determine whether we can build