mirror of
https://github.com/gren-lang/compiler.git
synced 2024-09-11 08:45:42 +03:00
Merge pull request #110 from gren-lang/platforms
Add platform support to package manager
This commit is contained in:
commit
b01c1ed9b5
@ -297,7 +297,7 @@ getDocs cache pkg vsn =
|
||||
|
||||
outline <- Task.eio (const Exit.DP_Cache) $ Outline.read home
|
||||
case outline of
|
||||
(Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed _ _)) ->
|
||||
(Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed _ _ _)) ->
|
||||
case Outline.flattenExposed exposed of
|
||||
[] ->
|
||||
Task.throw Exit.DP_Cache
|
||||
|
@ -25,6 +25,7 @@ import File qualified
|
||||
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.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Reporting.Exit qualified as Exit
|
||||
@ -49,6 +50,7 @@ data State = State
|
||||
|
||||
data Constraints = Constraints
|
||||
{ _gren :: C.Constraint,
|
||||
_platform :: Platform.Platform,
|
||||
_deps :: Map.Map Pkg.Name C.Constraint
|
||||
}
|
||||
|
||||
@ -65,10 +67,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 ->
|
||||
Platform.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)
|
||||
@ -79,7 +85,7 @@ verify cache constraints =
|
||||
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
|
||||
Just (Constraints _ _ deps) -> Details vsn deps
|
||||
Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
|
||||
|
||||
-- ADD TO APP - used in Install
|
||||
@ -90,13 +96,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,
|
||||
@ -111,10 +124,10 @@ addToApp cache pkg compatibleVsn outline@(Outline.AppOutline _ _ direct indirect
|
||||
(\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 _ constraints) pkg (Outline.AppOutline gren srcDirs direct _) old new =
|
||||
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 srcDirs d i)
|
||||
in AppSolution old new (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
|
||||
getTransitive constraints solution unvisited visited =
|
||||
@ -133,37 +146,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 :: Platform.Platform -> Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
|
||||
try rootPlatform constraints =
|
||||
exploreGoals (Goals rootPlatform constraints Map.empty)
|
||||
|
||||
-- EXPLORE GOALS
|
||||
|
||||
data Goals = Goals
|
||||
{ _pending :: Map.Map Pkg.Name C.Constraint,
|
||||
{ _root_platform :: Platform.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 rootPlatform pending solved) =
|
||||
case Map.minViewWithKey pending of
|
||||
Nothing ->
|
||||
return solved
|
||||
Just ((name, constraint), otherPending) ->
|
||||
do
|
||||
let goals1 = Goals otherPending solved
|
||||
let goals1 = Goals rootPlatform 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 rootPlatform pending solved) name version =
|
||||
do
|
||||
(Constraints gren deps) <- getConstraints name version
|
||||
if C.goodGren gren
|
||||
(Constraints gren platform deps) <- getConstraints name version
|
||||
if C.goodGren gren && Platform.compatible rootPlatform platform
|
||||
then do
|
||||
newPending <- foldM (addConstraint solved) pending (Map.toList deps)
|
||||
return (Goals newPending (Map.insert name version solved))
|
||||
return (Goals rootPlatform 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)
|
||||
@ -222,8 +236,8 @@ constraintsDecoder =
|
||||
do
|
||||
outline <- D.mapError (const ()) Outline.decoder
|
||||
case outline of
|
||||
Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps grenConstraint) ->
|
||||
return (Constraints grenConstraint deps)
|
||||
Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps grenConstraint platform) ->
|
||||
return (Constraints grenConstraint platform deps)
|
||||
Outline.App _ ->
|
||||
D.failure ()
|
||||
|
||||
|
@ -43,6 +43,7 @@ import Gren.Kernel qualified as Kernel
|
||||
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.Version qualified as V
|
||||
import Json.Encode qualified as E
|
||||
import Parse.Module qualified as Parse
|
||||
@ -184,35 +185,39 @@ 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
|
||||
verifyDependencies env time (ValidPkg pkg exposedList) 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
|
||||
else Task.throw $ Exit.DetailsBadGrenInAppOutline grenVersion
|
||||
|
||||
checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
|
||||
checkAppDeps (Outline.AppOutline _ _ direct indirect) =
|
||||
checkAppDeps (Outline.AppOutline _ _ _ direct indirect) =
|
||||
union noDups 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 ->
|
||||
Platform.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
|
||||
@ -341,7 +346,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
|
||||
do
|
||||
Reporting.report key Reporting.DBroken
|
||||
return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
|
||||
Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _)) ->
|
||||
Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
|
||||
do
|
||||
allDeps <- readMVar depsMVar
|
||||
directDeps <- traverse readMVar (Map.intersection allDeps deps)
|
||||
|
@ -33,6 +33,7 @@ import Gren.Constraint qualified as Con
|
||||
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.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode ((==>))
|
||||
@ -53,6 +54,7 @@ data Outline
|
||||
|
||||
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
|
||||
@ -65,7 +67,8 @@ data PkgOutline = PkgOutline
|
||||
_pkg_version :: V.Version,
|
||||
_pkg_exposed :: Exposed,
|
||||
_pkg_deps :: Map.Map Pkg.Name Con.Constraint,
|
||||
_pkg_gren_version :: Con.Constraint
|
||||
_pkg_gren_version :: Con.Constraint,
|
||||
_pkg_platform :: Platform.Platform
|
||||
}
|
||||
|
||||
data Exposed
|
||||
@ -103,9 +106,10 @@ write root outline =
|
||||
encode :: Outline -> E.Value
|
||||
encode outline =
|
||||
case outline of
|
||||
App (AppOutline gren srcDirs depsDirect depsTrans) ->
|
||||
App (AppOutline gren platform srcDirs depsDirect depsTrans) ->
|
||||
E.object
|
||||
[ "type" ==> E.chars "application",
|
||||
"platform" ==> Platform.encode platform,
|
||||
"source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs),
|
||||
"gren-version" ==> V.encode gren,
|
||||
"dependencies"
|
||||
@ -114,9 +118,10 @@ encode outline =
|
||||
"indirect" ==> encodeDeps V.encode depsTrans
|
||||
]
|
||||
]
|
||||
Pkg (PkgOutline name summary license version exposed deps gren) ->
|
||||
Pkg (PkgOutline name summary license version exposed deps gren platform) ->
|
||||
E.object
|
||||
[ "type" ==> E.string (Json.fromChars "package"),
|
||||
"platform" ==> Platform.encode platform,
|
||||
"name" ==> Pkg.encode name,
|
||||
"summary" ==> E.string summary,
|
||||
"license" ==> Licenses.encode license,
|
||||
@ -159,12 +164,12 @@ read root =
|
||||
return $ Left (Exit.OutlineHasBadStructure err)
|
||||
Right outline ->
|
||||
case outline of
|
||||
Pkg (PkgOutline pkg _ _ _ _ deps _) ->
|
||||
Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
|
||||
return $
|
||||
if Map.notMember Pkg.core deps && pkg /= Pkg.core
|
||||
then Left Exit.OutlineNoPkgCore
|
||||
else Right outline
|
||||
App (AppOutline _ srcDirs direct _)
|
||||
App (AppOutline _ _ srcDirs direct _)
|
||||
| Map.notMember Pkg.core direct ->
|
||||
return $ Left Exit.OutlineNoAppCore
|
||||
| otherwise ->
|
||||
@ -226,7 +231,7 @@ isDup paths =
|
||||
sourceDirs :: Outline -> NE.List SrcDir
|
||||
sourceDirs outline =
|
||||
case outline of
|
||||
App (AppOutline _ srcDirs _ _) ->
|
||||
App (AppOutline _ _ srcDirs _ _) ->
|
||||
srcDirs
|
||||
Pkg _ ->
|
||||
NE.singleton (RelativeSrcDir "src")
|
||||
@ -255,6 +260,7 @@ appDecoder :: Decoder AppOutline
|
||||
appDecoder =
|
||||
AppOutline
|
||||
<$> D.field "gren-version" versionDecoder
|
||||
<*> D.field "platform" Platform.decoder
|
||||
<*> D.field "source-directories" dirsDecoder
|
||||
<*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
|
||||
<*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
|
||||
@ -269,6 +275,7 @@ pkgDecoder =
|
||||
<*> D.field "exposed-modules" exposedDecoder
|
||||
<*> D.field "dependencies" (depsDecoder constraintDecoder)
|
||||
<*> D.field "gren-version" constraintDecoder
|
||||
<*> D.field "platform" Platform.decoder
|
||||
|
||||
-- JSON DECODE HELPERS
|
||||
|
||||
|
52
builder/src/Gren/Platform.hs
Normal file
52
builder/src/Gren/Platform.hs
Normal file
@ -0,0 +1,52 @@
|
||||
module Gren.Platform
|
||||
( Platform (..),
|
||||
--
|
||||
compatible,
|
||||
--
|
||||
encode,
|
||||
decoder,
|
||||
fromString,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode qualified as E
|
||||
import Reporting.Exit qualified as Exit
|
||||
|
||||
data Platform
|
||||
= Common
|
||||
| Browser
|
||||
| Node
|
||||
deriving (Eq)
|
||||
|
||||
-- COMPATIBILITY
|
||||
|
||||
compatible :: Platform -> Platform -> Bool
|
||||
compatible rootPlatform comparison =
|
||||
rootPlatform == comparison || comparison == Common
|
||||
|
||||
-- JSON
|
||||
|
||||
encode :: Platform -> E.Value
|
||||
encode platform =
|
||||
case platform of
|
||||
Common -> E.chars "common"
|
||||
Browser -> E.chars "browser"
|
||||
Node -> E.chars "node"
|
||||
|
||||
decoder :: D.Decoder Exit.OutlineProblem Platform
|
||||
decoder =
|
||||
do
|
||||
platformStr <- D.string
|
||||
case fromString $ Utf8.toChars platformStr of
|
||||
Just platform -> D.succeed platform
|
||||
Nothing -> D.failure Exit.OP_BadPlatform
|
||||
|
||||
fromString :: String -> Maybe Platform
|
||||
fromString value =
|
||||
case value of
|
||||
"common" -> Just Common
|
||||
"browser" -> Just Browser
|
||||
"node" -> Just Node
|
||||
_ -> Nothing
|
@ -1177,6 +1177,7 @@ data OutlineProblem
|
||||
| OP_BadLicense Json.String [Json.String]
|
||||
| OP_BadSummaryTooLong
|
||||
| OP_NoSrcDirs
|
||||
| OP_BadPlatform
|
||||
|
||||
toOutlineReport :: Outline -> Help.Report
|
||||
toOutlineReport problem =
|
||||
@ -1687,6 +1688,26 @@ toOutlineProblemReport path source _ region problem =
|
||||
"modules!"
|
||||
]
|
||||
)
|
||||
OP_BadPlatform ->
|
||||
toSnippet
|
||||
"UNKNOWN PLATFORM"
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"I got stuck while reading your gren.json file. I don't recognize the \"platform\" value.",
|
||||
D.fillSep
|
||||
[ "It",
|
||||
"must",
|
||||
"be",
|
||||
"one",
|
||||
"of",
|
||||
D.green "\"common\"",
|
||||
",",
|
||||
D.green "\"browser\"",
|
||||
"or",
|
||||
D.green "\"node\"",
|
||||
"."
|
||||
]
|
||||
)
|
||||
|
||||
-- DETAILS
|
||||
|
||||
|
@ -19,6 +19,7 @@ module Gren.Package
|
||||
kernel,
|
||||
core,
|
||||
browser,
|
||||
node,
|
||||
url,
|
||||
--
|
||||
suggestions,
|
||||
@ -116,6 +117,10 @@ browser :: Name
|
||||
browser =
|
||||
toName gren "browser"
|
||||
|
||||
node :: Name
|
||||
node =
|
||||
toName gren "node"
|
||||
|
||||
url :: Name
|
||||
url =
|
||||
toName gren "url"
|
||||
|
@ -20,6 +20,7 @@ module Json.Decode
|
||||
pairs,
|
||||
field,
|
||||
--
|
||||
succeed,
|
||||
oneOf,
|
||||
failure,
|
||||
mapError,
|
||||
@ -279,6 +280,13 @@ findField key pairs =
|
||||
then Just value
|
||||
else findField key remainingPairs
|
||||
|
||||
-- SUCCEED
|
||||
|
||||
succeed :: a -> Decoder x a
|
||||
succeed value =
|
||||
Decoder $ \_ ok _ ->
|
||||
ok value
|
||||
|
||||
-- ONE OF
|
||||
|
||||
oneOf :: [Decoder x a] -> Decoder x a
|
||||
|
@ -85,6 +85,7 @@ Common gren-common
|
||||
|
||||
-- Gren things
|
||||
Gren.Outline
|
||||
Gren.Platform
|
||||
Gren.Details
|
||||
--
|
||||
Gren.Compiler.Imports
|
||||
|
@ -59,7 +59,7 @@ getEnv =
|
||||
-- BUMP
|
||||
|
||||
bump :: Env -> Task.Task Exit.Bump ()
|
||||
bump env@(Env root _ outline@(Outline.PkgOutline pkg _ _ vsn _ _ _)) =
|
||||
bump env@(Env root _ outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
|
||||
Task.eio id $
|
||||
do
|
||||
versionResult <- Package.getVersions pkg
|
||||
@ -82,7 +82,7 @@ bump env@(Env root _ outline@(Outline.PkgOutline pkg _ _ vsn _ _ _)) =
|
||||
-- CHECK NEW PACKAGE
|
||||
|
||||
checkNewPackage :: FilePath -> Outline.PkgOutline -> IO ()
|
||||
checkNewPackage root outline@(Outline.PkgOutline _ _ _ version _ _ _) =
|
||||
checkNewPackage root outline@(Outline.PkgOutline _ _ _ version _ _ _ _) =
|
||||
do
|
||||
putStrLn Exit.newPackageOverview
|
||||
if version == V.one
|
||||
@ -97,7 +97,7 @@ checkNewPackage root outline@(Outline.PkgOutline _ _ _ version _ _ _) =
|
||||
-- SUGGEST VERSION
|
||||
|
||||
suggestVersion :: Env -> Task.Task Exit.Bump ()
|
||||
suggestVersion (Env root cache outline@(Outline.PkgOutline pkg _ _ vsn _ _ _)) =
|
||||
suggestVersion (Env root cache outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
|
||||
do
|
||||
oldDocs <-
|
||||
Task.mapError
|
||||
@ -128,7 +128,7 @@ suggestVersion (Env root cache outline@(Outline.PkgOutline pkg _ _ vsn _ _ _)) =
|
||||
<> ") in gren.json? [Y/n] "
|
||||
|
||||
generateDocs :: FilePath -> Outline.PkgOutline -> Task.Task Exit.Bump Docs.Documentation
|
||||
generateDocs root (Outline.PkgOutline _ _ _ _ exposed _ _) =
|
||||
generateDocs root (Outline.PkgOutline _ _ _ _ exposed _ _ _) =
|
||||
do
|
||||
details <-
|
||||
Task.eio Exit.BumpBadDetails $
|
||||
|
@ -130,7 +130,7 @@ readOutline (Env maybeRoot _) =
|
||||
case outline of
|
||||
Outline.App _ ->
|
||||
Task.throw Exit.DiffApplication
|
||||
Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _) ->
|
||||
Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) ->
|
||||
do
|
||||
versionResult <- Task.io $ Package.getVersions pkg
|
||||
case versionResult of
|
||||
|
@ -15,6 +15,7 @@ import Gren.Constraint qualified as Con
|
||||
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.Version qualified as V
|
||||
import Json.String qualified as Json
|
||||
import Reporting qualified
|
||||
@ -24,7 +25,8 @@ import System.Directory qualified as Dir
|
||||
import Prelude hiding (init)
|
||||
|
||||
data Flags = Flags
|
||||
{ _isPackage :: Bool
|
||||
{ _isPackage :: Bool,
|
||||
_platform :: Maybe Platform.Platform
|
||||
}
|
||||
|
||||
-- RUN
|
||||
@ -70,10 +72,8 @@ question =
|
||||
init :: Flags -> IO (Either Exit.Init ())
|
||||
init flags =
|
||||
do
|
||||
let initialDeps =
|
||||
if _isPackage flags
|
||||
then pkgDefaultDeps
|
||||
else appDefaultDeps
|
||||
let platform = selectPlatform flags
|
||||
let initialDeps = suggestDependencies platform
|
||||
(Solver.Env cache) <- Solver.initEnv
|
||||
potentialDeps <-
|
||||
Dirs.withRegistryLock cache $
|
||||
@ -84,7 +84,7 @@ init flags =
|
||||
Left (DPkg.GitError gitError) ->
|
||||
return $ Left $ Exit.InitNoCompatibleDependencies $ Just gitError
|
||||
Right deps -> do
|
||||
result <- Solver.verify cache deps
|
||||
result <- Solver.verify cache platform deps
|
||||
case result of
|
||||
Solver.Err exit ->
|
||||
return (Left (Exit.InitSolverProblem exit))
|
||||
@ -95,16 +95,16 @@ init flags =
|
||||
Solver.Ok details ->
|
||||
let outline =
|
||||
if _isPackage flags
|
||||
then pkgOutline deps
|
||||
else appOutlineFromSolverDetails details
|
||||
then pkgOutline platform deps
|
||||
else appOutlineFromSolverDetails platform initialDeps details
|
||||
in do
|
||||
Dir.createDirectoryIfMissing True "src"
|
||||
Outline.write "." outline
|
||||
putStrLn "Okay, I created it."
|
||||
return (Right ())
|
||||
|
||||
pkgOutline :: Map.Map Pkg.Name Con.Constraint -> Outline.Outline
|
||||
pkgOutline deps =
|
||||
pkgOutline :: Platform.Platform -> Map.Map Pkg.Name Con.Constraint -> Outline.Outline
|
||||
pkgOutline platform deps =
|
||||
Outline.Pkg $
|
||||
Outline.PkgOutline
|
||||
Pkg.dummyName
|
||||
@ -114,27 +114,36 @@ pkgOutline deps =
|
||||
(Outline.ExposedList [])
|
||||
deps
|
||||
Con.defaultGren
|
||||
platform
|
||||
|
||||
appOutlineFromSolverDetails :: (Map.Map Pkg.Name Solver.Details) -> Outline.Outline
|
||||
appOutlineFromSolverDetails details =
|
||||
appOutlineFromSolverDetails ::
|
||||
Platform.Platform ->
|
||||
[Pkg.Name] ->
|
||||
(Map.Map Pkg.Name Solver.Details) ->
|
||||
Outline.Outline
|
||||
appOutlineFromSolverDetails platform initialDeps details =
|
||||
let solution = Map.map (\(Solver.Details vsn _) -> vsn) details
|
||||
defaultDeps = Map.fromList $ map (\dep -> (dep, Con.exactly V.one)) appDefaultDeps
|
||||
defaultDeps = Map.fromList $ map (\dep -> (dep, Con.exactly V.one)) initialDeps
|
||||
directs = Map.intersection solution defaultDeps
|
||||
indirects = Map.difference solution defaultDeps
|
||||
in Outline.App $
|
||||
Outline.AppOutline
|
||||
V.compiler
|
||||
platform
|
||||
(NE.List (Outline.RelativeSrcDir "src") [])
|
||||
directs
|
||||
indirects
|
||||
|
||||
appDefaultDeps :: [Pkg.Name]
|
||||
appDefaultDeps =
|
||||
[ Pkg.core,
|
||||
Pkg.browser
|
||||
]
|
||||
selectPlatform :: Flags -> Platform.Platform
|
||||
selectPlatform flags =
|
||||
case (_isPackage flags, _platform flags) of
|
||||
(True, Nothing) -> Platform.Common
|
||||
(False, Nothing) -> Platform.Browser
|
||||
(_, Just platform) -> platform
|
||||
|
||||
pkgDefaultDeps :: [Pkg.Name]
|
||||
pkgDefaultDeps =
|
||||
[ Pkg.core
|
||||
]
|
||||
suggestDependencies :: Platform.Platform -> [Pkg.Name]
|
||||
suggestDependencies platform =
|
||||
case platform of
|
||||
Platform.Common -> [Pkg.core]
|
||||
Platform.Browser -> [Pkg.core, Pkg.browser]
|
||||
Platform.Node -> [Pkg.core, Pkg.node]
|
||||
|
@ -174,7 +174,7 @@ attemptChangesHelp root env oldOutline newOutline question =
|
||||
-- MAKE APP PLAN
|
||||
|
||||
makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version)
|
||||
makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ _ direct indirect) =
|
||||
makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ _ _ direct indirect) =
|
||||
if Map.member pkg direct
|
||||
then return AlreadyInstalled
|
||||
else case Map.lookup pkg indirect of
|
||||
@ -213,7 +213,7 @@ makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ _ direct indire
|
||||
-- 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
|
||||
|
@ -9,6 +9,7 @@ import Bump qualified
|
||||
import Data.List qualified as List
|
||||
import Diff qualified
|
||||
-- import qualified Format
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.Version qualified as V
|
||||
import Init qualified
|
||||
import Install qualified
|
||||
@ -84,9 +85,20 @@ init =
|
||||
|
||||
initFlags =
|
||||
flags Init.Flags
|
||||
|-- onOff "package" "Create a package specific gren.json file."
|
||||
|-- onOff "package" "Create a package (as opposed to an application)."
|
||||
|-- flag "platform" initPlatformParser "Which platform to target"
|
||||
in Terminal.Command "init" (Common summary) details example noArgs initFlags Init.run
|
||||
|
||||
initPlatformParser :: Parser Platform.Platform
|
||||
initPlatformParser =
|
||||
Parser
|
||||
{ _singular = "platform",
|
||||
_plural = "platforms",
|
||||
_parser = Platform.fromString,
|
||||
_suggest = \_ -> return ["common", "browser", "node"],
|
||||
_examples = \_ -> return ["common", "browser", "node"]
|
||||
}
|
||||
|
||||
-- REPL
|
||||
|
||||
repl :: Terminal.Command
|
||||
|
@ -64,7 +64,7 @@ publish env@(Env root _ outline) =
|
||||
case outline of
|
||||
Outline.App _ ->
|
||||
Task.throw Exit.PublishApplication
|
||||
Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _) ->
|
||||
Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) ->
|
||||
do
|
||||
knownVersionsResult <- Task.io $ Package.getVersions pkg
|
||||
let knownVersionsMaybe = Either.either (const Nothing) Just knownVersionsResult
|
||||
|
@ -42,6 +42,7 @@ import Gren.Licenses qualified as Licenses
|
||||
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.Version qualified as V
|
||||
import Parse.Declaration qualified as PD
|
||||
import Parse.Expression qualified as PE
|
||||
@ -523,6 +524,7 @@ getRoot =
|
||||
(Outline.ExposedList [])
|
||||
compatibleDeps
|
||||
C.defaultGren
|
||||
Platform.Browser
|
||||
|
||||
return root
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user