Skip to content

Commit 51d9f95

Browse files
angermanangerman
committed
Absolutely hacked nonsense, but ... it works?!
1 parent 6939af8 commit 51d9f95

File tree

11 files changed

+181
-51
lines changed

11 files changed

+181
-51
lines changed

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

Lines changed: 10 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -336,7 +336,8 @@ deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =
336336
Nothing -> original
337337
Just pkgs ->
338338
traceShow (pkgid, pkgs) $ mkPackageIndex
339-
(Map.update deletePkgInstance (installedUnitId pkgid) pids)
339+
(foldl' (flip (Map.delete . installedUnitId)) pids pkgs)
340+
-- (Map.update deletePkgInstance (installedUnitId pkgid) pids)
340341
(deletePkgName pnames)
341342
where
342343
deletePkgName =
@@ -345,10 +346,15 @@ deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =
345346
deletePkgVersion :: Map Version [IPI.InstalledPackageInfo] -> Maybe (Map Version [IPI.InstalledPackageInfo])
346347
deletePkgVersion =
347348
(\m -> if Map.null m then Nothing else Just m)
348-
. Map.update deletePkgInstance (packageVersion pkgid)
349+
. Map.update deletePkgInstances (packageVersion pkgid)
349350

350-
deletePkgInstance :: [IPI.InstalledPackageInfo] -> Maybe [IPI.InstalledPackageInfo]
351-
deletePkgInstance xs = if null xs' then Nothing else Just xs'
351+
deletePkgInstance :: IPI.InstalledPackageInfo -> Maybe IPI.InstalledPackageInfo
352+
deletePkgInstance ipi
353+
| pkgCompiler pkgid /= pkgCompiler (IPI.sourcePackageId ipi) = Just ipi
354+
| otherwise = Nothing
355+
356+
deletePkgInstances :: [IPI.InstalledPackageInfo] -> Maybe [IPI.InstalledPackageInfo]
357+
deletePkgInstances xs = if null xs' then Nothing else Just xs'
352358
where xs' = [x | x <- xs, pkgCompiler pkgid /= pkgCompiler (IPI.sourcePackageId x)]
353359

354360
-- | Removes all packages with this (case-sensitive) name from the index.

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

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,7 @@ import Distribution.Solver.Modular.IndexConversion
3434
import Distribution.Solver.Modular.Log
3535
( SolverFailure(..), displayLogMessages )
3636
import Distribution.Solver.Modular.Package
37-
( PN, showPI )
37+
( PN, showPI, I )
3838
import Distribution.Solver.Modular.RetryLog
3939
import Distribution.Solver.Modular.Solver
4040
( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
@@ -56,7 +56,7 @@ import Distribution.Simple.Utils
5656
import Distribution.Verbosity
5757
import Distribution.Solver.Modular.Configured (CP (..))
5858
import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
59-
import Distribution.Pretty (Pretty (..))
59+
import Distribution.Pretty (Pretty (..), prettyShow)
6060
import Text.PrettyPrint (text, vcat, Doc, nest, ($+$))
6161
import Distribution.Solver.Types.OptionalStanza (showStanzas, optStanzaSetNull)
6262
import Distribution.Solver.Types.Toolchain ( Toolchains )
@@ -86,6 +86,10 @@ modularResolver sc toolchains biidx iidx sidx pkgConfigDB pprefs pcs pns = do
8686
Step (show (vcat (map showCP cp))) $
8787
return $ postprocess assignment revdepmap
8888
where
89+
showIdx :: Index -> String
90+
showIdx idx = unlines [prettyShow pn ++ ": " ++ show i
91+
| (pn, m) <- M.toList idx
92+
, (i, _info) <- M.toList (m :: Map I PInfo)]
8993
-- Indices have to be converted into solver-specific uniform index.
9094
idx = convPIs toolchains gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) biidx iidx sidx
9195
-- Constraints have to be converted into a finite map indexed by PN.
@@ -97,7 +101,7 @@ modularResolver sc toolchains biidx iidx sidx pkgConfigDB pprefs pcs pns = do
97101
-- package qualifiers, which means that linked packages become duplicates
98102
-- and can be removed.
99103
postprocess a rdm = ordNubBy nodeKey $
100-
map (convCP biidx iidx sidx) (toCPs a rdm)
104+
map (convCP toolchains biidx iidx sidx) (toCPs a rdm)
101105

102106
-- Helper function to extract the PN from a constraint.
103107
pcName :: PackageConstraint -> PN

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

Lines changed: 9 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -19,16 +19,18 @@ import Distribution.Solver.Types.SolverId
1919
import Distribution.Solver.Types.SolverPackage
2020
import Distribution.Solver.Types.InstSolverPackage
2121
import Distribution.Solver.Types.SourcePackage
22+
import Distribution.Solver.Types.Toolchain
2223
import Control.Applicative ((<|>))
2324

2425
-- | Converts from the solver specific result @CP QPN@ into
2526
-- a 'ResolverPackage', which can then be converted into
2627
-- the install plan.
27-
convCP :: SI.InstalledPackageIndex -- ^ build
28+
convCP :: Toolchains
29+
-> SI.InstalledPackageIndex -- ^ build
2830
-> SI.InstalledPackageIndex -- ^ host
2931
-> CI.PackageIndex (SourcePackage loc)
3032
-> CP QPN -> ResolverPackage loc
31-
convCP biidx iidx sidx (CP qpi fa es ds) =
33+
convCP toolchains biidx iidx sidx (CP qpi fa es ds) =
3234
case qpi of
3335
-- Installed
3436
(PI qpn (I _stage _ (Inst pi))) ->
@@ -41,7 +43,7 @@ convCP biidx iidx sidx (CP qpi fa es ds) =
4143
}
4244
-- "In repo" i.e. a source package
4345
(PI qpn@(Q _path pn) (I stage v InRepo)) ->
44-
let pi = PackageIdentifier pn v Nothing {-# FIXME: should be COMPILERID #-} in
46+
let pi = PackageIdentifier pn v (Just $ compilerIdFor stage toolchains) in
4547
Configured $
4648
SolverPackage {
4749
solverPkgQPN = qpn,
@@ -54,10 +56,10 @@ convCP biidx iidx sidx (CP qpi fa es ds) =
5456
}
5557
where
5658
ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -})
57-
ds' = fmap (partitionEithers . map convConfId) ds
59+
ds' = fmap (partitionEithers . map (convConfId toolchains)) ds
5860

