Skip to content

Commit 17102ac

Browse files
angermanangerman
committed
Make it work [somewhat]
1 parent 0b47c06 commit 17102ac

File tree

6 files changed

+97
-23
lines changed

6 files changed

+97
-23
lines changed

‎Cabal/src/Distribution/Simple/GHC.hs‎

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -418,13 +418,10 @@ getInstalledPackages
418418
-> ProgramDb
419419
-> IO InstalledPackageIndex
420420
getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do
421-
print $ ("getInstalledPackages", (compilerId comp), packagedbs)
422421
checkPackageDbEnvVar verbosity
423422
checkPackageDbStack verbosity comp packagedbs
424423
pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb
425-
let pkgss' = [ (packagedb, (\pkg -> pkg{ InstalledPackageInfo.pkgCompiler = Just (compilerId comp)
426-
,InstalledPackageInfo.installedUnitId = ((\x -> mkUnitId $ prettyShow (compilerId comp) ++ ":" ++ (unUnitId x)) . InstalledPackageInfo.installedUnitId) pkg
427-
,InstalledPackageInfo.depends = (map (\x -> mkUnitId $ prettyShow (compilerId comp) ++ ":" ++ (unUnitId x)) . InstalledPackageInfo.depends) pkg })
424+
let pkgss' = [ (packagedb, (\pkg -> pkg{ InstalledPackageInfo.pkgCompiler = Just (compilerId comp) })
428425
<$> pkgs)
429426
| (packagedb, pkgs) <- pkgss
430427
]

‎cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module Distribution.Solver.Modular.Preference
1515
, onlyConstrained
1616
, sortGoals
1717
, pruneAfterFirstSuccess
18+
, pruneHostFromSetup
1819
) where
1920

2021
import Prelude ()
@@ -347,6 +348,20 @@ avoidReinstalls p = go
347348
x
348349
go x = x
349350

351+
-- | Ensure that Setup (Build time) dependencies only have Build dependencies
352+
-- available and that Host dependencies only have Host dependencies available.
353+
pruneHostFromSetup :: EndoTreeTrav d c
354+
pruneHostFromSetup = go
355+
where
356+
go (PChoiceF qpn rdm gr cs) | (Q (PackagePath _ (QualSetup _)) _) <- qpn =
357+
PChoiceF qpn rdm gr (W.filterKey (not . isHost) cs)
358+
go (PChoiceF qpn rdm gr cs) | (Q (PackagePath _ _) _) <- qpn =
359+
PChoiceF qpn rdm gr (W.filterKey isHost cs)
360+
go x = x
361+
362+
isHost :: POption -> Bool
363+
isHost (POption (I s _ _) _) = s == Host
364+
350365
-- | Require all packages to be mentioned in a constraint or as a goal.
351366
onlyConstrained :: (PN -> Bool) -> EndoTreeTrav d QGoalReason
352367
onlyConstrained p = go

‎cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs‎

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,8 @@ import qualified Distribution.Solver.Modular.PSQ as PSQ
4747
import Distribution.Simple.Setup (BooleanFlag(..))
4848
import Distribution.Simple.Compiler (compilerInfo)
4949

50+
import qualified Distribution.Solver.Modular.WeightedPSQ as W
51+
5052
#ifdef DEBUG_TRACETREE
5153
import qualified Distribution.Solver.Modular.ConflictSet as CS
5254
import qualified Distribution.Solver.Modular.WeightedPSQ as W
@@ -100,6 +102,7 @@ solve :: SolverConfig -- ^ solver parameters
100102
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
101103
solve sc toolchains idx pkgConfigDB userPrefs userConstraints userGoals =
102104
explorePhase .
105+
stageBuildDeps "B" .
103106
traceTree "cycles.json" id .
104107
detectCycles .
105108
traceTree "heuristics.json" id .
@@ -112,6 +115,9 @@ solve sc toolchains idx pkgConfigDB userPrefs userConstraints userGoals =
112115
validationCata .
113116
traceTree "pruned.json" id .
114117
trav prunePhase .
118+
-- stageBuildDeps "A'" .
119+
trav P.pruneHostFromSetup .
120+
stageBuildDeps "A" .
115121
traceTree "build.json" id $
116122
buildPhase
117123
where
@@ -148,6 +154,22 @@ solve sc toolchains idx pkgConfigDB userPrefs userConstraints userGoals =
148154
id)
149155
buildPhase = buildTree idx (independentGoals sc) (S.toList userGoals)
150156

