mirror of
https://github.com/gren-lang/compiler.git
synced 2024-09-11 08:45:42 +03:00
Pass root platform along to all necessary stages of the solver.
This commit is contained in:
parent
6ce6accf50
commit
963c9b3ce4
@ -19,6 +19,7 @@ where
|
||||
import Control.Monad (foldM)
|
||||
import Data.Map ((!))
|
||||
import Data.Map qualified as Map
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Deps.Package qualified as Package
|
||||
import Directories qualified as Dirs
|
||||
import File qualified
|
||||
@ -65,10 +66,14 @@ data Result a
|
||||
data Details
|
||||
= Details V.Version (Map.Map Pkg.Name C.Constraint)
|
||||
|
||||
verify :: Dirs.PackageCache -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
|
||||
verify cache constraints =
|
||||
verify ::
|
||||
Dirs.PackageCache ->
|
||||
Outline.Platform ->
|
||||
Map.Map Pkg.Name C.Constraint ->
|
||||
IO (Result (Map.Map Pkg.Name Details))
|
||||
verify cache rootPlatform constraints =
|
||||
Dirs.withRegistryLock cache $
|
||||
case try constraints of
|
||||
case try rootPlatform constraints of
|
||||
Solver solver ->
|
||||
solver
|
||||
(State cache Map.empty)
|
||||
@ -90,13 +95,20 @@ data AppSolution = AppSolution
|
||||
_app :: Outline.AppOutline
|
||||
}
|
||||
|
||||
addToApp :: Dirs.PackageCache -> Pkg.Name -> V.Version -> Outline.AppOutline -> IO (Result AppSolution)
|
||||
addToApp cache pkg compatibleVsn outline@(Outline.AppOutline _ _ _ direct indirect) =
|
||||
addToApp ::
|
||||
Dirs.PackageCache ->
|
||||
Pkg.Name ->
|
||||
V.Version ->
|
||||
Outline.AppOutline ->
|
||||
IO (Result AppSolution)
|
||||
addToApp cache pkg compatibleVsn outline@(Outline.AppOutline _ rootPlatform _ direct indirect) =
|
||||
Dirs.withRegistryLock cache $
|
||||
let allDeps = Map.union direct indirect
|
||||
|
||||
attempt toConstraint deps =
|
||||
try (Map.insert pkg (C.untilNextMajor compatibleVsn) (Map.map toConstraint deps))
|
||||
try
|
||||
rootPlatform
|
||||
(Map.insert pkg (C.untilNextMajor compatibleVsn) (Map.map toConstraint deps))
|
||||
in case oneOf
|
||||
(attempt C.exactly allDeps)
|
||||
[ attempt C.exactly direct,
|
||||
@ -133,37 +145,38 @@ getTransitive constraints solution unvisited visited =
|
||||
|
||||
-- TRY
|
||||
|
||||
try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
|
||||
try constraints =
|
||||
exploreGoals (Goals constraints Map.empty)
|
||||
try :: Outline.Platform -> Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
|
||||
try rootPlatform constraints =
|
||||
exploreGoals (Goals (NE.List rootPlatform []) constraints Map.empty)
|
||||
|
||||
-- EXPLORE GOALS
|
||||
|
||||
data Goals = Goals
|
||||
{ _pending :: Map.Map Pkg.Name C.Constraint,
|
||||
{ _compatible_platforms :: NE.List Outline.Platform,
|
||||
_pending :: Map.Map Pkg.Name C.Constraint,
|
||||
_solved :: Map.Map Pkg.Name V.Version
|
||||
}
|
||||
|
||||
exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version)
|
||||
exploreGoals (Goals pending solved) =
|
||||
exploreGoals (Goals compatiblePlatforms pending solved) =
|
||||
case Map.minViewWithKey pending of
|
||||
Nothing ->
|
||||
return solved
|
||||
Just ((name, constraint), otherPending) ->
|
||||
do
|
||||
let goals1 = Goals otherPending solved
|
||||
let goals1 = Goals compatiblePlatforms otherPending solved
|
||||
let lowestVersion = C.lowerBound constraint
|
||||
goals2 <- addVersion goals1 name lowestVersion
|
||||
exploreGoals goals2
|
||||
|
||||
addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals
|
||||
addVersion (Goals pending solved) name version =
|
||||
addVersion (Goals compatiblePlatforms pending solved) name version =
|
||||
do
|
||||
(Constraints gren deps) <- getConstraints name version
|
||||
if C.goodGren gren
|
||||
then do
|
||||
newPending <- foldM (addConstraint solved) pending (Map.toList deps)
|
||||
return (Goals newPending (Map.insert name version solved))
|
||||
return (Goals compatiblePlatforms newPending (Map.insert name version solved))
|
||||
else backtrack
|
||||
|
||||
addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
|
||||
|
@ -184,21 +184,21 @@ initEnv key scope root =
|
||||
type Task a = Task.Task Exit.Details a
|
||||
|
||||
verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
|
||||
verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct gren _) =
|
||||
verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct gren rootPlatform) =
|
||||
if Con.goodGren gren
|
||||
then do
|
||||
solution <- verifyConstraints env (Map.map (Con.exactly . Con.lowerBound) direct)
|
||||
solution <- verifyConstraints env rootPlatform (Map.map (Con.exactly . Con.lowerBound) direct)
|
||||
let exposedList = Outline.flattenExposed exposed
|
||||
let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
|
||||
verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
|
||||
else Task.throw $ Exit.DetailsBadGrenInPkg gren
|
||||
|
||||
verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
|
||||
verifyApp env time outline@(Outline.AppOutline grenVersion _ srcDirs direct _) =
|
||||
verifyApp env time outline@(Outline.AppOutline grenVersion rootPlatform srcDirs direct _) =
|
||||
if grenVersion == V.compiler
|
||||
then do
|
||||
stated <- checkAppDeps outline
|
||||
actual <- verifyConstraints env (Map.map Con.exactly stated)
|
||||
actual <- verifyConstraints env rootPlatform (Map.map Con.exactly stated)
|
||||
if Map.size stated == Map.size actual
|
||||
then verifyDependencies env time (ValidApp srcDirs) actual direct
|
||||
else Task.throw Exit.DetailsHandEditedDependencies
|
||||
@ -210,10 +210,14 @@ checkAppDeps (Outline.AppOutline _ _ _ direct indirect) =
|
||||
|
||||
-- VERIFY CONSTRAINTS
|
||||
|
||||
verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
|
||||
verifyConstraints (Env _ _ _ cache) constraints =
|
||||
verifyConstraints ::
|
||||
Env ->
|
||||
Outline.Platform ->
|
||||
Map.Map Pkg.Name Con.Constraint ->
|
||||
Task (Map.Map Pkg.Name Solver.Details)
|
||||
verifyConstraints (Env _ _ _ cache) rootPlatform constraints =
|
||||
do
|
||||
result <- Task.io $ Solver.verify cache constraints
|
||||
result <- Task.io $ Solver.verify cache rootPlatform constraints
|
||||
case result of
|
||||
Solver.Ok details -> return details
|
||||
Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution
|
||||
|
@ -84,7 +84,8 @@ init flags =
|
||||
Left (DPkg.GitError gitError) ->
|
||||
return $ Left $ Exit.InitNoCompatibleDependencies $ Just gitError
|
||||
Right deps -> do
|
||||
result <- Solver.verify cache deps
|
||||
-- TODO: Make root platform customizable
|
||||
result <- Solver.verify cache Outline.Browser deps
|
||||
case result of
|
||||
Solver.Err exit ->
|
||||
return (Left (Exit.InitSolverProblem exit))
|
||||
|
@ -213,7 +213,7 @@ makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ _ _ direct indi
|
||||
-- MAKE PACKAGE PLAN
|
||||
|
||||
makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint)
|
||||
makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _ _) =
|
||||
makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _ rootPlatform) =
|
||||
if Map.member pkg deps
|
||||
then return AlreadyInstalled
|
||||
else do
|
||||
@ -231,7 +231,7 @@ makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _
|
||||
Right compatibleVersion -> do
|
||||
let old = deps
|
||||
let cons = Map.insert pkg (C.untilNextMajor compatibleVersion) old
|
||||
result <- Task.io $ Solver.verify cache cons
|
||||
result <- Task.io $ Solver.verify cache rootPlatform cons
|
||||
case result of
|
||||
Solver.Ok solution ->
|
||||
let (Solver.Details vsn _) = solution ! pkg
|
||||
|
Loading…
Reference in New Issue
Block a user