mirror of
https://github.com/gren-lang/compiler.git
synced 2024-09-11 08:45:42 +03:00
Merge pull request #169 from gren-lang/local-disk-dependencies
Local disk dependencies
This commit is contained in:
commit
8a58879429
@ -19,6 +19,7 @@ where
|
||||
import Control.Monad (foldM)
|
||||
import Data.Map ((!))
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Deps.Package qualified as Package
|
||||
import Directories qualified as Dirs
|
||||
import File qualified
|
||||
@ -26,10 +27,13 @@ import Gren.Constraint qualified as C
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.PossibleFilePath (PossibleFilePath)
|
||||
import Gren.PossibleFilePath qualified as PossibleFilePath
|
||||
import Gren.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Reporting qualified
|
||||
import Reporting.Exit qualified as Exit
|
||||
import System.Directory qualified as Dir
|
||||
import System.FilePath ((</>))
|
||||
|
||||
-- SOLVER
|
||||
@ -52,7 +56,7 @@ data State = State
|
||||
data Constraints = Constraints
|
||||
{ _gren :: C.Constraint,
|
||||
_platform :: Platform.Platform,
|
||||
_deps :: Map.Map Pkg.Name C.Constraint
|
||||
_deps :: Map.Map Pkg.Name (PossibleFilePath C.Constraint)
|
||||
}
|
||||
|
||||
-- RESULT
|
||||
@ -65,13 +69,13 @@ data Result a
|
||||
-- VERIFY -- used by Gren.Details
|
||||
|
||||
data Details
|
||||
= Details V.Version (Map.Map Pkg.Name C.Constraint)
|
||||
= Details V.Version (Maybe FilePath) (Map.Map Pkg.Name (PossibleFilePath C.Constraint))
|
||||
|
||||
verify ::
|
||||
Reporting.DKey ->
|
||||
Dirs.PackageCache ->
|
||||
Platform.Platform ->
|
||||
Map.Map Pkg.Name C.Constraint ->
|
||||
Map.Map Pkg.Name (PossibleFilePath C.Constraint) ->
|
||||
IO (Result (Map.Map Pkg.Name Details))
|
||||
verify key cache rootPlatform constraints =
|
||||
Dirs.withRegistryLock cache $
|
||||
@ -83,17 +87,18 @@ verify key cache rootPlatform constraints =
|
||||
(\_ -> return NoSolution)
|
||||
(\e -> return $ Err e)
|
||||
|
||||
addDeps :: State -> Pkg.Name -> V.Version -> Details
|
||||
addDeps (State _ constraints) name vsn =
|
||||
case Map.lookup (name, vsn) constraints of
|
||||
Just (Constraints _ _ deps) -> Details vsn deps
|
||||
Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
|
||||
addDeps :: State -> Pkg.Name -> ConstraintSource -> Details
|
||||
addDeps (State _ constraints) name constraintSource =
|
||||
let vsn = C.lowerBound $ constraintFromCS constraintSource
|
||||
in case Map.lookup (name, vsn) constraints of
|
||||
Just (Constraints _ _ deps) -> Details vsn (filePathFromCS constraintSource) deps
|
||||
Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
|
||||
|
||||
-- ADD TO APP - used in Install
|
||||
|
||||
data AppSolution = AppSolution
|
||||
{ _old :: Map.Map Pkg.Name V.Version,
|
||||
_new :: Map.Map Pkg.Name V.Version,
|
||||
{ _old :: Map.Map Pkg.Name (PossibleFilePath V.Version),
|
||||
_new :: Map.Map Pkg.Name (PossibleFilePath V.Version),
|
||||
_app :: Outline.AppOutline
|
||||
}
|
||||
|
||||
@ -108,11 +113,13 @@ addToApp key cache pkg compatibleVsn outline@(Outline.AppOutline _ rootPlatform
|
||||
Dirs.withRegistryLock cache $
|
||||
let allDeps = Map.union direct indirect
|
||||
|
||||
insertableVsn = PossibleFilePath.Other (C.untilNextMajor compatibleVsn)
|
||||
|
||||
attempt toConstraint deps =
|
||||
try
|
||||
key
|
||||
rootPlatform
|
||||
(Map.insert pkg (C.untilNextMajor compatibleVsn) (Map.map toConstraint deps))
|
||||
(Map.insert pkg insertableVsn (Map.map (PossibleFilePath.mapWith toConstraint) deps))
|
||||
in case oneOf
|
||||
(attempt C.exactly allDeps)
|
||||
[ attempt C.exactly direct,
|
||||
@ -126,95 +133,159 @@ addToApp key cache pkg compatibleVsn outline@(Outline.AppOutline _ rootPlatform
|
||||
(\_ -> return $ NoSolution)
|
||||
(\e -> return $ Err e)
|
||||
|
||||
toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
|
||||
toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name (PossibleFilePath V.Version) -> Map.Map Pkg.Name ConstraintSource -> AppSolution
|
||||
toApp (State _ constraints) pkg (Outline.AppOutline gren platform srcDirs direct _) old new =
|
||||
let d = Map.intersection new (Map.insert pkg V.one direct)
|
||||
i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
|
||||
in AppSolution old new (Outline.AppOutline gren platform srcDirs d i)
|
||||
let newAsPFPs = Map.map constraintToFilePath new
|
||||
d = Map.intersection newAsPFPs (Map.insert pkg (PossibleFilePath.Other V.one) direct)
|
||||
dCSs = filter (\(pkgName, _) -> Map.member pkgName d) $ Map.toList new
|
||||
i = Map.map constraintToFilePath $ Map.difference (getTransitive constraints new dCSs Map.empty) d
|
||||
in AppSolution old newAsPFPs (Outline.AppOutline gren platform srcDirs d i)
|
||||
|
||||
getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name, V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
|
||||
constraintToFilePath :: ConstraintSource -> PossibleFilePath V.Version
|
||||
constraintToFilePath cs =
|
||||
case cs of
|
||||
Local _ fp -> PossibleFilePath.Is fp
|
||||
Remote con -> PossibleFilePath.Other $ C.lowerBound con
|
||||
|
||||
getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name ConstraintSource -> [(Pkg.Name, ConstraintSource)] -> Map.Map Pkg.Name ConstraintSource -> Map.Map Pkg.Name ConstraintSource
|
||||
getTransitive constraints solution unvisited visited =
|
||||
case unvisited of
|
||||
[] ->
|
||||
visited
|
||||
info@(pkg, vsn) : infos ->
|
||||
(pkg, cs) : infos ->
|
||||
if Map.member pkg visited
|
||||
then getTransitive constraints solution infos visited
|
||||
else
|
||||
let newDeps = _deps (constraints ! info)
|
||||
let vsn = C.lowerBound $ constraintFromCS cs
|
||||
newDeps = _deps (constraints ! (pkg, vsn))
|
||||
newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))
|
||||
newVisited = Map.insert pkg vsn visited
|
||||
newVisited = Map.insert pkg cs visited
|
||||
in getTransitive constraints solution infos $
|
||||
getTransitive constraints solution newUnvisited newVisited
|
||||
|
||||
-- CONSTRAINT SOURCE
|
||||
|
||||
data ConstraintSource
|
||||
= Remote C.Constraint
|
||||
| Local C.Constraint FilePath
|
||||
|
||||
-- TODO: Avoid re-reading the gren.json for local dependencies
|
||||
resolveToConstraintSource :: Pkg.Name -> PossibleFilePath C.Constraint -> Solver ConstraintSource
|
||||
resolveToConstraintSource pkgName possibleFP =
|
||||
Solver $ \state ok back err ->
|
||||
case possibleFP of
|
||||
PossibleFilePath.Other cons ->
|
||||
ok state (Remote cons) back
|
||||
PossibleFilePath.Is fp ->
|
||||
do
|
||||
outlineExists <- Dir.doesDirectoryExist fp
|
||||
if outlineExists
|
||||
then do
|
||||
let outlinePath = fp </> "gren.json"
|
||||
bytes <- File.readUtf8 outlinePath
|
||||
case D.fromByteString Outline.decoder bytes of
|
||||
Right (Outline.Pkg (Outline.PkgOutline _ _ _ version _ _ _ _)) ->
|
||||
ok state (Local (C.exactly version) fp) back
|
||||
Right _ ->
|
||||
err $ Exit.SolverBadLocalDep pkgName fp
|
||||
Left _ ->
|
||||
err $ Exit.SolverBadLocalDep pkgName fp
|
||||
else err $ Exit.SolverBadLocalDep pkgName fp
|
||||
|
||||
constraintFromCS :: ConstraintSource -> C.Constraint
|
||||
constraintFromCS source =
|
||||
case source of
|
||||
Remote c -> c
|
||||
Local c _ -> c
|
||||
|
||||
setConstraintInCS :: C.Constraint -> ConstraintSource -> ConstraintSource
|
||||
setConstraintInCS newCons source =
|
||||
case source of
|
||||
Remote _ -> Remote newCons
|
||||
Local _ fp -> Local newCons fp
|
||||
|
||||
filePathFromCS :: ConstraintSource -> Maybe FilePath
|
||||
filePathFromCS source =
|
||||
case source of
|
||||
Remote _ -> Nothing
|
||||
Local _ fp -> Just fp
|
||||
|
||||
-- TRY
|
||||
|
||||
try :: Reporting.DKey -> Platform.Platform -> Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
|
||||
try :: Reporting.DKey -> Platform.Platform -> Map.Map Pkg.Name (PossibleFilePath C.Constraint) -> Solver (Map.Map Pkg.Name ConstraintSource)
|
||||
try key rootPlatform constraints =
|
||||
exploreGoals key (Goals rootPlatform constraints Map.empty)
|
||||
do
|
||||
constraintSources <- Map.traverseWithKey resolveToConstraintSource constraints
|
||||
exploreGoals key (Goals rootPlatform constraintSources Map.empty)
|
||||
|
||||
-- EXPLORE GOALS
|
||||
|
||||
data Goals = Goals
|
||||
{ _root_platform :: Platform.Platform,
|
||||
_pending :: Map.Map Pkg.Name C.Constraint,
|
||||
_solved :: Map.Map Pkg.Name V.Version
|
||||
_pending :: Map.Map Pkg.Name ConstraintSource,
|
||||
_solved :: Map.Map Pkg.Name ConstraintSource
|
||||
}
|
||||
|
||||
exploreGoals :: Reporting.DKey -> Goals -> Solver (Map.Map Pkg.Name V.Version)
|
||||
exploreGoals :: Reporting.DKey -> Goals -> Solver (Map.Map Pkg.Name ConstraintSource)
|
||||
exploreGoals key (Goals rootPlatform pending solved) =
|
||||
case Map.minViewWithKey pending of
|
||||
Nothing ->
|
||||
return solved
|
||||
Just ((name, constraint), otherPending) ->
|
||||
Just ((name, constraintSource), otherPending) ->
|
||||
do
|
||||
let goals1 = Goals rootPlatform otherPending solved
|
||||
let lowestVersion = C.lowerBound constraint
|
||||
goals2 <- addVersion key goals1 name lowestVersion
|
||||
goals2 <- addVersion key goals1 name constraintSource
|
||||
exploreGoals key goals2
|
||||
|
||||
addVersion :: Reporting.DKey -> Goals -> Pkg.Name -> V.Version -> Solver Goals
|
||||
addVersion reportKey (Goals rootPlatform pending solved) name version =
|
||||
addVersion :: Reporting.DKey -> Goals -> Pkg.Name -> ConstraintSource -> Solver Goals
|
||||
addVersion reportKey (Goals rootPlatform pending solved) name source =
|
||||
do
|
||||
(Constraints gren platform deps) <- getConstraints reportKey name version
|
||||
let constraint = constraintFromCS source
|
||||
let lowestVersion = C.lowerBound constraint
|
||||
let maybeFilePath = filePathFromCS source
|
||||
(Constraints gren platform deps) <- getConstraints reportKey name lowestVersion maybeFilePath
|
||||
if C.goodGren gren
|
||||
then
|
||||
if Platform.compatible rootPlatform platform
|
||||
then do
|
||||
newPending <- foldM (addConstraint name solved) pending (Map.toList deps)
|
||||
return (Goals rootPlatform newPending (Map.insert name version solved))
|
||||
depsConstraintSources <- Map.traverseWithKey resolveToConstraintSource deps
|
||||
newPending <- foldM (addConstraint name solved) pending (Map.toList depsConstraintSources)
|
||||
return (Goals rootPlatform newPending (Map.insert name source solved))
|
||||
else
|
||||
solverError $
|
||||
Exit.SolverIncompatiblePlatforms name rootPlatform platform
|
||||
else backtrack
|
||||
|
||||
addConstraint :: Pkg.Name -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
|
||||
addConstraint sourcePkg solved unsolved (name, newConstraint) =
|
||||
case Map.lookup name solved of
|
||||
Just version ->
|
||||
if C.satisfies newConstraint version
|
||||
then return unsolved
|
||||
else
|
||||
solverError $
|
||||
Exit.SolverIncompatibleSolvedVersion sourcePkg name newConstraint version
|
||||
Nothing ->
|
||||
case Map.lookup name unsolved of
|
||||
Nothing ->
|
||||
return $ Map.insert name newConstraint unsolved
|
||||
Just oldConstraint ->
|
||||
case C.intersect oldConstraint newConstraint of
|
||||
Nothing ->
|
||||
solverError $
|
||||
Exit.SolverIncompatibleVersionRanges sourcePkg name oldConstraint newConstraint
|
||||
Just mergedConstraint ->
|
||||
if oldConstraint == mergedConstraint
|
||||
addConstraint :: Pkg.Name -> Map.Map Pkg.Name ConstraintSource -> Map.Map Pkg.Name ConstraintSource -> (Pkg.Name, ConstraintSource) -> Solver (Map.Map Pkg.Name ConstraintSource)
|
||||
addConstraint sourcePkg solved unsolved (name, newConstraintSource) =
|
||||
let newConstraint = constraintFromCS newConstraintSource
|
||||
in case Map.lookup name solved of
|
||||
Just solvedConstraintSource ->
|
||||
let solvedVersion = C.lowerBound $ constraintFromCS solvedConstraintSource
|
||||
in if C.satisfies newConstraint solvedVersion
|
||||
then return unsolved
|
||||
else return (Map.insert name mergedConstraint unsolved)
|
||||
else
|
||||
solverError $
|
||||
Exit.SolverIncompatibleSolvedVersion sourcePkg name newConstraint solvedVersion
|
||||
Nothing ->
|
||||
case Map.lookup name unsolved of
|
||||
Nothing ->
|
||||
return $ Map.insert name newConstraintSource unsolved
|
||||
Just oldConstraintSource ->
|
||||
let oldConstraint = constraintFromCS oldConstraintSource
|
||||
in case C.intersect oldConstraint newConstraint of
|
||||
Nothing ->
|
||||
solverError $
|
||||
Exit.SolverIncompatibleVersionRanges sourcePkg name oldConstraint newConstraint
|
||||
Just mergedConstraint ->
|
||||
if oldConstraint == mergedConstraint
|
||||
then return unsolved
|
||||
else return (Map.insert name (setConstraintInCS mergedConstraint newConstraintSource) unsolved)
|
||||
|
||||
-- GET CONSTRAINTS
|
||||
|
||||
getConstraints :: Reporting.DKey -> Pkg.Name -> V.Version -> Solver Constraints
|
||||
getConstraints reportKey pkg vsn =
|
||||
getConstraints :: Reporting.DKey -> Pkg.Name -> V.Version -> Maybe FilePath -> Solver Constraints
|
||||
getConstraints reportKey pkg vsn maybeFilePath =
|
||||
Solver $ \state@(State cache cDict) ok back err ->
|
||||
do
|
||||
let key = (pkg, vsn)
|
||||
@ -223,11 +294,13 @@ getConstraints reportKey pkg vsn =
|
||||
ok state cs back
|
||||
Nothing ->
|
||||
do
|
||||
isPackageInCache <- Package.isPackageInCache cache pkg vsn
|
||||
if isPackageInCache
|
||||
let packageCachePath = Dirs.package cache pkg vsn
|
||||
let path = Maybe.fromMaybe packageCachePath maybeFilePath
|
||||
isPackageOnDisk <- Dir.doesDirectoryExist path
|
||||
if isPackageOnDisk
|
||||
then do
|
||||
Reporting.report reportKey Reporting.DCached
|
||||
constraintsDecodeResult <- getConstraintsHelper cache pkg vsn
|
||||
constraintsDecodeResult <- getConstraintsHelper path pkg vsn
|
||||
case constraintsDecodeResult of
|
||||
Left exitMsg ->
|
||||
err exitMsg
|
||||
@ -243,17 +316,17 @@ getConstraints reportKey pkg vsn =
|
||||
err $ Exit.SolverBadGitOperationVersionedPkg pkg vsn gitErr
|
||||
Right () -> do
|
||||
Reporting.report reportKey $ Reporting.DReceived pkg vsn
|
||||
constraintsDecodeResult <- getConstraintsHelper cache pkg vsn
|
||||
constraintsDecodeResult <- getConstraintsHelper packageCachePath pkg vsn
|
||||
case constraintsDecodeResult of
|
||||
Left exitMsg ->
|
||||
err exitMsg
|
||||
Right cs ->
|
||||
ok (State cache (Map.insert key cs cDict)) cs back
|
||||
|
||||
getConstraintsHelper :: Dirs.PackageCache -> Pkg.Name -> V.Version -> IO (Either Exit.Solver Constraints)
|
||||
getConstraintsHelper cache pkg vsn =
|
||||
getConstraintsHelper :: FilePath -> Pkg.Name -> V.Version -> IO (Either Exit.Solver Constraints)
|
||||
getConstraintsHelper projectRoot pkg vsn =
|
||||
do
|
||||
let path = Dirs.package cache pkg vsn </> "gren.json"
|
||||
let path = projectRoot </> "gren.json"
|
||||
bytes <- File.readUtf8 path
|
||||
case D.fromByteString constraintsDecoder bytes of
|
||||
Right cs ->
|
||||
|
@ -4,10 +4,8 @@ module Directories
|
||||
( details,
|
||||
interfaces,
|
||||
objects,
|
||||
prepublishDir,
|
||||
greni,
|
||||
greno,
|
||||
temp,
|
||||
findRoot,
|
||||
withRootLock,
|
||||
withRegistryLock,
|
||||
@ -46,10 +44,6 @@ objects :: FilePath -> FilePath
|
||||
objects root =
|
||||
projectCache root </> "o.dat"
|
||||
|
||||
prepublishDir :: FilePath -> FilePath
|
||||
prepublishDir root =
|
||||
projectCache root </> "prepublish"
|
||||
|
||||
compilerVersion :: FilePath
|
||||
compilerVersion =
|
||||
V.toChars V.compiler
|
||||
@ -68,12 +62,6 @@ toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath
|
||||
toArtifactPath root name ext =
|
||||
projectCache root </> ModuleName.toHyphenPath name <.> ext
|
||||
|
||||
-- TEMP
|
||||
|
||||
temp :: FilePath -> String -> FilePath
|
||||
temp root ext =
|
||||
projectCache root </> "temp" <.> ext
|
||||
|
||||
-- ROOT
|
||||
|
||||
findRoot :: IO (Maybe FilePath)
|
||||
|
@ -45,6 +45,8 @@ import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as P
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.PossibleFilePath (PossibleFilePath)
|
||||
import Gren.PossibleFilePath qualified as PossibleFilePath
|
||||
import Gren.Version qualified as V
|
||||
import Json.Encode qualified as E
|
||||
import Parse.Module qualified as Parse
|
||||
@ -190,45 +192,45 @@ verifyPkg env@(Env reportKey _ _ _) time (Outline.PkgOutline pkg _ _ _ exposed d
|
||||
if Con.goodGren gren
|
||||
then do
|
||||
_ <- Task.io $ Reporting.report reportKey $ Reporting.DStart $ Map.size direct
|
||||
solution <- verifyConstraints env rootPlatform (Map.map (Con.exactly . Con.lowerBound) direct)
|
||||
solution <-
|
||||
verifyConstraints
|
||||
env
|
||||
rootPlatform
|
||||
(Map.map (PossibleFilePath.mapWith (Con.exactly . Con.lowerBound)) direct)
|
||||
let exposedList = Outline.flattenExposed exposed
|
||||
verifyDependencies env time (ValidPkg rootPlatform pkg exposedList) solution direct
|
||||
else Task.throw $ Exit.DetailsBadGrenInPkg gren
|
||||
|
||||
verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
|
||||
verifyApp env@(Env reportKey _ _ _) time outline@(Outline.AppOutline grenVersion rootPlatform srcDirs direct _) =
|
||||
verifyApp env@(Env reportKey _ _ _) time (Outline.AppOutline grenVersion rootPlatform srcDirs direct indirect) =
|
||||
if grenVersion == V.compiler
|
||||
then do
|
||||
stated <- checkAppDeps outline
|
||||
stated <- union noDups direct indirect
|
||||
_ <- Task.io $ Reporting.report reportKey $ Reporting.DStart (Map.size stated)
|
||||
actual <- verifyConstraints env rootPlatform (Map.map Con.exactly stated)
|
||||
actual <- verifyConstraints env rootPlatform (Map.map (PossibleFilePath.mapWith Con.exactly) stated)
|
||||
if Map.size stated == Map.size actual
|
||||
then verifyDependencies env time (ValidApp rootPlatform srcDirs) actual direct
|
||||
else
|
||||
let actualVersions = Map.map (\(Solver.Details vsn _) -> vsn) actual
|
||||
let actualVersions = Map.map (\(Solver.Details vsn _ _) -> vsn) actual
|
||||
in Task.throw $
|
||||
Exit.DetailsMissingDeps $
|
||||
Map.toList $
|
||||
Map.difference actualVersions stated
|
||||
else Task.throw $ Exit.DetailsBadGrenInAppOutline grenVersion
|
||||
|
||||
checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
|
||||
checkAppDeps (Outline.AppOutline _ _ _ direct indirect) =
|
||||
union noDups direct indirect
|
||||
|
||||
-- VERIFY CONSTRAINTS
|
||||
|
||||
verifyConstraints ::
|
||||
Env ->
|
||||
Platform.Platform ->
|
||||
Map.Map Pkg.Name Con.Constraint ->
|
||||
Map.Map Pkg.Name (PossibleFilePath Con.Constraint) ->
|
||||
Task (Map.Map Pkg.Name Solver.Details)
|
||||
verifyConstraints (Env reportKey _ _ cache) rootPlatform constraints =
|
||||
do
|
||||
result <- Task.io $ Solver.verify reportKey cache rootPlatform constraints
|
||||
case result of
|
||||
Solver.Ok details -> return details
|
||||
Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution
|
||||
Solver.NoSolution -> Task.throw Exit.DetailsNoSolution
|
||||
Solver.Err exit -> Task.throw $ Exit.DetailsSolverProblem exit
|
||||
|
||||
-- UNION
|
||||
@ -314,9 +316,9 @@ type Dep =
|
||||
Either (Maybe Exit.DetailsBadDep) Artifacts
|
||||
|
||||
verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
|
||||
verifyDep (Env key _ _ cache) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
|
||||
verifyDep (Env key _ _ cache) depsMVar solution pkg details@(Solver.Details vsn _ directDeps) =
|
||||
do
|
||||
let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
|
||||
let fingerprint = Map.intersectionWith (\(Solver.Details v _ _) _ -> v) solution directDeps
|
||||
maybeCache <- File.readBinary (Dirs.package cache pkg vsn </> "artifacts.dat")
|
||||
case maybeCache of
|
||||
Nothing ->
|
||||
@ -339,9 +341,10 @@ type Fingerprint =
|
||||
-- BUILD
|
||||
|
||||
build :: Reporting.DKey -> Dirs.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep
|
||||
build key cache depsMVar pkg (Solver.Details vsn _) f fs =
|
||||
build key cache depsMVar pkg (Solver.Details vsn maybeLocalPath _) f fs =
|
||||
do
|
||||
eitherOutline <- Outline.read (Dirs.package cache pkg vsn)
|
||||
let packageDir = Maybe.fromMaybe (Dirs.package cache pkg vsn) maybeLocalPath
|
||||
eitherOutline <- Outline.read packageDir
|
||||
case eitherOutline of
|
||||
Left _ ->
|
||||
do
|
||||
@ -359,13 +362,13 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
|
||||
Left _ ->
|
||||
do
|
||||
Reporting.report key Reporting.DBroken
|
||||
return $ Left $ Nothing
|
||||
return $ Left Nothing
|
||||
Right directArtifacts ->
|
||||
do
|
||||
let src = Dirs.package cache pkg vsn </> "src"
|
||||
let src = packageDir </> "src"
|
||||
let foreignDeps = gatherForeignInterfaces directArtifacts
|
||||
let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
|
||||
docsStatus <- getDocsStatus cache pkg vsn
|
||||
let exposedDict = Map.fromKeys (const ()) (Outline.flattenExposed exposed)
|
||||
docsStatus <- getDocsStatus packageDir
|
||||
mvar <- newEmptyMVar
|
||||
mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict
|
||||
putMVar mvar mvars
|
||||
@ -388,13 +391,13 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
|
||||
Reporting.report key Reporting.DBroken
|
||||
return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
|
||||
Just results ->
|
||||
let path = Dirs.package cache pkg vsn </> "artifacts.dat"
|
||||
let path = packageDir </> "artifacts.dat"
|
||||
ifaces = gatherInterfaces exposedDict results
|
||||
objects = gatherObjects results
|
||||
artifacts = Artifacts ifaces objects
|
||||
fingerprints = Set.insert f fs
|
||||
in do
|
||||
writeDocs cache pkg vsn docsStatus results
|
||||
writeDocs packageDir docsStatus results
|
||||
File.writeBinary path (ArtifactCache fingerprints artifacts)
|
||||
Reporting.report key Reporting.DBuilt
|
||||
return (Right artifacts)
|
||||
@ -579,10 +582,10 @@ data DocsStatus
|
||||
= DocsNeeded
|
||||
| DocsNotNeeded
|
||||
|
||||
getDocsStatus :: Dirs.PackageCache -> Pkg.Name -> V.Version -> IO DocsStatus
|
||||
getDocsStatus cache pkg vsn =
|
||||
getDocsStatus :: FilePath -> IO DocsStatus
|
||||
getDocsStatus packageDir =
|
||||
do
|
||||
exists <- File.exists (Dirs.package cache pkg vsn </> "docs.json")
|
||||
exists <- File.exists (packageDir </> "docs.json")
|
||||
if exists
|
||||
then return DocsNotNeeded
|
||||
else return DocsNeeded
|
||||
@ -597,11 +600,11 @@ makeDocs status modul =
|
||||
DocsNotNeeded ->
|
||||
Nothing
|
||||
|
||||
writeDocs :: Dirs.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO ()
|
||||
writeDocs cache pkg vsn status results =
|
||||
writeDocs :: FilePath -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO ()
|
||||
writeDocs packageDir status results =
|
||||
case status of
|
||||
DocsNeeded ->
|
||||
E.writeUgly (Dirs.package cache pkg vsn </> "docs.json") $
|
||||
E.writeUgly (packageDir </> "docs.json") $
|
||||
Docs.encode $
|
||||
Map.mapMaybe toDocs results
|
||||
DocsNotNeeded ->
|
||||
|
@ -8,6 +8,7 @@ module Gren.Outline
|
||||
PkgOutline (..),
|
||||
Exposed (..),
|
||||
SrcDir (..),
|
||||
PossibleFilePath (..),
|
||||
read,
|
||||
write,
|
||||
encode,
|
||||
@ -26,6 +27,7 @@ import AbsoluteSrcDir (AbsoluteSrcDir)
|
||||
import AbsoluteSrcDir qualified
|
||||
import Control.Monad (filterM, liftM)
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
@ -36,12 +38,15 @@ import Gren.Licenses qualified as Licenses
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.PossibleFilePath (PossibleFilePath)
|
||||
import Gren.PossibleFilePath qualified as PossibleFilePath
|
||||
import Gren.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode ((==>))
|
||||
import Json.Encode qualified as E
|
||||
import Json.String qualified as Json
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Exit qualified as Exit
|
||||
import System.Directory qualified as Dir
|
||||
import System.FilePath ((</>))
|
||||
@ -58,8 +63,8 @@ data AppOutline = AppOutline
|
||||
{ _app_gren_version :: V.Version,
|
||||
_app_platform :: Platform.Platform,
|
||||
_app_source_dirs :: NE.List SrcDir,
|
||||
_app_deps_direct :: Map.Map Pkg.Name V.Version,
|
||||
_app_deps_indirect :: Map.Map Pkg.Name V.Version
|
||||
_app_deps_direct :: Map.Map Pkg.Name (PossibleFilePath V.Version),
|
||||
_app_deps_indirect :: Map.Map Pkg.Name (PossibleFilePath V.Version)
|
||||
}
|
||||
|
||||
data PkgOutline = PkgOutline
|
||||
@ -68,7 +73,7 @@ data PkgOutline = PkgOutline
|
||||
_pkg_license :: Licenses.License,
|
||||
_pkg_version :: V.Version,
|
||||
_pkg_exposed :: Exposed,
|
||||
_pkg_deps :: Map.Map Pkg.Name Con.Constraint,
|
||||
_pkg_deps :: Map.Map Pkg.Name (PossibleFilePath Con.Constraint),
|
||||
_pkg_gren_version :: Con.Constraint,
|
||||
_pkg_platform :: Platform.Platform
|
||||
}
|
||||
@ -105,14 +110,14 @@ platform outline =
|
||||
Pkg (PkgOutline _ _ _ _ _ _ _ pltform) ->
|
||||
pltform
|
||||
|
||||
dependencyConstraints :: Outline -> Map.Map Pkg.Name Con.Constraint
|
||||
dependencyConstraints :: Outline -> Map.Map Pkg.Name (PossibleFilePath Con.Constraint)
|
||||
dependencyConstraints outline =
|
||||
case outline of
|
||||
App appOutline ->
|
||||
let direct = _app_deps_direct appOutline
|
||||
indirect = _app_deps_indirect appOutline
|
||||
appDeps = Map.union direct indirect
|
||||
in Map.map (\vsn -> Con.exactly vsn) appDeps
|
||||
in Map.map (PossibleFilePath.mapWith Con.exactly) appDeps
|
||||
Pkg pkgOutline ->
|
||||
_pkg_deps pkgOutline
|
||||
|
||||
@ -164,9 +169,9 @@ encodeModule :: ModuleName.Raw -> E.Value
|
||||
encodeModule name =
|
||||
E.name name
|
||||
|
||||
encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
|
||||
encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name (PossibleFilePath a) -> E.Value
|
||||
encodeDeps encodeValue deps =
|
||||
E.dict Pkg.toJsonString encodeValue deps
|
||||
E.dict Pkg.toJsonString (PossibleFilePath.encodeJson encodeValue) deps
|
||||
|
||||
encodeSrcDir :: SrcDir -> E.Value
|
||||
encodeSrcDir srcDir =
|
||||
@ -279,8 +284,8 @@ appDecoder =
|
||||
<$> D.field "gren-version" versionDecoder
|
||||
<*> D.field "platform" (Platform.decoder Exit.OP_BadPlatform)
|
||||
<*> D.field "source-directories" dirsDecoder
|
||||
<*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
|
||||
<*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
|
||||
<*> D.field "dependencies" (D.field "direct" (depsDecoder versionOrFilePathDecoder))
|
||||
<*> D.field "dependencies" (D.field "indirect" (depsDecoder versionOrFilePathDecoder))
|
||||
|
||||
pkgDecoder :: Decoder PkgOutline
|
||||
pkgDecoder =
|
||||
@ -290,7 +295,7 @@ pkgDecoder =
|
||||
<*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
|
||||
<*> D.field "version" versionDecoder
|
||||
<*> D.field "exposed-modules" exposedDecoder
|
||||
<*> D.field "dependencies" (depsDecoder constraintDecoder)
|
||||
<*> D.field "dependencies" (depsDecoder constraintOrFilePathDecoder)
|
||||
<*> D.field "gren-version" constraintDecoder
|
||||
<*> D.field "platform" (Platform.decoder Exit.OP_BadPlatform)
|
||||
|
||||
@ -308,11 +313,43 @@ summaryDecoder =
|
||||
|
||||
versionDecoder :: Decoder V.Version
|
||||
versionDecoder =
|
||||
D.mapError (uncurry Exit.OP_BadVersion) V.decoder
|
||||
D.mapError (Exit.OP_BadVersion . Exit.OP_AttemptedOther) V.decoder
|
||||
|
||||
versionOrFilePathDecoder :: Decoder (PossibleFilePath V.Version)
|
||||
versionOrFilePathDecoder =
|
||||
D.oneOf
|
||||
[ do
|
||||
vsn <- D.mapError (Exit.OP_BadVersion . Exit.OP_AttemptedOther) V.decoder
|
||||
D.succeed (PossibleFilePath.Other vsn),
|
||||
filePathDecoder Exit.OP_BadVersion
|
||||
]
|
||||
|
||||
filePathDecoder :: (Exit.PossibleFilePath err -> Exit.OutlineProblem) -> Decoder (PossibleFilePath val)
|
||||
filePathDecoder errorMapper =
|
||||
do
|
||||
jsonStr <- D.string
|
||||
D.Decoder $ \(A.At errRegion@(A.Region (A.Position row col) _) _) ok err ->
|
||||
let filePath = Json.toChars jsonStr
|
||||
in if List.isPrefixOf localDepPrefix filePath
|
||||
then ok (PossibleFilePath.Is $ List.drop (List.length localDepPrefix) filePath)
|
||||
else err (D.Failure errRegion $ errorMapper $ Exit.OP_AttemptedFilePath (row, col))
|
||||
|
||||
localDepPrefix :: String
|
||||
localDepPrefix =
|
||||
"local:"
|
||||
|
||||
constraintDecoder :: Decoder Con.Constraint
|
||||
constraintDecoder =
|
||||
D.mapError Exit.OP_BadConstraint Con.decoder
|
||||
D.mapError (Exit.OP_BadConstraint . Exit.OP_AttemptedOther) Con.decoder
|
||||
|
||||
constraintOrFilePathDecoder :: Decoder (PossibleFilePath Con.Constraint)
|
||||
constraintOrFilePathDecoder =
|
||||
D.oneOf
|
||||
[ do
|
||||
con <- D.mapError (Exit.OP_BadConstraint . Exit.OP_AttemptedOther) Con.decoder
|
||||
D.succeed (PossibleFilePath.Other con),
|
||||
filePathDecoder Exit.OP_BadConstraint
|
||||
]
|
||||
|
||||
depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
|
||||
depsDecoder valueDecoder =
|
||||
|
42
builder/src/Gren/PossibleFilePath.hs
Normal file
42
builder/src/Gren/PossibleFilePath.hs
Normal file
@ -0,0 +1,42 @@
|
||||
module Gren.PossibleFilePath
|
||||
( PossibleFilePath (..),
|
||||
mapWith,
|
||||
encodeJson,
|
||||
other,
|
||||
toChars,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Json.Encode qualified as E
|
||||
|
||||
data PossibleFilePath a
|
||||
= Is FilePath
|
||||
| Other a
|
||||
deriving (Eq)
|
||||
|
||||
mapWith :: (a -> b) -> PossibleFilePath a -> PossibleFilePath b
|
||||
mapWith fn possibleFP =
|
||||
case possibleFP of
|
||||
Is filePath -> Is filePath
|
||||
Other a -> Other $ fn a
|
||||
|
||||
other :: PossibleFilePath a -> Maybe a
|
||||
other possibleFP =
|
||||
case possibleFP of
|
||||
Is _ -> Nothing
|
||||
Other a -> Just a
|
||||
|
||||
encodeJson :: (a -> E.Value) -> PossibleFilePath a -> E.Value
|
||||
encodeJson encoderForNonFP possibleFP =
|
||||
case possibleFP of
|
||||
Is filePath ->
|
||||
E.string $ Utf8.fromChars $ "local:" ++ filePath
|
||||
Other a ->
|
||||
encoderForNonFP a
|
||||
|
||||
toChars :: (a -> String) -> PossibleFilePath a -> String
|
||||
toChars otherToString pfp =
|
||||
case pfp of
|
||||
Is fp -> fp
|
||||
Other a -> otherToString a
|
@ -28,6 +28,7 @@ module Reporting.Exit
|
||||
Solver (..),
|
||||
Outline (..),
|
||||
OutlineProblem (..),
|
||||
PossibleFilePath (..),
|
||||
Details (..),
|
||||
DetailsBadDep (..),
|
||||
BuildProblem (..),
|
||||
@ -987,6 +988,7 @@ outdatedToReport exit =
|
||||
|
||||
data Solver
|
||||
= SolverBadCacheData Pkg.Name V.Version
|
||||
| SolverBadLocalDep Pkg.Name String
|
||||
| SolverBadGitOperationUnversionedPkg Pkg.Name Git.Error
|
||||
| SolverBadGitOperationVersionedPkg Pkg.Name V.Version Git.Error
|
||||
| SolverIncompatibleSolvedVersion Pkg.Name Pkg.Name C.Constraint V.Version
|
||||
@ -1013,6 +1015,20 @@ toSolverReport problem =
|
||||
\ Hopefully that will get you unstuck, but it will not resolve the root\
|
||||
\ problem if a 3rd party tool is modifing cached files for some reason."
|
||||
]
|
||||
SolverBadLocalDep pkg filePath ->
|
||||
Help.report
|
||||
"PROBLEM SOLVING PACKAGE CONSTRAINTS"
|
||||
Nothing
|
||||
( "I need the gren.json of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " (located at "
|
||||
++ filePath
|
||||
++ ") to help me search for a set of compatible packages. It seems to be a dependency\
|
||||
\ that resides on your disk."
|
||||
)
|
||||
[ D.reflow
|
||||
"Verify that the path is correct, that it is defined as a package and that it compiles."
|
||||
]
|
||||
SolverBadGitOperationUnversionedPkg pkg gitError ->
|
||||
toGitErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" gitError $
|
||||
"I need the gren.json of "
|
||||
@ -1133,8 +1149,8 @@ data Outline
|
||||
data OutlineProblem
|
||||
= OP_BadType
|
||||
| OP_BadPkgName Row Col
|
||||
| OP_BadVersion Row Col
|
||||
| OP_BadConstraint C.Error
|
||||
| OP_BadVersion (PossibleFilePath (Row, Col))
|
||||
| OP_BadConstraint (PossibleFilePath C.Error)
|
||||
| OP_BadModuleName Row Col
|
||||
| OP_BadModuleHeaderTooLong
|
||||
| OP_BadDependencyName Row Col
|
||||
@ -1143,6 +1159,10 @@ data OutlineProblem
|
||||
| OP_NoSrcDirs
|
||||
| OP_BadPlatform
|
||||
|
||||
data PossibleFilePath otherError
|
||||
= OP_AttemptedFilePath (Row, Col)
|
||||
| OP_AttemptedOther otherError
|
||||
|
||||
toOutlineReport :: Outline -> Help.Report
|
||||
toOutlineReport problem =
|
||||
case problem of
|
||||
@ -1302,7 +1322,31 @@ toOutlineProblemReport path source _ region problem =
|
||||
\ to change your GitHub name!"
|
||||
]
|
||||
)
|
||||
OP_BadVersion row col ->
|
||||
OP_BadVersion (OP_AttemptedFilePath (row, col)) ->
|
||||
toSnippet
|
||||
"PROBLEM WITH DEPENDENCY FILE PATH"
|
||||
(toHighlight row col)
|
||||
( D.reflow $
|
||||
"I got stuck while reading your gren.json file. I was expecting a file path here:",
|
||||
D.fillSep
|
||||
[ "I",
|
||||
"need",
|
||||
"something",
|
||||
"like",
|
||||
D.green "\"local:..\"",
|
||||
"or",
|
||||
D.green "\"local:/absolute/path/to/project\"",
|
||||
"that",
|
||||
"explicitly",
|
||||
"states",
|
||||
"where",
|
||||
"to",
|
||||
"find",
|
||||
"the",
|
||||
"dependency."
|
||||
]
|
||||
)
|
||||
OP_BadVersion (OP_AttemptedOther (row, col)) ->
|
||||
toSnippet
|
||||
"PROBLEM WITH VERSION"
|
||||
(toHighlight row col)
|
||||
@ -1324,7 +1368,31 @@ toOutlineProblemReport path source _ region problem =
|
||||
"numbers!"
|
||||
]
|
||||
)
|
||||
OP_BadConstraint constraintError ->
|
||||
OP_BadConstraint (OP_AttemptedFilePath (row, col)) ->
|
||||
toSnippet
|
||||
"PROBLEM WITH DEPENDENCY FILE PATH"
|
||||
(toHighlight row col)
|
||||
( D.reflow $
|
||||
"I got stuck while reading your gren.json file. I was expecting a file path here:",
|
||||
D.fillSep
|
||||
[ "I",
|
||||
"need",
|
||||
"something",
|
||||
"like",
|
||||
D.green "\"local:..\"",
|
||||
"or",
|
||||
D.green "\"local:/absolute/path/to/project\"",
|
||||
"that",
|
||||
"explicitly",
|
||||
"states",
|
||||
"where",
|
||||
"to",
|
||||
"find",
|
||||
"the",
|
||||
"dependency."
|
||||
]
|
||||
)
|
||||
OP_BadConstraint (OP_AttemptedOther constraintError) ->
|
||||
case constraintError of
|
||||
C.BadFormat row col ->
|
||||
toSnippet
|
||||
|
@ -6,7 +6,7 @@
|
||||
|
||||
module Json.Decode
|
||||
( fromByteString,
|
||||
Decoder,
|
||||
Decoder (..),
|
||||
string,
|
||||
customString,
|
||||
bool,
|
||||
|
@ -91,6 +91,7 @@ Common gren-common
|
||||
Gren.Outline
|
||||
Gren.Platform
|
||||
Gren.Details
|
||||
Gren.PossibleFilePath
|
||||
--
|
||||
Gren.Compiler.Imports
|
||||
Gren.Compiler.Type
|
||||
|
@ -16,8 +16,9 @@ import Gren.Licenses qualified as Licenses
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.PossibleFilePath (PossibleFilePath)
|
||||
import Gren.PossibleFilePath qualified as PossibleFilePath
|
||||
import Gren.Version qualified as V
|
||||
import Json.String qualified as Json
|
||||
import Reporting qualified
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Exit qualified as Exit
|
||||
@ -83,7 +84,8 @@ init flags =
|
||||
return $ Left $ Exit.InitNoCompatibleDependencies Nothing
|
||||
Left (DPkg.GitError gitError) ->
|
||||
return $ Left $ Exit.InitNoCompatibleDependencies $ Just gitError
|
||||
Right deps -> do
|
||||
Right resolvedDeps -> do
|
||||
let deps = Map.map PossibleFilePath.Other resolvedDeps
|
||||
result <- Solver.verify Reporting.ignorer cache platform deps
|
||||
case result of
|
||||
Solver.Err exit ->
|
||||
@ -101,12 +103,12 @@ init flags =
|
||||
putStrLn "Okay, I created it."
|
||||
return (Right ())
|
||||
|
||||
pkgOutline :: Platform.Platform -> Map.Map Pkg.Name Con.Constraint -> Outline.Outline
|
||||
pkgOutline :: Platform.Platform -> Map.Map Pkg.Name (PossibleFilePath Con.Constraint) -> Outline.Outline
|
||||
pkgOutline platform deps =
|
||||
Outline.Pkg $
|
||||
Outline.PkgOutline
|
||||
Pkg.dummyName
|
||||
(Json.fromChars "")
|
||||
Outline.defaultSummary
|
||||
Licenses.bsd3
|
||||
V.one
|
||||
(Outline.ExposedList [])
|
||||
@ -117,10 +119,10 @@ pkgOutline platform deps =
|
||||
appOutlineFromSolverDetails ::
|
||||
Platform.Platform ->
|
||||
[Pkg.Name] ->
|
||||
(Map.Map Pkg.Name Solver.Details) ->
|
||||
Map.Map Pkg.Name Solver.Details ->
|
||||
Outline.Outline
|
||||
appOutlineFromSolverDetails platform initialDeps details =
|
||||
let solution = Map.map (\(Solver.Details vsn _) -> vsn) details
|
||||
let solution = Map.map (\(Solver.Details vsn _ _) -> vsn) details
|
||||
defaultDeps = Map.fromList $ map (\dep -> (dep, Con.exactly V.one)) initialDeps
|
||||
directs = Map.intersection solution defaultDeps
|
||||
indirects = Map.difference solution defaultDeps
|
||||
@ -129,8 +131,8 @@ appOutlineFromSolverDetails platform initialDeps details =
|
||||
V.compiler
|
||||
platform
|
||||
(NE.List (Outline.RelativeSrcDir "src") [])
|
||||
directs
|
||||
indirects
|
||||
(Map.map PossibleFilePath.Other directs)
|
||||
(Map.map PossibleFilePath.Other indirects)
|
||||
|
||||
selectPlatform :: Flags -> Platform.Platform
|
||||
selectPlatform flags =
|
||||
|
@ -18,6 +18,8 @@ import Gren.Constraint qualified as C
|
||||
import Gren.Details qualified as Details
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.PossibleFilePath (PossibleFilePath)
|
||||
import Gren.PossibleFilePath qualified as PossibleFilePath
|
||||
import Gren.Version qualified as V
|
||||
import Reporting qualified
|
||||
import Reporting.Doc ((<+>))
|
||||
@ -55,11 +57,11 @@ run args (Flags _skipPrompts) =
|
||||
Outline.App outline ->
|
||||
do
|
||||
changes <- makeAppPlan env pkg outline
|
||||
attemptChanges root env _skipPrompts oldOutline V.toChars changes
|
||||
attemptChanges root env _skipPrompts oldOutline (PossibleFilePath.toChars V.toChars) changes
|
||||
Outline.Pkg outline ->
|
||||
do
|
||||
changes <- makePkgPlan env pkg outline
|
||||
attemptChanges root env _skipPrompts oldOutline C.toChars changes
|
||||
attemptChanges root env _skipPrompts oldOutline (PossibleFilePath.toChars C.toChars) changes
|
||||
|
||||
-- ATTEMPT CHANGES
|
||||
|
||||
@ -160,7 +162,7 @@ installDependencies path =
|
||||
|
||||
-- MAKE APP PLAN
|
||||
|
||||
makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version)
|
||||
makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes (PossibleFilePath V.Version))
|
||||
makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ _ _ direct indirect) =
|
||||
if Map.member pkg direct
|
||||
then return AlreadyInstalled
|
||||
@ -197,7 +199,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 -> Pkg.Name -> Outline.PkgOutline -> Task (Changes (PossibleFilePath C.Constraint))
|
||||
makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _ rootPlatform) =
|
||||
if Map.member pkg deps
|
||||
then return AlreadyInstalled
|
||||
@ -215,14 +217,14 @@ makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _
|
||||
Exit.SolverBadGitOperationUnversionedPkg pkg gitError
|
||||
Right compatibleVersion -> do
|
||||
let old = deps
|
||||
let cons = Map.insert pkg (C.untilNextMajor compatibleVersion) old
|
||||
let cons = Map.insert pkg (PossibleFilePath.Other (C.untilNextMajor compatibleVersion)) old
|
||||
result <- Task.io $ Solver.verify Reporting.ignorer cache rootPlatform cons
|
||||
case result of
|
||||
Solver.Ok solution ->
|
||||
let (Solver.Details vsn _) = solution ! pkg
|
||||
let (Solver.Details vsn _ _) = solution ! pkg
|
||||
|
||||
con = C.untilNextMajor vsn
|
||||
new = Map.insert pkg con old
|
||||
new = Map.insert pkg (PossibleFilePath.Other con) old
|
||||
changes = detectChanges old new
|
||||
news = Map.mapMaybe keepNew changes
|
||||
in return $
|
||||
@ -236,7 +238,7 @@ makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _
|
||||
Solver.Err exit ->
|
||||
Task.throw $ Exit.InstallHadSolverTrouble exit
|
||||
|
||||
addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint
|
||||
addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name (PossibleFilePath C.Constraint) -> Map.Map Pkg.Name (PossibleFilePath C.Constraint) -> Map.Map Pkg.Name (PossibleFilePath C.Constraint)
|
||||
addNews pkg new old =
|
||||
Map.merge
|
||||
Map.preserveMissing
|
||||
|
@ -13,6 +13,8 @@ import Directories qualified as Dirs
|
||||
import Gren.Constraint qualified as C
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.PossibleFilePath (PossibleFilePath)
|
||||
import Gren.PossibleFilePath qualified as PossibleFilePath
|
||||
import Gren.Version qualified as V
|
||||
import Reporting qualified
|
||||
import Reporting.Exit qualified as Exit
|
||||
@ -56,15 +58,16 @@ listOutdatedAppDeps appOutline =
|
||||
(Outline._app_deps_direct appOutline)
|
||||
(Outline._app_deps_indirect appOutline)
|
||||
|
||||
asConstraints = Map.map C.exactly deps
|
||||
asConstraints = Map.map (PossibleFilePath.mapWith C.exactly) deps
|
||||
in listOutdatedDeps asConstraints
|
||||
|
||||
listOutdatedPkgDeps :: Outline.PkgOutline -> Task ()
|
||||
listOutdatedPkgDeps pkgOutline =
|
||||
listOutdatedDeps $ Outline._pkg_deps pkgOutline
|
||||
|
||||
listOutdatedDeps :: Map.Map Pkg.Name C.Constraint -> Task ()
|
||||
listOutdatedDeps cons = do
|
||||
listOutdatedDeps :: Map.Map Pkg.Name (PossibleFilePath C.Constraint) -> Task ()
|
||||
listOutdatedDeps filePathsOrConstraints = do
|
||||
let cons = Map.mapMaybe PossibleFilePath.other filePathsOrConstraints
|
||||
allHigherVersions <- Map.traverseWithKey higherVersions cons
|
||||
let interestingVersions = Map.mapMaybe toDisplayStrings allHigherVersions
|
||||
let report = finalizeReport $ Map.foldrWithKey buildReport [] interestingVersions
|
||||
|
@ -15,6 +15,8 @@ import Gren.Constraint qualified as C
|
||||
import Gren.Details qualified as Details
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.PossibleFilePath (PossibleFilePath)
|
||||
import Gren.PossibleFilePath qualified as PossibleFilePath
|
||||
import Gren.Version qualified as V
|
||||
import Reporting qualified
|
||||
import Reporting.Doc ((<+>))
|
||||
@ -50,11 +52,11 @@ run args (Flags _skipPrompts) =
|
||||
Outline.App outline ->
|
||||
do
|
||||
changes <- makeAppPlan env pkg outline
|
||||
attemptChanges root env _skipPrompts oldOutline V.toChars changes
|
||||
attemptChanges root env _skipPrompts oldOutline (PossibleFilePath.toChars V.toChars) changes
|
||||
Outline.Pkg outline ->
|
||||
do
|
||||
changes <- makePkgPlan env pkg outline
|
||||
attemptChanges root env _skipPrompts oldOutline C.toChars changes
|
||||
attemptChanges root env _skipPrompts oldOutline (PossibleFilePath.toChars C.toChars) changes
|
||||
|
||||
-- ATTEMPT CHANGES
|
||||
|
||||
@ -110,9 +112,9 @@ attemptChanges root env skipPrompt oldOutline toChars changes =
|
||||
]
|
||||
Changes changeDict newOutline ->
|
||||
let widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict
|
||||
changeDocs = Map.foldrWithKey (addChange toChars widths) ([]) changeDict
|
||||
changeDocs = Map.foldrWithKey (addChange toChars widths) [] changeDict
|
||||
in attemptChangesHelp root env skipPrompt oldOutline newOutline $
|
||||
D.vcat $
|
||||
D.vcat
|
||||
[ "Here is my plan:",
|
||||
viewChangeDocs changeDocs,
|
||||
"",
|
||||
@ -147,7 +149,7 @@ attemptChangesHelp root env skipPrompt oldOutline newOutline question =
|
||||
|
||||
-- MAKE APP PLAN
|
||||
|
||||
makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version)
|
||||
makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes (PossibleFilePath V.Version))
|
||||
makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ rootPlatform _ direct indirect) =
|
||||
case Map.lookup pkg direct of
|
||||
Just vsn -> do
|
||||
@ -157,7 +159,7 @@ makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ rootPlatform _
|
||||
case result of
|
||||
Solver.Ok solution ->
|
||||
let old = Map.union direct indirect
|
||||
new = Map.map (\(Solver.Details v _) -> v) solution
|
||||
new = Map.map (\(Solver.Details v _ _) -> PossibleFilePath.Other v) solution
|
||||
in if Map.member pkg new
|
||||
then
|
||||
return $
|
||||
@ -176,7 +178,7 @@ makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ rootPlatform _
|
||||
Outline._app_deps_indirect = Map.intersection indirect new
|
||||
}
|
||||
Solver.NoSolution ->
|
||||
Task.throw $ Exit.UninstallNoSolverSolution
|
||||
Task.throw Exit.UninstallNoSolverSolution
|
||||
Solver.Err exit ->
|
||||
Task.throw $ Exit.UninstallHadSolverTrouble exit
|
||||
Nothing ->
|
||||
@ -188,7 +190,7 @@ makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ rootPlatform _
|
||||
case result of
|
||||
Solver.Ok solution ->
|
||||
let old = Map.union direct indirect
|
||||
new = Map.map (\(Solver.Details v _) -> v) solution
|
||||
new = Map.map (\(Solver.Details v _ _) -> PossibleFilePath.Other v) solution
|
||||
in if Map.member pkg new
|
||||
then return $ PackageIsRequired (packagesDependingOn pkg solution)
|
||||
else
|
||||
@ -200,20 +202,20 @@ makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ rootPlatform _
|
||||
Outline._app_deps_indirect = Map.intersection indirect new
|
||||
}
|
||||
Solver.NoSolution ->
|
||||
Task.throw $ Exit.UninstallNoSolverSolution
|
||||
Task.throw Exit.UninstallNoSolverSolution
|
||||
Solver.Err exit ->
|
||||
Task.throw $ Exit.UninstallHadSolverTrouble exit
|
||||
Nothing ->
|
||||
return NoSuchPackage
|
||||
|
||||
toConstraints :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint
|
||||
toConstraints :: Map.Map Pkg.Name (PossibleFilePath V.Version) -> Map.Map Pkg.Name (PossibleFilePath V.Version) -> Map.Map Pkg.Name (PossibleFilePath C.Constraint)
|
||||
toConstraints direct indirect =
|
||||
Map.map C.exactly $ Map.union direct indirect
|
||||
Map.map (PossibleFilePath.mapWith C.exactly) $ Map.union direct indirect
|
||||
|
||||
packagesDependingOn :: Pkg.Name -> Map.Map Pkg.Name Solver.Details -> [Pkg.Name]
|
||||
packagesDependingOn targetPkg solution =
|
||||
Map.foldrWithKey
|
||||
( \pkg (Solver.Details _ deps) acc ->
|
||||
( \pkg (Solver.Details _ _ deps) acc ->
|
||||
if Map.member targetPkg deps
|
||||
then pkg : acc
|
||||
else acc
|
||||
@ -223,7 +225,7 @@ packagesDependingOn targetPkg solution =
|
||||
|
||||
-- MAKE PACKAGE PLAN
|
||||
|
||||
makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint)
|
||||
makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes (PossibleFilePath C.Constraint))
|
||||
makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _ rootPlatform) =
|
||||
if not $ Map.member pkg deps
|
||||
then return NoSuchPackage
|
||||
@ -240,7 +242,7 @@ makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _
|
||||
{ Outline._pkg_deps = withMissingPkg
|
||||
}
|
||||
Solver.NoSolution ->
|
||||
Task.throw $ Exit.UninstallNoSolverSolution
|
||||
Task.throw Exit.UninstallNoSolverSolution
|
||||
Solver.Err exit ->
|
||||
Task.throw $ Exit.UninstallHadSolverTrouble exit
|
||||
|
||||
|
@ -44,6 +44,7 @@ import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.PossibleFilePath as PossibleFilePath
|
||||
import Gren.Version qualified as V
|
||||
import Parse.Declaration qualified as PD
|
||||
import Parse.Expression qualified as PE
|
||||
@ -535,7 +536,7 @@ getRoot =
|
||||
Licenses.bsd3
|
||||
V.one
|
||||
(Outline.ExposedList [])
|
||||
compatibleDeps
|
||||
(Map.map PossibleFilePath.Other compatibleDeps)
|
||||
C.defaultGren
|
||||
Platform.Common
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user