157+
stageBuildDeps prefix = go
158+
where go :: Tree d c -> Tree d c
159+
go (PChoice qpn rdm gr cs) | (Q (PackagePath _ (QualSetup _)) _) <- qpn =
160+
(PChoice qpn rdm gr (trace (prefix ++ show qpn ++ '\n':unlines (map (" - " ++) candidates)) (go <$> cs)))
161+
where candidates = map show . filter (\(I _s _v l) -> l /= InRepo) . map (\(_w, (POption i _), _v) -> i) $ W.toList cs
162+
go (PChoice qpn rdm gr cs) =
163+
(PChoice qpn rdm gr (go <$> cs))
164+
go (FChoice qfn rdm gr t b d cs) =
165+
FChoice qfn rdm gr t b d (go <$> cs)
166+
go (SChoice qsn rdm gr t cs) =
167+
SChoice qsn rdm gr t (go <$> cs)
168+
go (GoalChoice rdm cs) =
169+
GoalChoice rdm (go <$> cs)
170+
go x@(Fail _ _) = x
171+
go x@(Done _ _) = x
172+
151173
allExplicit = M.keysSet userConstraints `S.union` userGoals
152174

153175
pkgIsExplicit :: PN -> Bool

‎cabal-install/src/Distribution/Client/ProjectBuilding.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -214,7 +214,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
214214
BuildInplaceOnly{} -> do
215215
-- TODO: [nice to have] use a proper file monitor rather
216216
-- than this dir exists test
217-
exists <- doesDirectoryExist srcdir
217+
exists <- doesDirectoryExist (traceShowId srcdir)
218218
if exists
219219
then dryRunLocalPkg pkg depsBuildStatus srcdir
220220
else return (BuildStatusUnpack tarball)

‎cabal-install/src/Distribution/Client/ProjectOrchestration.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1001,8 +1001,9 @@ printPlan
10011001
showPkgAndReason (ReadyPackage elab) =
10021002
unwords $
10031003
filter (not . null) $
1004+
-- FIXME: ideally we'd like to display the compiler in there as well.
1005+
-- we do have access to elabStage, but the toolchain isn't around.
10041006
[ " -"
1005-
, show (elabStage elab)
10061007
, if verbosity >= deafening
10071008
then prettyShow (installedUnitId elab)
10081009
else prettyShow (packageId elab)
@@ -1122,7 +1123,9 @@ printPlan
11221123
showBuildProfile =
11231124
"Build profile: "
11241125
++ unwords
1125-
[ "-w " ++ (showCompilerId . toolchainCompiler . buildToolchain . pkgConfigToolchains) elaboratedShared
1126+
[ "-w " ++ (showCompilerId . toolchainCompiler . hostToolchain . pkgConfigToolchains) elaboratedShared
1127+
-- FIXME: this should only be shown if hostToolchain /= buildToolchain
1128+
, "-W " ++ (showCompilerId . toolchainCompiler . buildToolchain . pkgConfigToolchains) elaboratedShared
11261129
, "-O"
11271130
++ ( case globalOptimization <> localOptimization of -- if local is not set, read global
11281131
Setup.Flag NoOptimisation -> "0"

‎cabal-install/src/Distribution/Client/ProjectPlanning.hs‎

Lines changed: 53 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -167,6 +167,7 @@ import Distribution.Solver.Types.Settings
167167
import Distribution.Solver.Types.SolverId
168168
import Distribution.Solver.Types.SolverPackage
169169
import Distribution.Solver.Types.SourcePackage
170+
import Distribution.Solver.Types.Stage
170171

171172
import Distribution.ModuleName
172173
import Distribution.Package
@@ -219,9 +220,10 @@ import qualified Distribution.Simple.GHC as GHC
219220
import qualified Distribution.Simple.GHCJS as GHCJS
220221
import qualified Distribution.Simple.InstallDirs as InstallDirs
221222
import qualified Distribution.Simple.LocalBuildInfo as Cabal
223+
import qualified Distribution.Simple.PackageIndex as PI
222224
import qualified Distribution.Simple.Setup as Cabal
223225
import qualified Distribution.Solver.Types.ComponentDeps as CD
224-
import Distribution.Solver.Types.Stage
226+
-- import Distribution.Solver.Types.Stage
225227
import Distribution.Solver.Types.Toolchain
226228

227229
import qualified Distribution.Compat.Graph as Graph
@@ -770,11 +772,38 @@ rebuildInstallPlan
770772
, hookHashes
771773
)
772774
$ do
775+
-- InstalledPackageIndex
776+
-- type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo
777+
-- data PackageIndex a = PackageIndex
778+
-- { -- The primary index. Each InstalledPackageInfo record is uniquely identified
779+
-- -- by its UnitId.
780+
-- --
781+
-- unitIdIndex :: !(Map UnitId a)
782+
-- , -- This auxiliary index maps package names (case-sensitively) to all the
783+
-- -- versions and instances of that package. This allows us to find all
784+
-- -- versions satisfying a dependency.
785+
-- --
786+
-- -- It is a three-level index. The first level is the package name,
787+
-- -- the second is the package version and the final level is instances
788+
-- -- of the same package version. These are unique by UnitId
789+
-- -- and are kept in preference order.
790+
-- --
791+
-- -- FIXME: Clarify what "preference order" means. Check that this invariant is
792+
-- -- preserved. See #1463 for discussion.
793+
-- packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a]))
794+
-- }
795+
-- deriving (Eq, Generic, Show, Read)
796+
--
797+
-- can probably use fromList $ Map.elems $ on it.
773798
hinstalledPkgIndex <-
774799
getInstalledPackages
775800
verbosity
776801
(hostToolchain toolchains)
777802
corePackageDbs
803+
-- this is an aweful hack, however `getInstalledPackages` is
804+
-- terribly invovled everywhere so we'll have to do with this
805+
-- for now. FIXME!
806+
-- let hinstalledPkgIndex' = PI.fromList $ PI.allPackages hinstalledPkgIndex
778807
binstalledPkgIndex <-
779808
getInstalledPackages
780809
verbosity
@@ -797,6 +826,8 @@ rebuildInstallPlan
797826