59-
convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}
60-
convConfId (PI (Q (PackagePath _ q) pn) (I _stage v loc)) =
61+
convConfId :: Toolchains -> PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}
62+
convConfId toolchains (PI (Q (PackagePath _ q) pn) (I stage v loc)) =
6163
case loc of
6264
Inst pi ->
6365
Left (PreExistingId sourceId pi)
@@ -72,4 +74,4 @@ convConfId (PI (Q (PackagePath _ q) pn) (I _stage v loc)) =
7274
, pn == pn' -> Right (PlannedId sourceId)
7375
| otherwise -> Left (PlannedId sourceId)
7476
where
75-
sourceId = PackageIdentifier pn v Nothing -- FIXME: this should be the compiler id!
77+
sourceId = PackageIdentifier pn v (Just $ compilerIdFor stage toolchains)

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

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -62,10 +62,14 @@ convPIs :: Toolchains -> Map PN [LabeledPackageConstraint]
6262
-> SI.InstalledPackageIndex -- ^ host
6363
-> CI.PackageIndex (SourcePackage loc)
6464
-> Index
65+
convPIs toolchains constraints sip strfl solveExes biidx iidx sidx =
66+
mkIndex $ (trace (pp "BIPIs" bipis) bipis) ++ (trace (pp "HIPIs" hipis) hipis) ++ (trace (pp "SPIs" spis) spis)
6567
where bipis = convIPI' toolchains sip biidx
6668
hipis = convIPI' toolchains sip iidx
6769
ipis = bipis ++ hipis
6870
spis = convSPI' toolchains constraints strfl solveExes sidx
71+
pp :: String -> [(PN, I, PInfo)] -> String
72+
pp label xs = unlines $ ("=== " ++ label ++ ":\n"):(map (\(pn, i, pi) -> show pn ++ " " ++ show i) xs)
6973

