mirror of
https://github.com/gren-lang/compiler.git
synced 2024-08-16 12:00:22 +03:00
Talk directly with remote git repo instead of keeping a bare repo locally.
This commit is contained in:
parent
b8cad6791f
commit
c9c75c2d13
@ -15,19 +15,9 @@ import System.Directory qualified as Dir
|
||||
|
||||
-- GET VERSIONS
|
||||
|
||||
getVersions :: Dirs.PackageCache -> Pkg.Name -> IO (Either Git.Error (V.Version, [V.Version]))
|
||||
getVersions cache name = do
|
||||
let repoPath = Dirs.basePackage cache name
|
||||
repoExists <- Dir.doesDirectoryExist repoPath
|
||||
retVal <-
|
||||
if repoExists
|
||||
then Git.update name repoPath
|
||||
else Git.clone (Git.githubUrl name) repoPath
|
||||
case retVal of
|
||||
Left problem ->
|
||||
return $ Left problem
|
||||
Right () ->
|
||||
Git.tags repoPath
|
||||
getVersions :: Pkg.Name -> IO (Either Git.Error (V.Version, [V.Version]))
|
||||
getVersions name =
|
||||
Git.tags (Git.githubUrl name)
|
||||
|
||||
-- GET POSSIBILITIES
|
||||
|
||||
@ -36,8 +26,8 @@ bumpPossibilities (latest, previous) =
|
||||
let allVersions = reverse (latest : previous)
|
||||
minorPoints = map last (List.groupBy sameMajor allVersions)
|
||||
patchPoints = map last (List.groupBy sameMinor allVersions)
|
||||
in (latest, V.bumpMajor latest, M.MAJOR)
|
||||
: map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
|
||||
in (latest, V.bumpMajor latest, M.MAJOR) :
|
||||
map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
|
||||
++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
|
||||
|
||||
sameMajor :: V.Version -> V.Version -> Bool
|
||||
@ -57,21 +47,4 @@ installPackageVersion cache pkg vsn = do
|
||||
if versionedPkgExists
|
||||
then return $ Right ()
|
||||
else do
|
||||
let basePkgPath = Dirs.basePackage cache pkg
|
||||
basePkgExists <- Dir.doesDirectoryExist basePkgPath
|
||||
if basePkgExists
|
||||
then do
|
||||
updateResult <- Git.update pkg basePkgPath
|
||||
case updateResult of
|
||||
Left updateErr ->
|
||||
return $ Left updateErr
|
||||
Right () ->
|
||||
Git.localClone basePkgPath vsn versionedPkgPath
|
||||
else do
|
||||
let gitUrl = Git.githubUrl pkg
|
||||
baseCloneResult <- Git.clone gitUrl basePkgPath
|
||||
case baseCloneResult of
|
||||
Left cloneErr ->
|
||||
return $ Left cloneErr
|
||||
Right () ->
|
||||
Git.localClone basePkgPath vsn versionedPkgPath
|
||||
Git.clone (Git.githubUrl pkg) vsn versionedPkgPath
|
||||
|
@ -196,8 +196,8 @@ addConstraint solved unsolved (name, newConstraint) =
|
||||
|
||||
getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
|
||||
getRelevantVersions name constraint =
|
||||
Solver $ \state@(State cache _) ok back err -> do
|
||||
versionsResult <- Package.getVersions cache name
|
||||
Solver $ \state@(State _ _) ok back err -> do
|
||||
versionsResult <- Package.getVersions name
|
||||
case versionsResult of
|
||||
Right (newest, previous) ->
|
||||
case filter (C.satisfies constraint) (newest : previous) of
|
||||
|
@ -4,8 +4,6 @@ module Git
|
||||
--
|
||||
githubUrl,
|
||||
clone,
|
||||
localClone,
|
||||
update,
|
||||
tags,
|
||||
--
|
||||
hasLocalTag,
|
||||
@ -13,9 +11,11 @@ module Git
|
||||
)
|
||||
where
|
||||
|
||||
import Data.ByteString.Char8 qualified as BS
|
||||
import Data.Either qualified as Either
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as TE
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import Parse.Primitives qualified as Parser
|
||||
@ -27,7 +27,7 @@ import System.Process qualified as Process
|
||||
data Error
|
||||
= MissingGit
|
||||
| FailedCommand (Maybe FilePath) [String] String
|
||||
| NoVersions FilePath
|
||||
| NoVersions
|
||||
|
||||
--
|
||||
|
||||
@ -53,43 +53,21 @@ githubUrl pkg =
|
||||
|
||||
--
|
||||
|
||||
clone :: GitUrl -> FilePath -> IO (Either Error ())
|
||||
clone (GitUrl (pkgName, gitUrl)) targetFolder = do
|
||||
maybeExec <- checkInstalledGit
|
||||
putStrFlush $ "Cloning " ++ pkgName ++ "... "
|
||||
case maybeExec of
|
||||
Nothing -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left MissingGit
|
||||
Just git -> do
|
||||
let args = ["clone", "--bare", gitUrl, targetFolder]
|
||||
(exitCode, _, stderr) <-
|
||||
Process.readCreateProcessWithExitCode
|
||||
(Process.proc git args)
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure _ -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left $ FailedCommand Nothing ("git" : args) stderr
|
||||
Exit.ExitSuccess -> do
|
||||
putStrLn "Ok!"
|
||||
return $ Right ()
|
||||
|
||||
localClone :: FilePath -> V.Version -> FilePath -> IO (Either Error ())
|
||||
localClone gitUrl vsn targetFolder = do
|
||||
clone :: GitUrl -> V.Version -> FilePath -> IO (Either Error ())
|
||||
clone (GitUrl (pkgName, gitUrl)) vsn targetFolder = do
|
||||
maybeExec <- checkInstalledGit
|
||||
putStrFlush $ "Cloning " ++ pkgName ++ " " ++ V.toChars vsn ++ "... "
|
||||
case maybeExec of
|
||||
Nothing ->
|
||||
return $ Left MissingGit
|
||||
Just git -> do
|
||||
let args =
|
||||
[ "clone",
|
||||
gitUrl,
|
||||
"--local",
|
||||
"-b",
|
||||
"--branch",
|
||||
V.toChars vsn,
|
||||
"--depth",
|
||||
"1",
|
||||
gitUrl,
|
||||
targetFolder
|
||||
]
|
||||
(exitCode, _, stderr) <-
|
||||
@ -100,62 +78,61 @@ localClone gitUrl vsn targetFolder = do
|
||||
Exit.ExitFailure _ -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left $ FailedCommand Nothing ("git" : args) stderr
|
||||
Exit.ExitSuccess ->
|
||||
return $ Right ()
|
||||
|
||||
update :: Pkg.Name -> FilePath -> IO (Either Error ())
|
||||
update pkg path = do
|
||||
maybeExec <- checkInstalledGit
|
||||
putStrFlush $ "Updating " ++ Pkg.toChars pkg ++ "... "
|
||||
case maybeExec of
|
||||
Nothing -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left MissingGit
|
||||
Just git -> do
|
||||
let args = ["fetch", "-t"]
|
||||
(exitCode, _, stderr) <-
|
||||
Process.readCreateProcessWithExitCode
|
||||
( (Process.proc git args)
|
||||
{ Process.cwd = Just path
|
||||
}
|
||||
)
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure _ -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left $ FailedCommand (Just path) ("git" : args) stderr
|
||||
Exit.ExitSuccess -> do
|
||||
putStrLn "Ok!"
|
||||
return $ Right ()
|
||||
|
||||
tags :: FilePath -> IO (Either Error (V.Version, [V.Version]))
|
||||
tags path = do
|
||||
tags :: GitUrl -> IO (Either Error (V.Version, [V.Version]))
|
||||
tags (GitUrl (pkgName, gitUrl)) = do
|
||||
maybeExec <- checkInstalledGit
|
||||
putStrFlush $ "Retrieving versions for " ++ pkgName ++ "... "
|
||||
case maybeExec of
|
||||
Nothing ->
|
||||
return $ Left MissingGit
|
||||
Just git -> do
|
||||
let args = ["tag"]
|
||||
let args =
|
||||
[ "ls-remote",
|
||||
"--tags",
|
||||
gitUrl
|
||||
]
|
||||
(exitCode, stdout, stderr) <-
|
||||
Process.readCreateProcessWithExitCode
|
||||
( (Process.proc git args)
|
||||
{ Process.cwd = Just path
|
||||
}
|
||||
)
|
||||
(Process.proc git args)
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure _ -> do
|
||||
return $ Left $ FailedCommand (Just path) ("git" : args) stderr
|
||||
putStrLn "Error!"
|
||||
return $ Left $ FailedCommand Nothing ("git" : args) stderr
|
||||
Exit.ExitSuccess ->
|
||||
let tagList =
|
||||
map BS.pack $ lines stdout
|
||||
map (TE.encodeUtf8) $
|
||||
map (Text.replace (Text.pack "refs/tags/") Text.empty) $
|
||||
map (Text.pack) $
|
||||
map (Maybe.fromMaybe "" . listGet 1) $
|
||||
map words $
|
||||
lines stdout
|
||||
|
||||
-- Ignore tags that aren't semantic versions
|
||||
versions =
|
||||
reverse $ List.sort $ Either.rights $ map (Parser.fromByteString V.parser (,)) tagList
|
||||
in case versions of
|
||||
[] -> return $ Left $ NoVersions path
|
||||
v : vs -> return $ Right (v, vs)
|
||||
reverse $
|
||||
List.sort $
|
||||
Either.rights $ -- Ignore tags that aren't semantic versions
|
||||
map (Parser.fromByteString V.parser (,)) tagList
|
||||
in do
|
||||
putStrLn "Ok!"
|
||||
return $ case versions of
|
||||
[] -> Left NoVersions
|
||||
v : vs -> Right (v, vs)
|
||||
|
||||
listGet :: Int -> [a] -> Maybe a
|
||||
listGet idx ls =
|
||||
case ls of
|
||||
[] -> Nothing
|
||||
first : rest ->
|
||||
if idx == 0
|
||||
then Just first
|
||||
else listGet (idx - 1) rest
|
||||
|
||||
--
|
||||
|
||||
hasLocalTag :: V.Version -> IO (Either Error ())
|
||||
hasLocalTag vsn = do
|
||||
|
@ -1888,9 +1888,9 @@ toGitErrorReport title err context =
|
||||
[ D.reflow "But it returned the following error message:",
|
||||
D.indent 4 $ D.reflow errorMsg
|
||||
]
|
||||
Git.NoVersions _ ->
|
||||
Git.NoVersions ->
|
||||
toGitReport
|
||||
(context ++ ", no valid semantic version tags in this repo.")
|
||||
(context ++ ", no semver compatible tags in this repo.")
|
||||
[ D.reflow
|
||||
"Gren packages are just git repositories with tags following the \
|
||||
\ semantic versioning scheme. However, it seems that this particular repo \
|
||||
|
@ -50,9 +50,6 @@ Common gren-common
|
||||
terminal/impl
|
||||
terminal/src
|
||||
|
||||
other-extensions:
|
||||
TemplateHaskell
|
||||
|
||||
other-modules:
|
||||
Bump
|
||||
Diff
|
||||
@ -211,7 +208,8 @@ Common gren-common
|
||||
scientific,
|
||||
time >= 1.9.1,
|
||||
utf8-string,
|
||||
vector
|
||||
vector,
|
||||
text >= 2 && < 3
|
||||
|
||||
Executable gren
|
||||
Import:
|
||||
|
@ -59,10 +59,10 @@ getEnv =
|
||||
-- BUMP
|
||||
|
||||
bump :: Env -> Task.Task Exit.Bump ()
|
||||
bump env@(Env root cache outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
|
||||
bump env@(Env root _ outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
|
||||
Task.eio id $
|
||||
do
|
||||
versionResult <- Dirs.withRegistryLock cache $ Package.getVersions cache pkg
|
||||
versionResult <- Package.getVersions pkg
|
||||
case versionResult of
|
||||
Right knownVersions ->
|
||||
let bumpableVersions =
|
||||
|
@ -69,11 +69,11 @@ type Task a =
|
||||
Task.Task Exit.Diff a
|
||||
|
||||
diff :: Env -> Args -> Task ()
|
||||
diff env@(Env _ cache) args =
|
||||
diff env@(Env _ _) args =
|
||||
case args of
|
||||
GlobalInquiry name v1 v2 ->
|
||||
do
|
||||
versionResult <- Task.io $ Dirs.withRegistryLock cache $ Package.getVersions cache name
|
||||
versionResult <- Task.io $ Package.getVersions name
|
||||
case versionResult of
|
||||
Right vsns ->
|
||||
do
|
||||
@ -116,7 +116,7 @@ getLatestDocs (Env _ cache) name (latest, _) =
|
||||
-- READ OUTLINE
|
||||
|
||||
readOutline :: Env -> Task (Pkg.Name, (V.Version, [V.Version]))
|
||||
readOutline (Env maybeRoot cache) =
|
||||
readOutline (Env maybeRoot _) =
|
||||
case maybeRoot of
|
||||
Nothing ->
|
||||
Task.throw Exit.DiffNoOutline
|
||||
@ -132,7 +132,7 @@ readOutline (Env maybeRoot cache) =
|
||||
Task.throw Exit.DiffApplication
|
||||
Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) ->
|
||||
do
|
||||
versionResult <- Task.io $ Dirs.withRegistryLock cache $ Package.getVersions cache pkg
|
||||
versionResult <- Task.io $ Package.getVersions pkg
|
||||
case versionResult of
|
||||
Right vsns ->
|
||||
return (pkg, vsns)
|
||||
|
@ -60,13 +60,13 @@ getEnv =
|
||||
-- PUBLISH
|
||||
|
||||
publish :: Env -> Task.Task Exit.Publish ()
|
||||
publish env@(Env root cache outline) =
|
||||
publish env@(Env root _ outline) =
|
||||
case outline of
|
||||
Outline.App _ ->
|
||||
Task.throw Exit.PublishApplication
|
||||
Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) ->
|
||||
do
|
||||
knownVersionsResult <- Task.io $ Dirs.withRegistryLock cache $ Package.getVersions cache pkg
|
||||
knownVersionsResult <- Task.io $ Package.getVersions pkg
|
||||
let knownVersionsMaybe = Either.either (const Nothing) Just knownVersionsResult
|
||||
reportPublishStart pkg vsn knownVersionsMaybe
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user