798827
liftIO $ do
799828
notice verbosity "Resolving dependencies..."
829+
liftIO $ print ("build compiler", compilerId $ toolchainCompiler $ buildToolchain toolchains)
830+
liftIO $ print ("host compiler", compilerId $ toolchainCompiler $ hostToolchain toolchains)
800831
planOrError <-
801832
foldProgress logMsg (pure . Left) (pure . Right) $
802833
planPackages
@@ -2275,8 +2306,8 @@ elaborateInstallPlan
22752306
then BuildInplaceOnly OnDisk
22762307
else BuildAndInstall
22772308
elabPackageDbs = projectConfigPackageDBs sharedPackageConfig
2278-
elabBuildPackageDBStack = buildAndRegisterDbs
2279-
elabRegisterPackageDBStack = buildAndRegisterDbs
2309+
elabBuildPackageDBStack = buildAndRegisterDbs stage
2310+
elabRegisterPackageDBStack = buildAndRegisterDbs stage
22802311

22812312
elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription
22822313
elabSetupScriptCliVersion =
@@ -2285,19 +2316,25 @@ elaborateInstallPlan
22852316
elabPkgDescription
22862317
libDepGraph
22872318
deps0
2288-
elabSetupPackageDBStack = buildAndRegisterDbs
22892319

2290-
inplacePackageDbs = corePackageDbs ++ [distPackageDB (compilerId elabCompiler)]
2320+
-- This code is ... a bit nuts. We need to parameterise the DB stack
2321+
-- over the stage. (which is also assigned to elabStage). And now
2322+
-- we have inplace, core, ... other DBStacks, for the Setup however,
2323+
-- we _must_ force it to use the Build stage stack. As that's where
2324+
-- the setup dependencies will be found.
2325+
elabSetupPackageDBStack = buildAndRegisterDbs Build
2326+
2327+
inplacePackageDbs stage = corePackageDbs stage ++ [distPackageDB (compilerId (toolchainCompiler (toolchainFor stage toolchains)))]
22912328

2292-
corePackageDbs = storePackageDBStack elabCompiler (projectConfigPackageDBs sharedPackageConfig)
2329+
corePackageDbs stage = storePackageDBStack (toolchainCompiler (toolchainFor stage toolchains)) (projectConfigPackageDBs sharedPackageConfig)
22932330

2294-
elabInplaceBuildPackageDBStack = inplacePackageDbs
2295-
elabInplaceRegisterPackageDBStack = inplacePackageDbs
2296-
elabInplaceSetupPackageDBStack = inplacePackageDbs
2331+
elabInplaceBuildPackageDBStack = inplacePackageDbs stage
2332+
elabInplaceRegisterPackageDBStack = inplacePackageDbs stage
2333+
elabInplaceSetupPackageDBStack = inplacePackageDbs stage
22972334

2298-
buildAndRegisterDbs
2299-
| shouldBuildInplaceOnly pkg = inplacePackageDbs
2300-
| otherwise = corePackageDbs
2335+
buildAndRegisterDbs stage
2336+
| shouldBuildInplaceOnly pkg = inplacePackageDbs stage
2337+
| otherwise = corePackageDbs stage
23012338

23022339
elabPkgDescriptionOverride = descOverride
23032340

@@ -3877,10 +3914,10 @@ setupHsScriptOptions
38773914
-- - if we commit to a Cabal version, the logic in
38783915
Nothing
38793916
else Just elabSetupScriptCliVersion
3880-
, -- for Setup.hs, we _always_ want to use the HOST toolchain.
3881-
useCompiler = Just (toolchainCompiler $ hostToolchain $ pkgConfigToolchains)
3882-
, usePlatform = Just (toolchainPlatform $ hostToolchain $ pkgConfigToolchains)
3883-
, useProgramDb = toolchainProgramDb $ hostToolchain $ pkgConfigToolchains
3917+
, -- for Setup.hs, we _always_ want to use the BUILD toolchain.
3918+
useCompiler = Just (toolchainCompiler $ buildToolchain $ pkgConfigToolchains)
3919+
, usePlatform = Just (toolchainPlatform $ buildToolchain $ pkgConfigToolchains)
3920+
, useProgramDb = toolchainProgramDb $ buildToolchain $ pkgConfigToolchains
38843921
, usePackageDB = elabSetupPackageDBStack
38853922
, usePackageIndex = Nothing
38863923
, useDependencies =

0 commit comments

Comments
 (0)