Skip to content

Commit d1386fc

Browse files
qrilkaqrilka
committed
Attempt of ad-hock cycle resolution
1 parent 3b28b7d commit d1386fc

File tree

1 file changed

+120
-58
lines changed

1 file changed

+120
-58
lines changed

‎src/Stack/Build/ConstructPlan.hs

Lines changed: 120 additions & 58 deletions
Original file line numberDiff line numberDiff line change
@@ -90,9 +90,15 @@ combineMap = Map.mergeWithKey
9090
(fmap (uncurry PIOnlyInstalled))
9191

9292
data AddDepRes
93-
= ADRToInstall Task
93+
= ADRToFullInstall Task
94+
| ADRToLibraryInstall Task (M ())
9495
| ADRFound InstallLocation Installed
95-
deriving Show
96+
97+
instance Show AddDepRes where
98+
show (ADRToFullInstall t) = "ADRToFullInstall (" ++ show t ++ ")"
99+
show (ADRToLibraryInstall t _) = "ADRToLibraryInstall (" ++ show t ++ ", <<postponed>>)"
100+
show (ADRFound il i) = "ADRFound (" ++ show il ++ ", " ++ show i ++ ")"
101+
96102

97103
type ParentMap = MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)])
98104

@@ -179,8 +185,13 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
179185
econfig <- view envConfigL
180186
sources <- getSources
181187

182-
let onTarget = void . addDep False
183-
let inner = mapM_ onTarget $ Map.keys (smtTargets $ smTargets sourceMap)
188+
let inner = do
189+
mapM_ (addDep False) (Map.keys $ smtTargets $ smTargets sourceMap)
190+
m <- get
191+
for_ m $ \adr ->
192+
case adr of
193+
Right (ADRToLibraryInstall _t final) -> final
194+
_ -> return ()
184195
let ctx = mkCtx econfig sources
185196
((), m, W efinals installExes dirtyReason deps warnings parents) <-
186197
liftIO $ runRWST inner ctx M.empty
@@ -193,7 +204,8 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
193204
if null errs
194205
then do
195206
let toTask (_, ADRFound _ _) = Nothing
196-
toTask (name, ADRToInstall task) = Just (name, task)
207+
toTask (name, ADRToFullInstall task) = Just (name, task)
208+
toTask (_name, ADRToLibraryInstall _ _) = error "task is supposed to be finalized at this point"
197209
tasks = M.fromList $ mapMaybe toTask adrs
198210
takeSubset =
199211
case boptsCLIBuildSubset $ bcoBuildOptsCLI baseConfigOpts0 of
@@ -354,35 +366,55 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps =
354366
-- benchmarks. If @isAllInOne@ is 'True' (the common case), then all of
355367
-- these should have already been taken care of as part of the build
356368
-- step.
357-
addFinal :: LocalPackage -> Package -> Bool -> Bool -> M ()
358-
addFinal lp package isAllInOne buildHaddocks = do
359-
depsRes <- addPackageDeps False package
360-
res <- case depsRes of
361-
Left e -> return $ Left e
362-
Right (missing, present, _minLoc) -> do
363-
ctx <- ask
364-
return $ Right Task
365-
{ taskProvides = PackageIdentifier
366-
(packageName package)
367-
(packageVersion package)
368-
, taskConfigOpts = TaskConfigOpts missing $ \missing' ->
369-
let allDeps = Map.union present missing'
370-
in configureOpts
371-
(view envConfigL ctx)
372-
(baseConfigOpts ctx)
373-
allDeps
374-
True -- local
375-
Mutable
376-
package
377-
, taskBuildHaddock = buildHaddocks
378-
, taskPresent = present
379-
, taskType = TTLocalMutable lp
380-
, taskAllInOne = isAllInOne
381-
, taskCachePkgSrc = CacheSrcLocal (toFilePath (parent (lpCabalFile lp)))
382-
, taskAnyMissing = not $ Set.null missing
383-
, taskBuildTypeConfig = packageBuildTypeConfig package
384-
}
385-
tell mempty { wFinals = Map.singleton (packageName package) res }
369+
addFinal :: LocalPackage -> Package -> Bool -> Bool -> Maybe Task -> Either ConstructPlanException AddDepRes -> M (Either ConstructPlanException AddDepRes)
370+
addFinal lp package isAllInOne buildHaddocks mTask parentAdr =
371+
case mTask of
372+
Just task -> do
373+
go AllowCycles $ do
374+
let final = do
375+
res <- goWithNoCycles
376+
updateLibMap (packageName package) res
377+
return $ Right (ADRToLibraryInstall task final)
378+
Nothing -> goWithNoCycles
379+
where
380+
goWithNoCycles = go NoCycles noPartialWithNoCycles
381+
recordAndReturn res = do
382+
tell mempty {wFinals = Map.singleton (packageName package) res}
383+
return parentAdr
384+
go allowCycles onPartial = do
385+
depsRes <- addPackageDeps False allowCycles package
386+
case depsRes of
387+
Left e -> recordAndReturn $ Left e
388+
Right (False, (missing, present, _minLoc)) -> do
389+
ctx <- ask
390+
recordAndReturn $ Right
391+
Task
392+
{ taskProvides =
393+
PackageIdentifier
394+
(packageName package)
395+
(packageVersion package)
396+
, taskConfigOpts =
397+
TaskConfigOpts missing $ \missing' ->
398+
let allDeps = Map.union present missing'
399+
in configureOpts
400+
(view envConfigL ctx)
401+
(baseConfigOpts ctx)
402+
allDeps
403+
True -- local
404+
Mutable
405+
package
406+
, taskBuildHaddock = buildHaddocks
407+
, taskPresent = present
408+
, taskType = TTLocalMutable lp
409+
, taskAllInOne = isAllInOne
410+
, taskCachePkgSrc =
411+
CacheSrcLocal
412+
(toFilePath (parent (lpCabalFile lp)))
413+
, taskAnyMissing = not $ Set.null missing
414+
, taskBuildTypeConfig =
415+
packageBuildTypeConfig package
416+
}
417+
Right (True, _) -> onPartial
386418