7074
-- | Convert a Cabal installed package index to the simpler,
7175
-- more uniform index format of the solver.
@@ -154,7 +158,7 @@ convIP toolchains idx ipi =
154158
convIPId :: Toolchains -> DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
155159
convIPId toolchains dr comp idx ipid =
156160
case SI.lookupUnitId idx ipid of
157-
Nothing -> Left ipid
161+
Nothing -> traceShow (show comp ++ ": Failed to find: " ++ show ipid ++ " in index.") $ Left ipid
158162
Just ipi -> let (pn, i) = convId toolchains ipi
159163
name = ExposedLib LMainLibName -- TODO: Handle sub-libraries.
160164
in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)
@@ -175,7 +179,8 @@ convSP :: Toolchains -> Map PN [LabeledPackageConstraint]
175179
convSP toolchains constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv _compid) gpd _ _pl) =
176180
let pkgConstraints = fromMaybe [] $ M.lookup pn constraints
177181
in [(pn, I Host pv InRepo, convGPD (hostToolchain toolchains) pkgConstraints strfl solveExes pn gpd)
178-
,(pn, I Build pv InRepo, convGPD (buildToolchain toolchains) pkgConstraints strfl solveExes pn gpd)]
182+
,(pn, I Build pv InRepo, convGPD (buildToolchain toolchains) pkgConstraints strfl solveExes pn gpd)
183+
]
179184

180185
-- We do not use 'flattenPackageDescription' or 'finalizePD'
181186
-- from 'Distribution.PackageDescription.Configuration' here, because we

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -105,6 +105,7 @@ solve sc toolchains idx pkgConfigDB userPrefs userConstraints userGoals =
105105
traceTree "cycles.json" id .
106106
detectCycles .
107107
traceTree "heuristics.json" id .
108+
stageBuildDeps "post-pref: " .
108109
trav (
109110
heuristicsPhase .
110111
preferencesPhase .
@@ -114,9 +115,9 @@ solve sc toolchains idx pkgConfigDB userPrefs userConstraints userGoals =
114115
validationCata .
115116
traceTree "pruned.json" id .
116117
trav prunePhase .
117-
-- stageBuildDeps "post-prune: " .
118+
stageBuildDeps "post-prune: " .
118119
(if buildIsHost toolchains then id else trav P.pruneHostFromSetup) .
119-
-- stageBuildDeps "build: " .
120+
stageBuildDeps "build: " .
120121
traceTree "build.json" id $
121122
buildPhase
122123
where

‎cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ module Distribution.Solver.Types.Toolchain
55
( Toolchain (..)
66
, Toolchains (..)
77
, toolchainFor
8+
, compilerIdFor
89
, mkToolchainsWithHost
910
, buildIsHost
1011
) where
@@ -48,6 +49,9 @@ toolchainFor :: Stage -> Toolchains -> Toolchain
4849
toolchainFor Build = buildToolchain
4950
toolchainFor Host = hostToolchain
5051

52+
compilerIdFor :: Stage -> Toolchains -> CompilerId
53+
compilerIdFor stage = compilerId . toolchainCompiler . toolchainFor stage
54+
5155
instance Binary Toolchains
5256
instance Structured Toolchains
5357

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

Lines changed: 20 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -166,6 +166,8 @@ import Data.List
166166
import qualified Data.Map as Map
167167
import qualified Data.Set as Set
168168

169+
import GHC.Stack (HasCallStack)
170+
169171
-- ------------------------------------------------------------
170172

171173
-- * High level planner policy
@@ -836,13 +838,13 @@ resolveDependencies toolchains pkgConfigDB params =
836838
targets
837839
where
838840
finalparams@( DepResolverParams
839-
targets
841+
targets -- depResolverTargets
840842
constraints
841843
prefs
842844
defpref
843845
installedPkgIndex
844846
binstalledPkgIndex
845-
sourcePkgIndex
847+
sourcePkgIndex -- depResolverSourcePkgIndex
846848
reordGoals
847849
cntConflicts
848850
fineGrained
@@ -928,17 +930,31 @@ interpretPackagesPreference selected defaultPref prefs =
928930
-- | Make an install plan from the output of the dep resolver.
929931
-- It checks that the plan is valid, or it's an error in the dep resolver.
930932
validateSolverResult
931-
:: Toolchains
933+
:: HasCallStack => Toolchains
932934
-> IndependentGoals
933935
-> [ResolverPackage UnresolvedPkgLoc]
934936
-> SolverInstallPlan
935937
validateSolverResult toolchains indepGoals pkgs =
936-
case planPackagesProblems toolchains pkgs of
938+
case planPackagesProblems toolchains (trace (dump pkgs) pkgs) of
937939
[] -> case SolverInstallPlan.new indepGoals graph of
938940
Right plan -> plan
939941
Left problems -> error (formatPlanProblems problems)
940942
problems -> error (formatPkgProblems problems)
941943
where
944+
dump :: [ResolverPackage UnresolvedPkgLoc] -> String
945+
dump xs = unlines $
946+
"=== DUMP ===":[unlines $ (resolverPkgHead x ++ show (packageId x)):[ "- "++ solverIdHead y ++ show (solverSrcId y)
947+
| y <- CD.flatDeps (resolverPackageLibDeps x)]
948+
| x <- xs ]
949+
++ ["=== /DUMP =="]
950+
951+
solverIdHead :: SolverId -> String
952+
solverIdHead (PreExistingId{}) = "[PE]"
953+
solverIdHead (PlannedId {}) = "[PL]"
954+
955+
resolverPkgHead (PreExisting _) = "[PE]"
956+
resolverPkgHead (Configured _) = "[CF]"
957+
942958
graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)
943959
graph = Graph.fromDistinctList pkgs
944960

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

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1091,6 +1091,14 @@ findProjectPackages
10911091
let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo
10921092
namedPkgs = map ProjectPackageNamed projectPackagesNamed
10931093

1094+
-- FIXME: We should _REALLY_ Tag the packages here somehow.
1095+
-- Right now we just slam together requiredPkgs and buildPkgs, ...
1096+
-- Maybe we can carry the Build/Host distinction in the
1097+
-- ProjectPackageLocation. Because we later on really want to make
1098+
-- sure we consider only buildPkgs for building with the Build
1099+
-- compiler, and all others with the Host compiler. For now we just
1100+
-- Assume both for both compilers, but this is not god.
1101+
-- XXX: FIXME!
10941102
return (concat [requiredPkgs, buildPkgs, optionalPkgs, repoPkgs, namedPkgs])
10951103
where
10961104
findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation]

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