387419
-- | Given a 'PackageName', adds all of the build tasks to build the
388420
-- package, if needed.
@@ -489,31 +521,31 @@ installPackage treatAsDep name ps minstalled = do
489521
PSRemote pkgLoc _version _fromSnaphot cp -> do
490522
planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name
491523
package <- loadPackage ctx pkgLoc (cpFlags cp) (cpGhcOptions cp)
492-
resolveDepsAndInstall True treatAsDep (cpHaddocks cp) ps package minstalled
524+
resolveDepsAndInstall treatAsDep (cpHaddocks cp) ps package minstalled Nothing
493525
PSFilePath lp ->
494526
case lpTestBench lp of
495527
Nothing -> do
496528
planDebug $ "installPackage: No test / bench component for " ++ show name ++ " so doing an all-in-one build."
497-
resolveDepsAndInstall True treatAsDep (lpBuildHaddocks lp) ps (lpPackage lp) minstalled
529+
resolveDepsAndInstall treatAsDep (lpBuildHaddocks lp) ps (lpPackage lp) minstalled Nothing
498530
Just tb -> do
499531
-- Attempt to find a plan which performs an all-in-one
500532
-- build. Ignore the writer action + reset the state if
501533
-- it fails.
502534
s <- get
503535
res <- pass $ do
504-
res <- addPackageDeps treatAsDep tb
536+
res <- addPackageDeps treatAsDep NoCycles tb
505537
let writerFunc w = case res of
506538
Left _ -> mempty
507539
_ -> w
508540
return (res, writerFunc)
509541
case res of
510-
Right deps -> do
542+
Right (partial, deps) -> do
543+
when partial noPartialWithNoCycles
511544
planDebug $ "installPackage: For " ++ show name ++ ", successfully added package deps"
512545
adr <- installPackageGivenDeps True False ps tb minstalled deps
513546
-- FIXME: this redundantly adds the deps (but
514547
-- they'll all just get looked up in the map)
515-
addFinal lp tb True False
516-
return $ Right adr
548+
addFinal lp tb True False Nothing $ Right adr
517549
Left _ -> do
518550
-- Reset the state to how it was before
519551
-- attempting to find an all-in-one build
@@ -522,26 +554,40 @@ installPackage treatAsDep name ps minstalled = do
522554
put s
523555
-- Otherwise, fall back on building the
524556
-- tests / benchmarks in a separate step.
525-
res' <- resolveDepsAndInstall False treatAsDep (lpBuildHaddocks lp) ps (lpPackage lp) minstalled
526-
when (isRight res') $ do
557+
resolveDepsAndInstall treatAsDep (lpBuildHaddocks lp) ps (lpPackage lp) minstalled $ Just $ \adr -> do
558+
let res' = Right adr
527559
-- Insert it into the map so that it's
528560
-- available for addFinal.
529561
updateLibMap name res'
530-
addFinal lp tb False False
531-
return res'
562+
case adr of
563+
ADRToFullInstall t -> do
564+
addFinal lp tb False False (Just t) res'
565+
_ ->
566+
addFinal lp tb False False Nothing res'
532567

533568
resolveDepsAndInstall :: Bool
534-
-> Bool
535569
-> Bool
536570
-> PackageSource
537571
-> Package
538572
-> Maybe Installed
573+
-> Maybe (AddDepRes -> M (Either ConstructPlanException AddDepRes))
539574
-> M (Either ConstructPlanException AddDepRes)
540-
resolveDepsAndInstall isAllInOne treatAsDep buildHaddocks ps package minstalled = do
541-
res <- addPackageDeps treatAsDep package
575+
resolveDepsAndInstall treatAsDep buildHaddocks ps package minstalled mOnPartial = do
576+
let allowCycles = case mOnPartial of
577+
Just _ -> AllowCycles
578+
Nothing -> NoCycles
579+
res <- addPackageDeps treatAsDep allowCycles package
542580
case res of
543581
Left err -> return $ Left err
544-
Right deps -> liftM Right $ installPackageGivenDeps isAllInOne buildHaddocks ps package minstalled deps
582+
Right (False, deps) -> do
583+
install <- installPackageGivenDeps True buildHaddocks ps package minstalled deps
584+
return $ Right install
585+
Right (True, deps) -> do
586+
case mOnPartial of
587+
Just onPartial -> do
588+
install <- installPackageGivenDeps False buildHaddocks ps package minstalled deps
589+
onPartial install
590+
Nothing -> noPartialWithNoCycles
545591

546592
-- | Checks if we need to install the given 'Package', given the results
547593
-- of 'addPackageDeps'. If dependencies are missing, the package is
@@ -571,7 +617,7 @@ installPackageGivenDeps isAllInOne buildHaddocks ps package minstalled (missing,
571617
mutable = installLocationIsMutable loc <> minMutable
572618
return $ case mRightVersionInstalled of
573619
Just installed -> ADRFound loc installed
574-
Nothing -> ADRToInstall Task
620+
Nothing -> ADRToFullInstall Task
575621
{ taskProvides = PackageIdentifier
576622
(packageName package)
577623
(packageVersion package)
@@ -615,6 +661,14 @@ addEllipsis t
615661
| T.length t < 100 = t
616662
| otherwise = T.take 97 t <> "..."
617663

664+
data AllowCycles
665+
= AllowCycles
666+
| NoCycles
667+
deriving (Show, Eq)
668+
669+
noPartialWithNoCycles :: a
670+
noPartialWithNoCycles = error "Install can't be partial with no cycles allowed"
671+
618672
-- | Given a package, recurses into all of its dependencies. The results
619673
-- indicate which packages are missing, meaning that their 'GhcPkgId's
620674
-- will be figured out during the build, after they've been built. The
@@ -626,8 +680,9 @@ addEllipsis t
626680
-- is 'Snap', then it can either be installed locally or in the
627681
-- snapshot.
628682
addPackageDeps :: Bool -- ^ is this being used by a dependency?
629-
-> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
630-
addPackageDeps treatAsDep package = do
683+
-> AllowCycles
684+
-> Package -> M (Either ConstructPlanException (Bool, (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)))
685+
addPackageDeps treatAsDep allowCycles package = do
631686
ctx <- ask
632687
deps' <- packageDepsWithTools package
633688
deps <- forM (Map.toList deps') $ \(depname, DepValue range depType) -> do
@@ -695,7 +750,9 @@ addPackageDeps treatAsDep package = do
695750
else return False
696751
if inRange
697752
then case adr of
698-
ADRToInstall task -> return $ Right
753+
ADRToLibraryInstall task _postponed -> return $ Right
754+
(Set.singleton $ taskProvides task, Map.empty, taskTargetIsMutable task)
755+
ADRToFullInstall task -> return $ Right
699756
(Set.singleton $ taskProvides task, Map.empty, taskTargetIsMutable task)
700757
ADRFound loc (Executable _) -> return $ Right
701758
(Set.empty, Map.empty, installLocationIsMutable loc)
@@ -710,12 +767,16 @@ addPackageDeps treatAsDep package = do
710767
-- package must be installed locally. Otherwise the result is
711768
-- 'Snap', indicating that the parent can either be installed
712769
-- locally or in the snapshot.
713-
([], pairs) -> return $ Right $ mconcat pairs
714-
(errs, _) -> return $ Left $ DependencyPlanFailures
715-
package
716-
(Map.fromList errs)
770+
([], pairs) -> return $ Right (False, mconcat pairs)
771+
(errs, pairs) ->
772+
if allowCycles == AllowCycles && all isCycleErr errs
773+
then return $ Right (True, mconcat pairs)
774+
else return $ Left $ DependencyPlanFailures package (Map.fromList errs)
717775
where
718-
adrVersion (ADRToInstall task) = pkgVersion $ taskProvides task
776+
isCycleErr (_, (_, _, BDDependencyCycleDetected _)) = True
777+
isCycleErr _ = False
778+
adrVersion (ADRToFullInstall task) = pkgVersion $ taskProvides task
779+
adrVersion (ADRToLibraryInstall task _) = pkgVersion $ taskProvides task
719780
adrVersion (ADRFound _ installed) = installedVersion installed
720781
-- Update the parents map, for later use in plan construction errors
721782
-- - see 'getShortestDepsPath'.
@@ -724,7 +785,8 @@ addPackageDeps treatAsDep package = do
724785
val = (First mversion, [(packageIdentifier package, range)])
725786

726787
adrHasLibrary :: AddDepRes -> Bool
727-
adrHasLibrary (ADRToInstall task) = taskHasLibrary task
788+
adrHasLibrary (ADRToFullInstall task) = taskHasLibrary task
789+
adrHasLibrary (ADRToLibraryInstall task _) = taskHasLibrary task
728790
adrHasLibrary (ADRFound _ Library{}) = True
729791
adrHasLibrary (ADRFound _ Executable{}) = False
730792

0 commit comments

Comments
 (0)