Lines changed: 14 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -659,7 +659,8 @@ resolveTargets
659659
checkTarget bt@(TargetPackage _ (ordNub -> [pkgid]) mkfilter)
660660
| Just ats <-
661661
fmap (maybe id filterTargetsKind mkfilter) $
662-
Map.lookup pkgid availableTargetsByPackageId =
662+
(trace (unlines $ ("Failed to find " ++ prettyShow pkgid ++ " in "):[prettyShow k {-# ++ " -> " ++ show v #-} | (k,v) <- Map.toList availableTargetsByPackageId])
663+
(Map.lookup pkgid availableTargetsByPackageId)) =
663664
fmap (componentTargets WholeComponent) $
664665
selectPackageTargets bt ats
665666
| otherwise =
@@ -685,9 +686,18 @@ resolveTargets
685686
$ concat (Map.elems availableTargetsByPackageId)
686687
checkTarget (TargetComponent pkgid cname subtarget)
687688
| Just ats <-
688-
Map.lookup
689-
(pkgid, cname)
690-
availableTargetsByPackageIdAndComponentName =
689+
-- FIXME: this is stupid. We do not know what the target selectors HOST compiler is...
690+
-- so we'll assume tere is only a _SINGLE_ match in the map if we ignore the pkgCompiler.
691+
-- This lookup is now O(n) instead of O(log n).
692+
(trace (unlines $ ("Failed to find " ++ prettyShow pkgid ++ ":" ++ show cname ++ " in "):[prettyShow k ++ ":" ++ show k' {-# ++ " -> " ++ show v #-} | ((k,k'),v) <- Map.toList availableTargetsByPackageIdAndComponentName])
693+
(case [v | ((k,k'),v) <- Map.toList availableTargetsByPackageIdAndComponentName
694+
, k{pkgCompiler = Nothing} == pkgid
695+
, k' == cname] of
696+
[match] -> Just match))
697+
-- (Map.lookup
698+
-- (pkgid, cname)
699+
-- availableTargetsByPackageIdAndComponentName))
700+
=
691701
fmap (componentTargets subtarget) $
692702
selectComponentTargets subtarget ats
693703
| Map.member pkgid availableTargetsByPackageId =

0 commit comments

Comments
 (0)