mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-26 11:07:48 +03:00
Merge branch 'trunk' into topic/merge4
This commit is contained in:
commit
6e92e62151
3
.github/workflows/bundle-ucm.yaml
vendored
3
.github/workflows/bundle-ucm.yaml
vendored
@ -233,7 +233,8 @@ jobs:
|
||||
file: ucm
|
||||
content: |
|
||||
#!/bin/bash
|
||||
"$(dirname "$0")/unison/unison" --runtime-path "$(dirname "$0")/runtime/bin/unison-runtime" "$@"
|
||||
unison_root="$(dirname "$(readlink -f "$0")")"
|
||||
"${unison_root}/unison/unison" --runtime-path "${unison_root}/runtime/bin/unison-runtime" "$@"
|
||||
- name: create startup script (Windows)
|
||||
if: runner.os == 'Windows'
|
||||
uses: 1arp/create-a-file-action@0.4.4
|
||||
|
2
.github/workflows/release.yaml
vendored
2
.github/workflows/release.yaml
vendored
@ -52,7 +52,7 @@ jobs:
|
||||
|
||||
gh release create "release/${{inputs.version}}" \
|
||||
--repo unisonweb/unison \
|
||||
--target "${{github.ref}}" \
|
||||
--target "${{github.sha}}" \
|
||||
--generate-notes \
|
||||
--notes-start-tag "${prev_tag}" \
|
||||
\
|
||||
|
@ -85,5 +85,5 @@ curl -L https://github.com/unisonweb/unison/releases/latest/download/ucm-linux.t
|
||||
|
||||
**Windows manual install:**
|
||||
* Recommended: [Set your default Terminal application](https://devblogs.microsoft.com/commandline/windows-terminal-as-your-default-command-line-experience/) to “Windows Terminal”.
|
||||
* Download [the release](https://github.com/unisonweb/unison/releases/download/release%2FM5h/ucm-windows.zip) and extract it to a location of your choosing.
|
||||
* Download [the release](https://github.com/unisonweb/unison/releases/latest/download/ucm-windows.zip) and extract it to a location of your choosing.
|
||||
* Run `ucm.exe`
|
||||
|
@ -88,15 +88,11 @@ module Unison.Codebase
|
||||
|
||||
-- ** Remote sync
|
||||
viewRemoteBranch,
|
||||
importRemoteBranch,
|
||||
Preprocessing (..),
|
||||
pushGitBranch,
|
||||
PushGitBranchOpts (..),
|
||||
|
||||
-- * Codebase path
|
||||
getCodebaseDir,
|
||||
CodebasePath,
|
||||
SyncToDir,
|
||||
|
||||
-- * Direct codebase access
|
||||
runTransaction,
|
||||
@ -114,8 +110,6 @@ module Unison.Codebase
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Except (ExceptT (ExceptT), runExceptT)
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import U.Codebase.Branch qualified as V2
|
||||
@ -130,21 +124,13 @@ import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation))
|
||||
import Unison.Codebase.CodeLookup qualified as CL
|
||||
import Unison.Codebase.Editor.Git (withStatus)
|
||||
import Unison.Codebase.Editor.Git qualified as Git
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace)
|
||||
import Unison.Codebase.GitError qualified as GitError
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.Codebase.Type
|
||||
( Codebase (..),
|
||||
GitError (GitCodebaseError),
|
||||
PushGitBranchOpts (..),
|
||||
SyncToDir,
|
||||
)
|
||||
import Unison.Codebase.Type (Codebase (..), GitError)
|
||||
import Unison.CodebasePath (CodebasePath, getCodebaseDir)
|
||||
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
|
||||
import Unison.DataDeclaration (Decl)
|
||||
@ -168,7 +154,6 @@ import Unison.Typechecker.TypeLookup (TypeLookup (TypeLookup))
|
||||
import Unison.Typechecker.TypeLookup qualified as TL
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.Util.Relation qualified as Rel
|
||||
import Unison.Util.Timing (time)
|
||||
import Unison.Var (Var)
|
||||
import Unison.WatchKind qualified as WK
|
||||
|
||||
@ -483,40 +468,6 @@ isType c r = case r of
|
||||
|
||||
-- * Git stuff
|
||||
|
||||
-- | An optional preprocessing step to run on branches
|
||||
-- before they're imported into the local codebase.
|
||||
data Preprocessing m
|
||||
= Unmodified
|
||||
| Preprocessed (Branch m -> m (Branch m))
|
||||
|
||||
-- | Sync elements as needed from a remote git codebase into the local one.
|
||||
-- If `sch` is supplied, we try to load the specified branch hash;
|
||||
-- otherwise we try to load the root branch.
|
||||
importRemoteBranch ::
|
||||
forall m v a.
|
||||
(MonadUnliftIO m) =>
|
||||
Codebase m v a ->
|
||||
ReadGitRemoteNamespace ->
|
||||
SyncMode ->
|
||||
Preprocessing m ->
|
||||
m (Either GitError (Branch m))
|
||||
importRemoteBranch codebase ns mode preprocess = runExceptT $ do
|
||||
branchHash <- ExceptT . viewRemoteBranch' codebase ns Git.RequireExistingBranch $ \(branch, cacheDir) -> do
|
||||
withStatus "Importing downloaded files into local codebase..." $ do
|
||||
processedBranch <- preprocessOp branch
|
||||
time "SyncFromDirectory" $ do
|
||||
syncFromDirectory codebase cacheDir mode processedBranch
|
||||
pure $ Branch.headHash processedBranch
|
||||
time "load fresh local branch after sync" $ do
|
||||
lift (getBranchForHash codebase branchHash) >>= \case
|
||||
Nothing -> throwE . GitCodebaseError $ GitError.CouldntLoadSyncedBranch ns branchHash
|
||||
Just result -> pure $ result
|
||||
where
|
||||
preprocessOp :: Branch m -> m (Branch m)
|
||||
preprocessOp = case preprocess of
|
||||
Preprocessed f -> f
|
||||
Unmodified -> pure
|
||||
|
||||
-- | Pull a git branch and view it from the cache, without syncing into the
|
||||
-- local codebase.
|
||||
viewRemoteBranch ::
|
||||
|
@ -1,9 +1,12 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
module Unison.Codebase.GitError
|
||||
( CodebasePath,
|
||||
GitProtocolError (..),
|
||||
GitCodebaseError (..),
|
||||
)
|
||||
where
|
||||
|
||||
module Unison.Codebase.GitError where
|
||||
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo)
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo, WriteGitRepo)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Prelude
|
||||
|
||||
@ -30,8 +33,5 @@ data GitProtocolError
|
||||
data GitCodebaseError h
|
||||
= NoRemoteNamespaceWithHash ReadGitRepo ShortCausalHash
|
||||
| RemoteNamespaceHashAmbiguous ReadGitRepo ShortCausalHash (Set h)
|
||||
| CouldntLoadRootBranch ReadGitRepo h
|
||||
| CouldntParseRemoteBranch ReadGitRepo String
|
||||
| CouldntLoadSyncedBranch ReadGitRemoteNamespace h
|
||||
| CouldntFindRemoteBranch ReadGitRepo Path
|
||||
deriving (Show)
|
||||
|
@ -1,10 +1,5 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Codebase.SqliteCodebase
|
||||
( Unison.Codebase.SqliteCodebase.init,
|
||||
@ -64,8 +59,7 @@ import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
|
||||
import Unison.Codebase.SqliteCodebase.Paths
|
||||
import Unison.Codebase.SqliteCodebase.SyncEphemeral qualified as SyncEphemeral
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.Codebase.Type (LocalOrRemote (..), PushGitBranchOpts (..))
|
||||
import Unison.Codebase.Type (GitPushBehavior, LocalOrRemote (..))
|
||||
import Unison.Codebase.Type qualified as C
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.Hash (Hash)
|
||||
@ -325,8 +319,8 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
|
||||
withRunInIO \runInIO ->
|
||||
runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)))
|
||||
|
||||
syncFromDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
|
||||
syncFromDirectory srcRoot _syncMode b =
|
||||
syncFromDirectory :: Codebase1.CodebasePath -> Branch m -> m ()
|
||||
syncFromDirectory srcRoot b =
|
||||
withConnection (debugName ++ ".sync.src") srcRoot \srcConn ->
|
||||
withConn \destConn -> do
|
||||
progressStateRef <- liftIO (newIORef emptySyncProgressState)
|
||||
@ -334,8 +328,8 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
|
||||
Sqlite.runWriteTransaction destConn \runDest -> do
|
||||
syncInternal (syncProgress progressStateRef) runSrc runDest b
|
||||
|
||||
syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
|
||||
syncToDirectory destRoot _syncMode b =
|
||||
syncToDirectory :: Codebase1.CodebasePath -> Branch m -> m ()
|
||||
syncToDirectory destRoot b =
|
||||
withConn \srcConn ->
|
||||
withConnection (debugName ++ ".sync.dest") destRoot \destConn -> do
|
||||
progressStateRef <- liftIO (newIORef emptySyncProgressState)
|
||||
@ -635,11 +629,11 @@ pushGitBranch ::
|
||||
(MonadUnliftIO m) =>
|
||||
Sqlite.Connection ->
|
||||
WriteGitRepo ->
|
||||
PushGitBranchOpts ->
|
||||
GitPushBehavior ->
|
||||
-- An action which accepts the current root branch on the remote and computes a new branch.
|
||||
(Branch m -> m (Either e (Branch m))) ->
|
||||
m (Either C.GitError (Either e (Branch m)))
|
||||
pushGitBranch srcConn repo (PushGitBranchOpts behavior _syncMode) action = UnliftIO.try do
|
||||
pushGitBranch srcConn repo behavior action = UnliftIO.try do
|
||||
-- Pull the latest remote into our git cache
|
||||
-- Use a local git clone to copy this git repo into a temp-dir
|
||||
-- Delete the codebase in our temp-dir
|
||||
|
@ -1,3 +0,0 @@
|
||||
module Unison.Codebase.SyncMode where
|
||||
|
||||
data SyncMode = ShortCircuit | Complete deriving (Eq, Show)
|
@ -4,10 +4,8 @@
|
||||
module Unison.Codebase.Type
|
||||
( Codebase (..),
|
||||
CodebasePath,
|
||||
PushGitBranchOpts (..),
|
||||
GitPushBehavior (..),
|
||||
GitError (..),
|
||||
SyncToDir,
|
||||
LocalOrRemote (..),
|
||||
gitErrorFromOpenCodebaseError,
|
||||
)
|
||||
@ -21,7 +19,6 @@ import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, W
|
||||
import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError)
|
||||
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
||||
import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..))
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.CodebasePath (CodebasePath)
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.DataDeclaration (Decl)
|
||||
@ -36,12 +33,6 @@ import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.WatchKind qualified as WK
|
||||
|
||||
type SyncToDir m =
|
||||
CodebasePath -> -- dest codebase
|
||||
SyncMode ->
|
||||
Branch m -> -- branch to sync to dest codebase
|
||||
m ()
|
||||
|
||||
-- | Abstract interface to a user's codebase.
|
||||
data Codebase m v a = Codebase
|
||||
{ -- | Get a user-defined term from the codebase.
|
||||
@ -86,12 +77,12 @@ data Codebase m v a = Codebase
|
||||
-- The terms and type declarations that a branch references must already exist in the codebase.
|
||||
putBranch :: Branch m -> m (),
|
||||
-- | Copy a branch and all of its dependencies from the given codebase into this one.
|
||||
syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
|
||||
syncFromDirectory :: CodebasePath -> Branch m -> m (),
|
||||
-- | Copy a branch and all of its dependencies from this codebase into the given codebase.
|
||||
syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
|
||||
syncToDirectory :: CodebasePath -> Branch m -> m (),
|
||||
viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r),
|
||||
-- | Push the given branch to the given repo, and optionally set it as the root branch.
|
||||
pushGitBranch :: forall e. WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))),
|
||||
pushGitBranch :: forall e. WriteGitRepo -> GitPushBehavior -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))),
|
||||
-- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@.
|
||||
getWatch :: WK.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a)),
|
||||
-- | Get the set of user-defined terms-or-constructors that have the given type.
|
||||
@ -116,11 +107,6 @@ data LocalOrRemote
|
||||
| Remote
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data PushGitBranchOpts = PushGitBranchOpts
|
||||
{ behavior :: GitPushBehavior,
|
||||
syncMode :: SyncMode
|
||||
}
|
||||
|
||||
data GitPushBehavior
|
||||
= -- | Don't set root, just sync entities.
|
||||
GitPushBehaviorGist
|
||||
|
@ -84,7 +84,6 @@ library
|
||||
Unison.Codebase.SqliteCodebase.Operations
|
||||
Unison.Codebase.SqliteCodebase.Paths
|
||||
Unison.Codebase.SqliteCodebase.SyncEphemeral
|
||||
Unison.Codebase.SyncMode
|
||||
Unison.Codebase.TermEdit
|
||||
Unison.Codebase.TermEdit.Typing
|
||||
Unison.Codebase.Type
|
||||
|
@ -38,7 +38,7 @@ if ! [[ "$1" =~ ^[0-9]+\.[0-9]+\.[0-9]+$ ]] ; then
|
||||
fi
|
||||
|
||||
version="${1}"
|
||||
target=${2:-origin/trunk}
|
||||
src=${2:-origin/trunk}
|
||||
tag="release/$version"
|
||||
|
||||
echo "Creating release in unison-local-ui."
|
||||
@ -50,7 +50,7 @@ gh release create "release/${version}" \
|
||||
echo "Kicking off release workflow in unisonweb/unison"
|
||||
# Make sure our origin/trunk ref is up to date, since that's usually what gets tagged.
|
||||
git fetch origin trunk
|
||||
git tag "${tag}" "${target}"
|
||||
git tag "${tag}" "${src}"
|
||||
git push origin "${tag}"
|
||||
gh workflow run release --repo unisonweb/unison \
|
||||
--ref "${tag}" \
|
||||
|
138
unison-cli/src/Unison/Cli/DownloadUtils.hs
Normal file
138
unison-cli/src/Unison/Cli/DownloadUtils.hs
Normal file
@ -0,0 +1,138 @@
|
||||
-- | Utility functions for downloading remote entities and storing them locally in SQLite.
|
||||
--
|
||||
-- These are shared by commands like `pull` and `clone`.
|
||||
module Unison.Cli.DownloadUtils
|
||||
( downloadProjectBranchFromShare,
|
||||
downloadLooseCodeFromShare,
|
||||
GitNamespaceHistoryTreatment (..),
|
||||
downloadLooseCodeFromGitRepo,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVar, readTVarIO)
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import System.Console.Regions qualified as Console.Regions
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Git qualified as Git
|
||||
import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver)
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadShareLooseCode, shareUserHandleToText)
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Type (GitError)
|
||||
import Unison.Codebase.Type qualified as Codebase (viewRemoteBranch')
|
||||
import Unison.Core.Project (ProjectAndBranch (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.Share.API.Hash qualified as Share
|
||||
import Unison.Share.Codeserver qualified as Codeserver
|
||||
import Unison.Share.Sync qualified as Share
|
||||
import Unison.Share.Sync.Types qualified as Share
|
||||
import Unison.Share.Types (codeserverBaseURL)
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Sync.Common qualified as Sync.Common
|
||||
import Unison.Sync.Types qualified as Share
|
||||
|
||||
-- | Download a project/branch from Share.
|
||||
downloadProjectBranchFromShare ::
|
||||
HasCallStack =>
|
||||
Share.IncludeSquashedHead ->
|
||||
Share.RemoteProjectBranch ->
|
||||
Cli (Either Output.ShareError CausalHash)
|
||||
downloadProjectBranchFromShare useSquashed branch =
|
||||
Cli.labelE \done -> do
|
||||
let remoteProjectBranchName = branch.branchName
|
||||
let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName))
|
||||
causalHashJwt <-
|
||||
case (useSquashed, branch.squashedBranchHead) of
|
||||
(Share.IncludeSquashedHead, Nothing) -> done Output.ShareExpectedSquashedHead
|
||||
(Share.IncludeSquashedHead, Just squashedHead) -> pure squashedHead
|
||||
(Share.NoSquashedHead, _) -> pure branch.branchHead
|
||||
exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt))
|
||||
when (not exists) do
|
||||
(result, numDownloaded) <-
|
||||
Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
|
||||
result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback
|
||||
numDownloaded <- liftIO getNumDownloaded
|
||||
pure (result, numDownloaded)
|
||||
result & onLeft \err0 -> do
|
||||
done case err0 of
|
||||
Share.SyncError err -> Output.ShareErrorDownloadEntities err
|
||||
Share.TransportError err -> Output.ShareErrorTransport err
|
||||
Cli.respond (Output.DownloadedEntities numDownloaded)
|
||||
pure (Sync.Common.hash32ToCausalHash (Share.hashJWTHash causalHashJwt))
|
||||
|
||||
-- | Download loose code from Share.
|
||||
downloadLooseCodeFromShare :: ReadShareLooseCode -> Cli (Either Output.ShareError CausalHash)
|
||||
downloadLooseCodeFromShare namespace = do
|
||||
let codeserver = Codeserver.resolveCodeserver namespace.server
|
||||
let baseURL = codeserverBaseURL codeserver
|
||||
|
||||
-- Auto-login to share if pulling from a non-public path
|
||||
when (not (RemoteRepo.isPublic namespace)) do
|
||||
_userInfo <- ensureAuthenticatedWithCodeserver codeserver
|
||||
pure ()
|
||||
|
||||
let shareFlavoredPath =
|
||||
Share.Path $
|
||||
shareUserHandleToText namespace.repo
|
||||
:| map NameSegment.toUnescapedText (Path.toList namespace.path)
|
||||
|
||||
Cli.labelE \done -> do
|
||||
(causalHash, numDownloaded) <-
|
||||
Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
|
||||
causalHash <-
|
||||
Share.pull baseURL shareFlavoredPath downloadedCallback & onLeftM \err0 ->
|
||||
done case err0 of
|
||||
Share.SyncError err -> Output.ShareErrorPull err
|
||||
Share.TransportError err -> Output.ShareErrorTransport err
|
||||
numDownloaded <- liftIO getNumDownloaded
|
||||
pure (causalHash, numDownloaded)
|
||||
Cli.respond (Output.DownloadedEntities numDownloaded)
|
||||
pure causalHash
|
||||
|
||||
-- Provide the given action a callback that display to the terminal.
|
||||
withEntitiesDownloadedProgressCallback :: ((Int -> IO (), IO Int) -> IO a) -> IO a
|
||||
withEntitiesDownloadedProgressCallback action = do
|
||||
entitiesDownloadedVar <- newTVarIO 0
|
||||
Console.Regions.displayConsoleRegions do
|
||||
Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do
|
||||
Console.Regions.setConsoleRegion region do
|
||||
entitiesDownloaded <- readTVar entitiesDownloadedVar
|
||||
pure $
|
||||
"\n Downloaded "
|
||||
<> tShow entitiesDownloaded
|
||||
<> " entities...\n\n"
|
||||
action ((\n -> atomically (modifyTVar' entitiesDownloadedVar (+ n))), readTVarIO entitiesDownloadedVar)
|
||||
|
||||
data GitNamespaceHistoryTreatment
|
||||
= -- | Don't touch the history
|
||||
GitNamespaceHistoryTreatment'LetAlone
|
||||
| -- | Throw away all history at all levels
|
||||
GitNamespaceHistoryTreatment'DiscardAllHistory
|
||||
|
||||
-- | Download loose code that's in a SQLite codebase in a Git repo.
|
||||
downloadLooseCodeFromGitRepo ::
|
||||
MonadIO m =>
|
||||
Codebase IO Symbol Ann ->
|
||||
GitNamespaceHistoryTreatment ->
|
||||
ReadGitRemoteNamespace ->
|
||||
m (Either GitError CausalHash)
|
||||
downloadLooseCodeFromGitRepo codebase historyTreatment namespace = liftIO do
|
||||
Codebase.viewRemoteBranch' codebase namespace Git.RequireExistingBranch \(branch0, cacheDir) -> do
|
||||
let branch =
|
||||
case historyTreatment of
|
||||
GitNamespaceHistoryTreatment'LetAlone -> branch0
|
||||
GitNamespaceHistoryTreatment'DiscardAllHistory -> Branch.discardHistory branch0
|
||||
|
||||
Codebase.syncFromDirectory codebase cacheDir branch
|
||||
pure (Branch.headHash branch)
|
@ -25,6 +25,7 @@ module Unison.Cli.Monad
|
||||
|
||||
-- * Short-circuiting
|
||||
label,
|
||||
labelE,
|
||||
returnEarly,
|
||||
returnEarlyWithoutOutput,
|
||||
haltRepl,
|
||||
@ -336,6 +337,12 @@ label f =
|
||||
| otherwise -> throwIO err
|
||||
Right a -> feed k a
|
||||
|
||||
-- | A variant of @label@ for the common case that early-return values are tagged with a Left.
|
||||
labelE :: ((forall void. a -> Cli void) -> Cli b) -> Cli (Either a b)
|
||||
labelE f =
|
||||
label \goto ->
|
||||
Right <$> f (goto . Left)
|
||||
|
||||
-- | Time an action.
|
||||
time :: String -> Cli a -> Cli a
|
||||
time label action =
|
||||
|
@ -474,8 +474,8 @@ updateRoot new reason =
|
||||
let newHash = Branch.headHash new
|
||||
oldHash <- getLastSavedRootHash
|
||||
when (oldHash /= newHash) do
|
||||
setRootBranch new
|
||||
liftIO (Codebase.putRootBranch codebase reason new)
|
||||
setRootBranch new
|
||||
setLastSavedRootHash newHash
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
|
@ -27,6 +27,7 @@ module Unison.Cli.ProjectUtils
|
||||
expectLooseCodeOrProjectBranch,
|
||||
|
||||
-- * Loading remote project info
|
||||
expectRemoteProjectById,
|
||||
expectRemoteProjectByName,
|
||||
expectRemoteProjectBranchById,
|
||||
loadRemoteProjectBranchByName,
|
||||
@ -37,6 +38,7 @@ module Unison.Cli.ProjectUtils
|
||||
|
||||
-- * Other helpers
|
||||
findTemporaryBranchName,
|
||||
expectLatestReleaseBranchName,
|
||||
)
|
||||
where
|
||||
|
||||
@ -61,8 +63,9 @@ import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, ResolvedBranchRelativePath)
|
||||
import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath
|
||||
import Unison.Core.Project (ProjectBranchName (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||
import Unison.Project.Util
|
||||
import Unison.Sqlite (Transaction)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -264,6 +267,12 @@ expectLooseCodeOrProjectBranch =
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Remote project utils
|
||||
|
||||
-- | Expect a remote project by id. Its latest-known name is also provided, for error messages.
|
||||
expectRemoteProjectById :: RemoteProjectId -> ProjectName -> Cli Share.RemoteProject
|
||||
expectRemoteProjectById remoteProjectId remoteProjectName = do
|
||||
Share.getProjectById remoteProjectId & onNothingM do
|
||||
Cli.returnEarly (Output.RemoteProjectDoesntExist Share.hardCodedUri remoteProjectName)
|
||||
|
||||
expectRemoteProjectByName :: ProjectName -> Cli Share.RemoteProject
|
||||
expectRemoteProjectByName remoteProjectName = do
|
||||
Share.getProjectByName remoteProjectName & onNothingM do
|
||||
@ -358,3 +367,10 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case
|
||||
remoteProjectBranchDoesntExist :: ProjectAndBranch ProjectName ProjectBranchName -> Cli void
|
||||
remoteProjectBranchDoesntExist projectAndBranch =
|
||||
Cli.returnEarly (Output.RemoteProjectBranchDoesntExist Share.hardCodedUri projectAndBranch)
|
||||
|
||||
-- | Expect the given remote project to have a latest release, and return it as a valid branch name.
|
||||
expectLatestReleaseBranchName :: Share.RemoteProject -> Cli ProjectBranchName
|
||||
expectLatestReleaseBranchName remoteProject =
|
||||
case remoteProject.latestRelease of
|
||||
Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases remoteProject.projectName)
|
||||
Just semver -> pure (UnsafeProjectBranchName ("releases/" <> into @Text semver))
|
||||
|
@ -96,7 +96,7 @@ data GetProjectBranchResponse
|
||||
data IncludeSquashedHead
|
||||
= IncludeSquashedHead
|
||||
| NoSquashedHead
|
||||
deriving (Show, Eq)
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
-- | Get a project branch by id.
|
||||
--
|
||||
|
@ -64,6 +64,7 @@ import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
|
||||
import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace)
|
||||
import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI)
|
||||
import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Format
|
||||
import Unison.Codebase.Editor.HandleInput.InstallLib (handleInstallLib)
|
||||
import Unison.Codebase.Editor.HandleInput.Load (EvalMode (Sandboxed), evalUnisonFile, handleLoad, loadUnisonFile)
|
||||
import Unison.Codebase.Editor.HandleInput.Merge2 (handleMerge)
|
||||
import Unison.Codebase.Editor.HandleInput.MoveAll (handleMoveAll)
|
||||
@ -77,7 +78,7 @@ import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename)
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
|
||||
import Unison.Codebase.Editor.HandleInput.Projects (handleProjects)
|
||||
import Unison.Codebase.Editor.HandleInput.Pull (doPullRemoteBranch, mergeBranchAndPropagateDefaultPatch, propagatePatch)
|
||||
import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch, propagatePatch)
|
||||
import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch)
|
||||
import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft)
|
||||
import Unison.Codebase.Editor.HandleInput.Run (handleRun)
|
||||
@ -1023,7 +1024,7 @@ loop e = do
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
Cli.respondNumbered $ ListEdits patch suffixifiedPPE
|
||||
PullRemoteBranchI sourceTarget sMode pMode verbosity -> doPullRemoteBranch sourceTarget sMode pMode verbosity
|
||||
PullRemoteBranchI sourceTarget pMode verbosity -> handlePull sourceTarget pMode verbosity
|
||||
PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput
|
||||
ListDependentsI hq -> handleDependents hq
|
||||
ListDependenciesI hq -> handleDependencies hq
|
||||
@ -1188,6 +1189,7 @@ loop e = do
|
||||
CloneI remoteNames localNames -> handleClone remoteNames localNames
|
||||
ReleaseDraftI semver -> handleReleaseDraft semver
|
||||
UpgradeI old new -> handleUpgrade old new
|
||||
LibInstallI libdep -> handleInstallLib libdep
|
||||
|
||||
inputDescription :: Input -> Cli Text
|
||||
inputDescription input =
|
||||
@ -1372,6 +1374,7 @@ inputDescription input =
|
||||
StructuredFindReplaceI {} -> wat
|
||||
GistI {} -> wat
|
||||
HistoryI {} -> wat
|
||||
LibInstallI {} -> wat
|
||||
ListDependenciesI {} -> wat
|
||||
ListDependentsI {} -> wat
|
||||
ListEditsI {} -> wat
|
||||
|
141
unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs
Normal file
141
unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs
Normal file
@ -0,0 +1,141 @@
|
||||
-- | @lib.install@ input handler
|
||||
module Unison.Codebase.Editor.HandleInput.InstallLib
|
||||
( handleInstallLib,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..))
|
||||
import Unison.Cli.DownloadUtils
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Core.Project (ProjectBranchName)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project
|
||||
( ProjectAndBranch (..),
|
||||
ProjectBranchNameKind (..),
|
||||
ProjectBranchNameOrLatestRelease (..),
|
||||
ProjectName,
|
||||
Semver (..),
|
||||
classifyProjectBranchName,
|
||||
projectNameToUserProjectSlugs,
|
||||
)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (unsafeParseText)
|
||||
|
||||
handleInstallLib :: ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease) -> Cli ()
|
||||
handleInstallLib (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) = do
|
||||
(currentProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
|
||||
let currentProjectBranchPath =
|
||||
ProjectUtils.projectBranchPath $
|
||||
ProjectAndBranch
|
||||
currentProjectAndBranch.project.projectId
|
||||
currentProjectAndBranch.branch.branchId
|
||||
|
||||
libdepProject <- ProjectUtils.expectRemoteProjectByName libdepProjectName
|
||||
|
||||
libdepBranchName <-
|
||||
case fromMaybe ProjectBranchNameOrLatestRelease'LatestRelease unresolvedLibdepBranchName of
|
||||
ProjectBranchNameOrLatestRelease'Name name -> pure name
|
||||
ProjectBranchNameOrLatestRelease'LatestRelease -> ProjectUtils.expectLatestReleaseBranchName libdepProject
|
||||
|
||||
let libdepProjectAndBranchNames =
|
||||
ProjectAndBranch libdepProjectName libdepBranchName
|
||||
|
||||
libdepProjectBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
Share.IncludeSquashedHead
|
||||
(ProjectAndBranch (libdepProject.projectId, libdepProjectName) libdepBranchName)
|
||||
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
causalHash <-
|
||||
downloadProjectBranchFromShare Share.IncludeSquashedHead libdepProjectBranch
|
||||
& onLeftM (Cli.returnEarly . Output.ShareError)
|
||||
|
||||
remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase causalHash)
|
||||
|
||||
-- Find the best available dependency name, starting with the best one (e.g. "unison_base_1_0_0"), and tacking on a
|
||||
-- "__2", "__3", etc. suffix.
|
||||
--
|
||||
-- For example, if the best name is "foo", and libdeps "foo" and "foo__2" already exist, then we'll get "foo__3".
|
||||
libdepNameSegment :: NameSegment <- do
|
||||
currentBranchObject <- Cli.getBranch0At currentProjectBranchPath
|
||||
pure $
|
||||
fresh
|
||||
(\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText)
|
||||
( case Map.lookup NameSegment.libSegment currentBranchObject._children of
|
||||
Nothing -> Set.empty
|
||||
Just libdeps -> Map.keysSet (Branch._children (Branch.head libdeps))
|
||||
)
|
||||
(makeDependencyName libdepProjectName libdepBranchName)
|
||||
|
||||
let libdepPath :: Path.Absolute
|
||||
libdepPath =
|
||||
Path.resolve
|
||||
currentProjectBranchPath
|
||||
(Path.Relative (Path.fromList [NameSegment.libSegment, libdepNameSegment]))
|
||||
|
||||
let reflogDescription = "lib.install " <> into @Text libdepProjectAndBranchNames
|
||||
_didUpdate <- Cli.updateAt reflogDescription libdepPath (\_empty -> remoteBranchObject)
|
||||
|
||||
Cli.respond (Output.InstalledLibdep libdepProjectAndBranchNames libdepNameSegment)
|
||||
|
||||
fresh :: Ord a => (Int -> a -> a) -> Set a -> a -> a
|
||||
fresh bump taken x =
|
||||
fromJust (List.find (\y -> not (Set.member y taken)) (x : map (\i -> bump i x) [2 ..]))
|
||||
|
||||
-- This function mangles the dependency (a project name + a branch name) to a flat string without special characters,
|
||||
-- suitable for sticking in the `lib` namespace.
|
||||
--
|
||||
-- >>> makeDependencyName (unsafeFrom @Text "@unison/base") (unsafeFrom @Text "main")
|
||||
-- unison_base_main
|
||||
--
|
||||
-- >>> makeDependencyName (unsafeFrom @Text "@unison/base") (unsafeFrom @Text "releases/1.0.0")
|
||||
-- unison_base_1_0_0
|
||||
--
|
||||
-- >>> makeDependencyName (unsafeFrom @Text "@unison/base") (unsafeFrom @Text "releases/drafts/1.0.0")
|
||||
-- unison_base_1_0_0_draft
|
||||
--
|
||||
-- >>> makeDependencyName (unsafeFrom @Text "@unison/base") (unsafeFrom @Text "@person/topic")
|
||||
-- unison_base_person_topic
|
||||
makeDependencyName :: ProjectName -> ProjectBranchName -> NameSegment
|
||||
makeDependencyName projectName branchName =
|
||||
NameSegment.unsafeParseText $
|
||||
Text.intercalate "_" $
|
||||
fold
|
||||
[ case projectNameToUserProjectSlugs projectName of
|
||||
(user, project) ->
|
||||
fold
|
||||
[ if Text.null user then [] else [user],
|
||||
[project]
|
||||
],
|
||||
case classifyProjectBranchName branchName of
|
||||
ProjectBranchNameKind'Contributor user branch -> [user, underscorify branch]
|
||||
ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"]
|
||||
ProjectBranchNameKind'Release ver -> semverSegments ver
|
||||
ProjectBranchNameKind'NothingSpecial -> [underscorify branchName]
|
||||
]
|
||||
where
|
||||
semverSegments :: Semver -> [Text]
|
||||
semverSegments (Semver x y z) =
|
||||
[tShow x, tShow y, tShow z]
|
||||
|
||||
underscorify :: ProjectBranchName -> Text
|
||||
underscorify =
|
||||
Text.replace "-" "_" . into @Text
|
@ -10,9 +10,10 @@ import Data.These (These (..))
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
|
||||
import U.Codebase.Sqlite.DbId qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project)
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli (updateAt)
|
||||
@ -20,17 +21,11 @@ import Unison.Cli.ProjectUtils (projectBranchPath)
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Editor.HandleInput.Pull qualified as HandleInput.Pull
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, projectNameUserSlug)
|
||||
import Unison.Share.API.Hash qualified as Share.API
|
||||
import Unison.Share.Sync qualified as Share (downloadEntities)
|
||||
import Unison.Share.Sync.Types qualified as Share
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Sync.Common (hash32ToCausalHash)
|
||||
import Unison.Sync.Types qualified as Share
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
data LocalProjectKey
|
||||
@ -47,7 +42,7 @@ handleClone remoteNames0 maybeLocalNames0 = do
|
||||
maybeCurrentProjectBranch <- ProjectUtils.getCurrentProjectBranch
|
||||
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0
|
||||
localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0
|
||||
cloneInto localNames1 (resolvedRemoteNames ^. #branch)
|
||||
cloneInto localNames1 resolvedRemoteNames.branch
|
||||
|
||||
data ResolvedRemoteNames = ResolvedRemoteNames
|
||||
{ branch :: Share.RemoteProjectBranch,
|
||||
@ -106,8 +101,8 @@ resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
|
||||
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
|
||||
case (maybeRemoteProject, maybeRemoteBranch) of
|
||||
(Just remoteProject, Nothing) -> do
|
||||
let remoteProjectId = remoteProject ^. #projectId
|
||||
let remoteProjectName = remoteProject ^. #projectName
|
||||
let remoteProjectId = remoteProject.projectId
|
||||
let remoteProjectName = remoteProject.projectName
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
remoteBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
@ -193,14 +188,14 @@ resolveLocalNames ::
|
||||
resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames =
|
||||
resolve case maybeLocalNames of
|
||||
Nothing ->
|
||||
ProjectAndBranchNames'Unambiguous case resolvedRemoteNames ^. #from of
|
||||
ProjectAndBranchNames'Unambiguous case resolvedRemoteNames.from of
|
||||
ResolvedRemoteNamesFrom'Branch -> That remoteBranchName
|
||||
ResolvedRemoteNamesFrom'Project -> This remoteProjectName
|
||||
ResolvedRemoteNamesFrom'ProjectAndBranch -> These remoteProjectName remoteBranchName
|
||||
Just localNames -> localNames
|
||||
where
|
||||
remoteBranchName = resolvedRemoteNames ^. #branch ^. #branchName
|
||||
remoteProjectName = resolvedRemoteNames ^. #branch ^. #projectName
|
||||
remoteBranchName = resolvedRemoteNames.branch.branchName
|
||||
remoteProjectName = resolvedRemoteNames.branch.projectName
|
||||
|
||||
resolve names =
|
||||
case names of
|
||||
@ -211,7 +206,7 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneLocal
|
||||
(ProjectAndBranch localProjectName remoteBranchName)
|
||||
(ProjectAndBranch (currentProject ^. #name) localBranchName)
|
||||
(ProjectAndBranch currentProject.name localBranchName)
|
||||
ProjectAndBranchNames'Unambiguous (This localProjectName) -> resolveP localProjectName
|
||||
ProjectAndBranchNames'Unambiguous (That localBranchName) -> resolveB localBranchName
|
||||
ProjectAndBranchNames'Unambiguous (These localProjectName localBranchName) -> resolvePB localProjectName localBranchName
|
||||
@ -237,28 +232,13 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
|
||||
-- it takes some time to pull the remote).
|
||||
cloneInto :: ProjectAndBranch LocalProjectKey ProjectBranchName -> Share.RemoteProjectBranch -> Cli ()
|
||||
cloneInto localProjectBranch remoteProjectBranch = do
|
||||
let remoteProjectName = remoteProjectBranch ^. #projectName
|
||||
let remoteBranchName = remoteProjectBranch ^. #branchName
|
||||
let remoteProjectName = remoteProjectBranch.projectName
|
||||
let remoteBranchName = remoteProjectBranch.branchName
|
||||
let remoteProjectBranchNames = ProjectAndBranch remoteProjectName remoteBranchName
|
||||
|
||||
-- Pull the remote branch's contents
|
||||
let remoteBranchHeadJwt = remoteProjectBranch ^. #branchHead
|
||||
(result, numDownloaded) <-
|
||||
Cli.with HandleInput.Pull.withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
|
||||
result <-
|
||||
Share.downloadEntities
|
||||
Share.hardCodedBaseUrl
|
||||
(Share.RepoInfo (into @Text remoteProjectBranchNames))
|
||||
remoteBranchHeadJwt
|
||||
downloadedCallback
|
||||
numDownloaded <- liftIO getNumDownloaded
|
||||
pure (result, numDownloaded)
|
||||
case result of
|
||||
Left err0 ->
|
||||
(Cli.returnEarly . Output.ShareError) case err0 of
|
||||
Share.SyncError err -> Output.ShareErrorDownloadEntities err
|
||||
Share.TransportError err -> Output.ShareErrorTransport err
|
||||
Right () -> Cli.respond (Output.DownloadedEntities numDownloaded)
|
||||
branchHead <-
|
||||
downloadProjectBranchFromShare Share.NoSquashedHead remoteProjectBranch
|
||||
& onLeftM (Cli.returnEarly . Output.ShareError)
|
||||
|
||||
localProjectAndBranch <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
@ -272,21 +252,21 @@ cloneInto localProjectBranch remoteProjectBranch = do
|
||||
localProjectId <- Sqlite.unsafeIO (ProjectId <$> UUID.nextRandom)
|
||||
Queries.insertProject localProjectId localProjectName
|
||||
pure (localProjectId, localProjectName)
|
||||
Right localProject -> pure (localProject ^. #projectId, localProject ^. #name)
|
||||
Right localProject -> pure (localProject.projectId, localProject.name)
|
||||
localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
|
||||
Queries.insertProjectBranch
|
||||
Sqlite.ProjectBranch
|
||||
{ projectId = localProjectId,
|
||||
branchId = localBranchId,
|
||||
name = localProjectBranch ^. #branch,
|
||||
name = localProjectBranch.branch,
|
||||
parentBranchId = Nothing
|
||||
}
|
||||
Queries.insertBranchRemoteMapping
|
||||
localProjectId
|
||||
localBranchId
|
||||
(remoteProjectBranch ^. #projectId)
|
||||
remoteProjectBranch.projectId
|
||||
Share.hardCodedUri
|
||||
(remoteProjectBranch ^. #branchId)
|
||||
remoteProjectBranch.branchId
|
||||
pure (ProjectAndBranch (localProjectId, localProjectName) localBranchId)
|
||||
|
||||
Cli.respond $
|
||||
@ -294,12 +274,11 @@ cloneInto localProjectBranch remoteProjectBranch = do
|
||||
remoteProjectBranchNames
|
||||
( ProjectAndBranch
|
||||
(localProjectAndBranch ^. #project . _2)
|
||||
(localProjectBranch ^. #branch)
|
||||
localProjectBranch.branch
|
||||
)
|
||||
|
||||
-- Manipulate the root namespace and cd
|
||||
Cli.Env {codebase} <- ask
|
||||
let branchHead = hash32ToCausalHash (Share.API.hashJWTHash remoteBranchHeadJwt)
|
||||
theBranch <- liftIO (Codebase.expectBranchForHash codebase branchHead)
|
||||
let path = projectBranchPath (over #project fst localProjectAndBranch)
|
||||
Cli.updateAt ("clone " <> into @Text remoteProjectBranchNames) path (const theBranch)
|
||||
@ -312,8 +291,8 @@ loadAssociatedRemoteProjectId ::
|
||||
loadAssociatedRemoteProjectId (ProjectAndBranch project branch) =
|
||||
fmap fst <$> Queries.loadRemoteProjectBranch projectId Share.hardCodedUri branchId
|
||||
where
|
||||
projectId = project ^. #projectId
|
||||
branchId = branch ^. #branchId
|
||||
projectId = project.projectId
|
||||
branchId = branch.branchId
|
||||
|
||||
assertProjectNameHasUserSlug :: ProjectName -> Cli ()
|
||||
assertProjectNameHasUserSlug projectName =
|
||||
@ -334,6 +313,6 @@ assertLocalProjectBranchDoesntExist rollback = \case
|
||||
ProjectAndBranch (LocalProjectKey'Project project) branchName -> go project branchName
|
||||
where
|
||||
go project branchName = do
|
||||
Queries.projectBranchExistsByName (project ^. #projectId) branchName & onTrueM do
|
||||
rollback (Output.ProjectAndBranchNameAlreadyExists (ProjectAndBranch (project ^. #name) branchName))
|
||||
Queries.projectBranchExistsByName project.projectId branchName & onTrueM do
|
||||
rollback (Output.ProjectAndBranchNameAlreadyExists (ProjectAndBranch project.name branchName))
|
||||
pure (Right project)
|
||||
|
@ -13,6 +13,7 @@ import System.Random.Shuffle qualified as RandomShuffle
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli (stepAt)
|
||||
@ -20,7 +21,6 @@ import Unison.Cli.ProjectUtils (projectBranchPath)
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.HandleInput.Pull qualified as Pull
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
@ -114,8 +114,8 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
Share.GetProjectBranchResponseBranchNotFound -> done Nothing
|
||||
Share.GetProjectBranchResponseProjectNotFound -> done Nothing
|
||||
Share.GetProjectBranchResponseSuccess branch -> pure branch
|
||||
let useSquashed = False
|
||||
Pull.downloadShareProjectBranch useSquashed baseLatestReleaseBranch
|
||||
downloadProjectBranchFromShare Share.NoSquashedHead baseLatestReleaseBranch
|
||||
& onLeftM (Cli.returnEarly . Output.ShareError)
|
||||
Cli.Env {codebase} <- ask
|
||||
baseLatestReleaseBranchObject <-
|
||||
liftIO $
|
||||
|
@ -1,37 +1,30 @@
|
||||
-- | @pull@ input handler
|
||||
module Unison.Codebase.Editor.HandleInput.Pull
|
||||
( doPullRemoteBranch,
|
||||
loadShareLooseCodeIntoMemory,
|
||||
( handlePull,
|
||||
loadPropagateDiffDefaultPatch,
|
||||
mergeBranchAndPropagateDefaultPatch,
|
||||
propagatePatch,
|
||||
downloadShareProjectBranch,
|
||||
withEntitiesDownloadedProgressCallback,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO)
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.List.NonEmpty qualified as Nel
|
||||
import Data.Text qualified as Text
|
||||
import Data.These
|
||||
import System.Console.Regions qualified as Console.Regions
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project)
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch)
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.DownloadUtils
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Cli.UnisonConfigUtils (resolveConfiguredUrl)
|
||||
import Unison.Codebase (Preprocessing (..))
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch (..))
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Merge qualified as Branch
|
||||
import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver)
|
||||
import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper)
|
||||
import Unison.Codebase.Editor.Input
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
@ -39,38 +32,48 @@ import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
|
||||
import Unison.Codebase.Editor.Propagate qualified as Propagate
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), ReadShareLooseCode (..), ShareUserHandle (..), printReadRemoteNamespace)
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace)
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Patch (Patch (..))
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.Codebase.SyncMode qualified as SyncMode
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
import Unison.CommandLine.InputPattern qualified as InputPattern
|
||||
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
||||
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName)
|
||||
import Unison.Share.API.Hash (HashJWT)
|
||||
import Unison.Share.API.Hash qualified as Share
|
||||
import Unison.Share.Codeserver qualified as Codeserver
|
||||
import Unison.Share.Sync qualified as Share
|
||||
import Unison.Share.Sync.Types qualified as Share
|
||||
import Unison.Share.Types (codeserverBaseURL)
|
||||
import Unison.Sync.Common qualified as Common
|
||||
import Unison.Sync.Types qualified as Share
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
doPullRemoteBranch :: PullSourceTarget -> SyncMode.SyncMode -> PullMode -> Verbosity.Verbosity -> Cli ()
|
||||
doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do
|
||||
handlePull :: PullSourceTarget -> PullMode -> Verbosity.Verbosity -> Cli ()
|
||||
handlePull unresolvedSourceAndTarget pullMode verbosity = do
|
||||
let includeSquashed = case pullMode of
|
||||
Input.PullWithHistory -> Share.NoSquashedHead
|
||||
Input.PullWithoutHistory -> Share.IncludeSquashedHead
|
||||
(source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget
|
||||
remoteBranchObject <- loadRemoteNamespaceIntoMemory syncMode pullMode source
|
||||
remoteBranchObject <- do
|
||||
Cli.Env {codebase} <- ask
|
||||
causalHash <-
|
||||
case source of
|
||||
ReadRemoteNamespaceGit repo -> do
|
||||
downloadLooseCodeFromGitRepo
|
||||
codebase
|
||||
( case pullMode of
|
||||
Input.PullWithHistory -> GitNamespaceHistoryTreatment'LetAlone
|
||||
Input.PullWithoutHistory -> GitNamespaceHistoryTreatment'DiscardAllHistory
|
||||
)
|
||||
repo
|
||||
& onLeftM (Cli.returnEarly . Output.GitError)
|
||||
ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError)
|
||||
ReadShare'ProjectBranch remoteBranch ->
|
||||
downloadProjectBranchFromShare
|
||||
( case pullMode of
|
||||
Input.PullWithHistory -> Share.NoSquashedHead
|
||||
Input.PullWithoutHistory -> Share.IncludeSquashedHead
|
||||
)
|
||||
remoteBranch
|
||||
& onLeftM (Cli.returnEarly . Output.ShareError)
|
||||
liftIO (Codebase.expectBranchForHash codebase causalHash)
|
||||
when (Branch.isEmpty0 (Branch.head remoteBranchObject)) do
|
||||
Cli.respond (PulledEmptyBranch source)
|
||||
targetAbsolutePath <-
|
||||
@ -178,7 +181,12 @@ resolveExplicitSource includeSquashed = \case
|
||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||
Just (remoteProjectId, _maybeProjectBranchId) -> do
|
||||
remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri)
|
||||
remoteBranchName <- resolveRemoteBranchName remoteProjectName branchNameOrLatestRelease
|
||||
remoteBranchName <-
|
||||
case branchNameOrLatestRelease of
|
||||
ProjectBranchNameOrLatestRelease'Name name -> pure name
|
||||
ProjectBranchNameOrLatestRelease'LatestRelease -> do
|
||||
remoteProject <- ProjectUtils.expectRemoteProjectById remoteProjectId remoteProjectName
|
||||
ProjectUtils.expectLatestReleaseBranchName remoteProject
|
||||
remoteProjectBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
includeSquashed
|
||||
@ -192,21 +200,15 @@ resolveExplicitSource includeSquashed = \case
|
||||
ReadShare'ProjectBranch (These projectName branchNameOrLatestRelease) -> do
|
||||
remoteProject <- ProjectUtils.expectRemoteProjectByName projectName
|
||||
let remoteProjectId = remoteProject ^. #projectId
|
||||
branchName <- resolveRemoteBranchName projectName branchNameOrLatestRelease
|
||||
branchName <-
|
||||
case branchNameOrLatestRelease of
|
||||
ProjectBranchNameOrLatestRelease'Name name -> pure name
|
||||
ProjectBranchNameOrLatestRelease'LatestRelease -> ProjectUtils.expectLatestReleaseBranchName remoteProject
|
||||
remoteProjectBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
includeSquashed
|
||||
(ProjectAndBranch (remoteProjectId, projectName) branchName)
|
||||
pure (ReadShare'ProjectBranch remoteProjectBranch)
|
||||
where
|
||||
resolveRemoteBranchName :: ProjectName -> ProjectBranchNameOrLatestRelease -> Cli ProjectBranchName
|
||||
resolveRemoteBranchName projectName = \case
|
||||
ProjectBranchNameOrLatestRelease'Name branchName -> pure branchName
|
||||
ProjectBranchNameOrLatestRelease'LatestRelease -> do
|
||||
remoteProject <- ProjectUtils.expectRemoteProjectByName projectName
|
||||
case remoteProject ^. #latestRelease of
|
||||
Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases projectName)
|
||||
Just semver -> pure (UnsafeProjectBranchName ("releases/" <> into @Text semver))
|
||||
|
||||
resolveImplicitTarget :: Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
resolveImplicitTarget =
|
||||
@ -214,85 +216,6 @@ resolveImplicitTarget =
|
||||
Nothing -> Left Path.currentPath
|
||||
Just (projectAndBranch, _restPath) -> Right projectAndBranch
|
||||
|
||||
loadRemoteNamespaceIntoMemory ::
|
||||
SyncMode ->
|
||||
PullMode ->
|
||||
ReadRemoteNamespace Share.RemoteProjectBranch ->
|
||||
Cli (Branch IO)
|
||||
loadRemoteNamespaceIntoMemory syncMode pullMode remoteNamespace = do
|
||||
Cli.Env {codebase} <- ask
|
||||
case remoteNamespace of
|
||||
ReadRemoteNamespaceGit repo -> do
|
||||
let preprocess = case pullMode of
|
||||
Input.PullWithHistory -> Unmodified
|
||||
Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory
|
||||
Cli.ioE (Codebase.importRemoteBranch codebase repo syncMode preprocess) \err ->
|
||||
Cli.returnEarly (Output.GitError err)
|
||||
ReadShare'LooseCode repo -> loadShareLooseCodeIntoMemory repo
|
||||
ReadShare'ProjectBranch remoteBranch -> do
|
||||
projectBranchCausalHashJWT <- downloadShareProjectBranch (pullMode == Input.PullWithoutHistory) remoteBranch
|
||||
let causalHash = Common.hash32ToCausalHash (Share.hashJWTHash projectBranchCausalHashJWT)
|
||||
liftIO (Codebase.expectBranchForHash codebase causalHash)
|
||||
|
||||
-- | @downloadShareProjectBranch branch@ downloads the given branch.
|
||||
downloadShareProjectBranch :: HasCallStack => Bool -> Share.RemoteProjectBranch -> Cli HashJWT
|
||||
downloadShareProjectBranch useSquashedIfAvailable branch = do
|
||||
let remoteProjectBranchName = branch ^. #branchName
|
||||
let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch (branch ^. #projectName) remoteProjectBranchName))
|
||||
causalHashJwt <-
|
||||
if useSquashedIfAvailable
|
||||
then case (branch ^. #squashedBranchHead) of
|
||||
Nothing -> Cli.returnEarly (Output.ShareError ShareExpectedSquashedHead)
|
||||
Just squashedHead -> pure squashedHead
|
||||
else pure (branch ^. #branchHead)
|
||||
exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt))
|
||||
when (not exists) do
|
||||
(result, numDownloaded) <-
|
||||
Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
|
||||
result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback
|
||||
numDownloaded <- liftIO getNumDownloaded
|
||||
pure (result, numDownloaded)
|
||||
result & onLeft \err0 -> do
|
||||
(Cli.returnEarly . Output.ShareError) case err0 of
|
||||
Share.SyncError err -> Output.ShareErrorDownloadEntities err
|
||||
Share.TransportError err -> Output.ShareErrorTransport err
|
||||
Cli.respond (Output.DownloadedEntities numDownloaded)
|
||||
pure causalHashJwt
|
||||
|
||||
loadShareLooseCodeIntoMemory :: ReadShareLooseCode -> Cli (Branch IO)
|
||||
loadShareLooseCodeIntoMemory rrn@(ReadShareLooseCode {server, repo, path}) = do
|
||||
let codeserver = Codeserver.resolveCodeserver server
|
||||
let baseURL = codeserverBaseURL codeserver
|
||||
-- Auto-login to share if pulling from a non-public path
|
||||
when (not $ RemoteRepo.isPublic rrn) . void $ ensureAuthenticatedWithCodeserver codeserver
|
||||
let shareFlavoredPath = Share.Path (shareUserHandleToText repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path))
|
||||
Cli.Env {codebase} <- ask
|
||||
(causalHash, numDownloaded) <-
|
||||
Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
|
||||
causalHash <-
|
||||
Share.pull baseURL shareFlavoredPath downloadedCallback & onLeftM \err0 ->
|
||||
(Cli.returnEarly . Output.ShareError) case err0 of
|
||||
Share.SyncError err -> Output.ShareErrorPull err
|
||||
Share.TransportError err -> Output.ShareErrorTransport err
|
||||
numDownloaded <- liftIO getNumDownloaded
|
||||
pure (causalHash, numDownloaded)
|
||||
Cli.respond (Output.DownloadedEntities numDownloaded)
|
||||
liftIO (Codebase.expectBranchForHash codebase causalHash)
|
||||
|
||||
-- Provide the given action a callback that display to the terminal.
|
||||
withEntitiesDownloadedProgressCallback :: ((Int -> IO (), IO Int) -> IO a) -> IO a
|
||||
withEntitiesDownloadedProgressCallback action = do
|
||||
entitiesDownloadedVar <- newTVarIO 0
|
||||
Console.Regions.displayConsoleRegions do
|
||||
Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do
|
||||
Console.Regions.setConsoleRegion region do
|
||||
entitiesDownloaded <- readTVar entitiesDownloadedVar
|
||||
pure $
|
||||
"\n Downloaded "
|
||||
<> tShow entitiesDownloaded
|
||||
<> " entities...\n\n"
|
||||
action ((\n -> atomically (modifyTVar' entitiesDownloadedVar (+ n))), readTVarIO entitiesDownloadedVar)
|
||||
|
||||
-- | supply `dest0` if you want to print diff messages
|
||||
-- supply unchangedMessage if you want to display it if merge had no effect
|
||||
mergeBranchAndPropagateDefaultPatch ::
|
||||
|
@ -26,7 +26,6 @@ import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Cli.UnisonConfigUtils qualified as UnisonConfigUtils
|
||||
import Unison.Codebase (PushGitBranchOpts (..))
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch (..))
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
@ -52,8 +51,6 @@ import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import Unison.Codebase.PushBehavior qualified as PushBehavior
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.Codebase.SyncMode qualified as SyncMode
|
||||
import Unison.Codebase.Type (GitPushBehavior (..))
|
||||
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
|
||||
import Unison.Hash qualified as Hash
|
||||
@ -84,13 +81,8 @@ handleGist :: GistInput -> Cli ()
|
||||
handleGist (GistInput repo) = do
|
||||
Cli.Env {codebase} <- ask
|
||||
sourceBranch <- Cli.getCurrentBranch
|
||||
let opts =
|
||||
PushGitBranchOpts
|
||||
{ behavior = GitPushBehaviorGist,
|
||||
syncMode = SyncMode.ShortCircuit
|
||||
}
|
||||
result <-
|
||||
Cli.ioE (Codebase.pushGitBranch codebase repo opts (\_remoteRoot -> pure (Right sourceBranch))) \err ->
|
||||
Cli.ioE (Codebase.pushGitBranch codebase repo GitPushBehaviorGist (\_remoteRoot -> pure (Right sourceBranch))) \err ->
|
||||
Cli.returnEarly (Output.GitError err)
|
||||
_branch <- result & onLeft Cli.returnEarly
|
||||
schLength <- Cli.runTransaction Codebase.branchHashLength
|
||||
@ -105,7 +97,7 @@ handleGist (GistInput repo) = do
|
||||
|
||||
-- | Handle a @push@ command.
|
||||
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
|
||||
handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior, syncMode} = do
|
||||
handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||
case sourceTarget of
|
||||
-- push <implicit> to <implicit>
|
||||
PushSourceTarget0 ->
|
||||
@ -113,7 +105,7 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior, syncMo
|
||||
Nothing -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case
|
||||
WriteRemoteNamespaceGit namespace -> pushLooseCodeToGitLooseCode localPath namespace pushBehavior syncMode
|
||||
WriteRemoteNamespaceGit namespace -> pushLooseCodeToGitLooseCode localPath namespace pushBehavior
|
||||
WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
Just (localProjectAndBranch, _restPath) ->
|
||||
@ -124,7 +116,7 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior, syncMo
|
||||
-- push <implicit> to .some.path (git)
|
||||
PushSourceTarget1 (WriteRemoteNamespaceGit namespace) -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
pushLooseCodeToGitLooseCode localPath namespace pushBehavior syncMode
|
||||
pushLooseCodeToGitLooseCode localPath namespace pushBehavior
|
||||
-- push <implicit> to .some.path (share)
|
||||
PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
@ -141,7 +133,7 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior, syncMo
|
||||
-- push .some.path to .some.path (git)
|
||||
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceGit namespace) -> do
|
||||
localPath <- Cli.resolvePath' localPath0
|
||||
pushLooseCodeToGitLooseCode localPath namespace pushBehavior syncMode
|
||||
pushLooseCodeToGitLooseCode localPath namespace pushBehavior
|
||||
-- push .some.path to .some.path (share)
|
||||
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do
|
||||
localPath <- Cli.resolvePath' localPath0
|
||||
@ -158,7 +150,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior, syncMo
|
||||
(ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
namespace
|
||||
pushBehavior
|
||||
syncMode
|
||||
-- push @some/project to .some.path (share)
|
||||
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do
|
||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
|
||||
@ -178,8 +169,8 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior, syncMo
|
||||
PushBehavior.RequireNonEmpty -> False
|
||||
|
||||
-- Push a local namespace ("loose code") to a Git-hosted remote namespace ("loose code").
|
||||
pushLooseCodeToGitLooseCode :: Path.Absolute -> WriteGitRemoteNamespace -> PushBehavior -> SyncMode -> Cli ()
|
||||
pushLooseCodeToGitLooseCode localPath gitRemotePath pushBehavior syncMode = do
|
||||
pushLooseCodeToGitLooseCode :: Path.Absolute -> WriteGitRemoteNamespace -> PushBehavior -> Cli ()
|
||||
pushLooseCodeToGitLooseCode localPath gitRemotePath pushBehavior = do
|
||||
sourceBranch <- Cli.getBranchAt localPath
|
||||
let withRemoteRoot :: Branch IO -> Either Output (Branch IO)
|
||||
withRemoteRoot remoteRoot = do
|
||||
@ -190,21 +181,17 @@ pushLooseCodeToGitLooseCode localPath gitRemotePath pushBehavior syncMode = do
|
||||
case Branch.modifyAtM (gitRemotePath ^. #path) f remoteRoot of
|
||||
Nothing -> Left (RefusedToPush pushBehavior (WriteRemoteNamespaceGit gitRemotePath))
|
||||
Just newRemoteRoot -> Right newRemoteRoot
|
||||
let opts =
|
||||
PushGitBranchOpts
|
||||
{ behavior =
|
||||
case pushBehavior of
|
||||
PushBehavior.ForcePush -> GitPushBehaviorForce
|
||||
PushBehavior.RequireEmpty -> GitPushBehaviorFf
|
||||
PushBehavior.RequireNonEmpty -> GitPushBehaviorFf,
|
||||
syncMode
|
||||
}
|
||||
let behavior =
|
||||
case pushBehavior of
|
||||
PushBehavior.ForcePush -> GitPushBehaviorForce
|
||||
PushBehavior.RequireEmpty -> GitPushBehaviorFf
|
||||
PushBehavior.RequireNonEmpty -> GitPushBehaviorFf
|
||||
Cli.Env {codebase} <- ask
|
||||
let push =
|
||||
Codebase.pushGitBranch
|
||||
codebase
|
||||
(gitRemotePath ^. #repo)
|
||||
opts
|
||||
behavior
|
||||
(\remoteRoot -> pure (withRemoteRoot remoteRoot))
|
||||
result <-
|
||||
liftIO push & onLeftM \err ->
|
||||
|
@ -41,7 +41,6 @@ import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.Codebase.Verbosity (Verbosity)
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath)
|
||||
import Unison.HashQualified qualified as HQ
|
||||
@ -115,7 +114,7 @@ data Input
|
||||
MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode
|
||||
| PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject
|
||||
| DiffNamespaceI BranchId BranchId -- old new
|
||||
| PullRemoteBranchI PullSourceTarget SyncMode PullMode Verbosity
|
||||
| PullRemoteBranchI PullSourceTarget PullMode Verbosity
|
||||
| PushRemoteBranchI PushRemoteBranchInput
|
||||
| ResetRootI (Either ShortCausalHash Path')
|
||||
| ResetI
|
||||
@ -244,6 +243,7 @@ data Input
|
||||
| EditNamespaceI [Path.Path]
|
||||
| -- New merge algorithm: merge the given project branch into the current one.
|
||||
MergeI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
||||
| LibInstallI !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease))
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | The source of a `branch` command: what to make the new branch from.
|
||||
@ -293,8 +293,7 @@ data PushSourceTarget
|
||||
|
||||
data PushRemoteBranchInput = PushRemoteBranchInput
|
||||
{ sourceTarget :: PushSourceTarget,
|
||||
pushBehavior :: PushBehavior,
|
||||
syncMode :: SyncMode
|
||||
pushBehavior :: PushBehavior
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
|
@ -408,6 +408,7 @@ data Output
|
||||
| MergeMissingConstructorName !Name
|
||||
| MergeNestedDeclAlias !Name !Name
|
||||
| MergeStrayConstructor !Name
|
||||
| InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment
|
||||
|
||||
data UpdateOrUpgrade = UOUUpdate | UOUUpgrade
|
||||
|
||||
@ -649,6 +650,7 @@ isFailure o = case o of
|
||||
MergeMissingConstructorName {} -> True
|
||||
MergeNestedDeclAlias {} -> True
|
||||
MergeStrayConstructor {} -> True
|
||||
InstalledLibdep {} -> False
|
||||
|
||||
isNumberedFailure :: NumberedOutput -> Bool
|
||||
isNumberedFailure = \case
|
||||
|
@ -41,7 +41,6 @@ import Unison.Codebase.Editor.UriParser qualified as UriParser
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.PushBehavior qualified as PushBehavior
|
||||
import Unison.Codebase.SyncMode qualified as SyncMode
|
||||
import Unison.Codebase.Verbosity (Verbosity)
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
import Unison.CommandLine
|
||||
@ -57,7 +56,15 @@ import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectBranchNameOrLatestRelease (..), ProjectBranchSpecifier (..), ProjectName, Semver)
|
||||
import Unison.Project
|
||||
( ProjectAndBranch (..),
|
||||
ProjectAndBranchNames (..),
|
||||
ProjectBranchName,
|
||||
ProjectBranchNameOrLatestRelease (..),
|
||||
ProjectBranchSpecifier (..),
|
||||
ProjectName,
|
||||
Semver,
|
||||
)
|
||||
import Unison.Project.Util (ProjectContext (..), projectContextFromPath)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (parseText)
|
||||
import Unison.Syntax.Name qualified as Name (parseText, unsafeParseText)
|
||||
@ -1223,6 +1230,28 @@ forkLocal =
|
||||
pure $ Input.ForkLocalBranchI src dest
|
||||
_ -> Left (I.help forkLocal)
|
||||
|
||||
libInstallInputPattern :: InputPattern
|
||||
libInstallInputPattern =
|
||||
InputPattern
|
||||
{ patternName = "lib.install",
|
||||
aliases = ["install.lib"],
|
||||
visibility = I.Visible,
|
||||
args = [],
|
||||
help =
|
||||
P.wrapColumn2
|
||||
[ ( makeExample libInstallInputPattern ["@unison/base/releases/latest"],
|
||||
"installs `@unison/base/releases/latest` as a dependency of the current project"
|
||||
)
|
||||
],
|
||||
parse = \args ->
|
||||
maybe (Left (I.help libInstallInputPattern)) Right do
|
||||
[arg] <- Just args
|
||||
libdep <-
|
||||
eitherToMaybe $
|
||||
tryInto @(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) (Text.pack arg)
|
||||
Just (Input.LibInstallI libdep)
|
||||
}
|
||||
|
||||
reset :: InputPattern
|
||||
reset =
|
||||
InputPattern
|
||||
@ -1362,68 +1391,21 @@ pullImpl name aliases verbosity pullMode addendum = do
|
||||
],
|
||||
parse =
|
||||
maybeToEither (I.help self) . \case
|
||||
[] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 SyncMode.ShortCircuit pullMode verbosity
|
||||
[] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 pullMode verbosity
|
||||
[sourceString] -> do
|
||||
source <- parsePullSource (Text.pack sourceString)
|
||||
Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) SyncMode.ShortCircuit pullMode verbosity
|
||||
Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) pullMode verbosity
|
||||
[sourceString, targetString] -> do
|
||||
source <- parsePullSource (Text.pack sourceString)
|
||||
target <- parseLooseCodeOrProject targetString
|
||||
Just $
|
||||
Input.PullRemoteBranchI
|
||||
(Input.PullSourceTarget2 source target)
|
||||
SyncMode.ShortCircuit
|
||||
pullMode
|
||||
verbosity
|
||||
_ -> Nothing
|
||||
}
|
||||
|
||||
pullExhaustive :: InputPattern
|
||||
pullExhaustive =
|
||||
InputPattern
|
||||
"debug.pull-exhaustive"
|
||||
[]
|
||||
I.Hidden
|
||||
[("remote namespace to pull", Optional, remoteNamespaceArg), ("destination namespace", Optional, namespaceArg)]
|
||||
( P.lines
|
||||
[ P.wrap $
|
||||
"The "
|
||||
<> makeExample' pullExhaustive
|
||||
<> "command can be used in place of"
|
||||
<> makeExample' pullVerbose
|
||||
<> "to complete namespaces"
|
||||
<> "which were pulled incompletely due to a bug in UCM"
|
||||
<> "versions M1l and earlier. It may be extra slow!"
|
||||
]
|
||||
)
|
||||
( maybeToEither (I.help pullExhaustive) . \case
|
||||
[] ->
|
||||
Just $
|
||||
Input.PullRemoteBranchI
|
||||
Input.PullSourceTarget0
|
||||
SyncMode.Complete
|
||||
Input.PullWithHistory
|
||||
Verbosity.Verbose
|
||||
[sourceString] -> do
|
||||
source <- parsePullSource (Text.pack sourceString)
|
||||
Just $
|
||||
Input.PullRemoteBranchI
|
||||
(Input.PullSourceTarget1 source)
|
||||
SyncMode.Complete
|
||||
Input.PullWithHistory
|
||||
Verbosity.Verbose
|
||||
[sourceString, targetString] -> do
|
||||
source <- parsePullSource (Text.pack sourceString)
|
||||
target <- parseLooseCodeOrProject targetString
|
||||
Just $
|
||||
Input.PullRemoteBranchI
|
||||
(Input.PullSourceTarget2 source target)
|
||||
SyncMode.Complete
|
||||
Input.PullWithHistory
|
||||
Verbosity.Verbose
|
||||
_ -> Nothing
|
||||
)
|
||||
|
||||
debugTabCompletion :: InputPattern
|
||||
debugTabCompletion =
|
||||
InputPattern
|
||||
@ -1524,8 +1506,7 @@ push =
|
||||
Input.PushRemoteBranchI
|
||||
Input.PushRemoteBranchInput
|
||||
{ sourceTarget,
|
||||
pushBehavior = PushBehavior.RequireNonEmpty,
|
||||
syncMode = SyncMode.ShortCircuit
|
||||
pushBehavior = PushBehavior.RequireNonEmpty
|
||||
}
|
||||
where
|
||||
suggestionsConfig =
|
||||
@ -1580,8 +1561,7 @@ pushCreate =
|
||||
Input.PushRemoteBranchI
|
||||
Input.PushRemoteBranchInput
|
||||
{ sourceTarget,
|
||||
pushBehavior = PushBehavior.RequireEmpty,
|
||||
syncMode = SyncMode.ShortCircuit
|
||||
pushBehavior = PushBehavior.RequireEmpty
|
||||
}
|
||||
where
|
||||
suggestionsConfig =
|
||||
@ -1615,8 +1595,7 @@ pushForce =
|
||||
Input.PushRemoteBranchI
|
||||
Input.PushRemoteBranchInput
|
||||
{ sourceTarget,
|
||||
pushBehavior = PushBehavior.ForcePush,
|
||||
syncMode = SyncMode.ShortCircuit
|
||||
pushBehavior = PushBehavior.ForcePush
|
||||
}
|
||||
where
|
||||
suggestionsConfig =
|
||||
@ -1660,8 +1639,7 @@ pushExhaustive =
|
||||
Input.PushRemoteBranchI
|
||||
Input.PushRemoteBranchInput
|
||||
{ sourceTarget,
|
||||
pushBehavior = PushBehavior.RequireNonEmpty,
|
||||
syncMode = SyncMode.Complete
|
||||
pushBehavior = PushBehavior.RequireNonEmpty
|
||||
}
|
||||
where
|
||||
suggestionsConfig =
|
||||
@ -2598,7 +2576,7 @@ runScheme =
|
||||
InputPattern
|
||||
"run.native"
|
||||
[]
|
||||
I.Hidden
|
||||
I.Visible
|
||||
[("definition to run", Required, exactDefinitionTermQueryArg), ("arguments", ZeroPlus, noCompletionsArg)]
|
||||
( P.wrapColumn2
|
||||
[ ( makeExample runScheme ["main", "args"],
|
||||
@ -3090,6 +3068,7 @@ validInputs =
|
||||
history,
|
||||
ioTest,
|
||||
ioTestAll,
|
||||
libInstallInputPattern,
|
||||
load,
|
||||
makeStandalone,
|
||||
mergeBuiltins,
|
||||
@ -3111,7 +3090,6 @@ validInputs =
|
||||
projectSwitch,
|
||||
projectsInputPattern,
|
||||
pull,
|
||||
pullExhaustive,
|
||||
pullVerbose,
|
||||
pullWithoutHistory,
|
||||
push,
|
||||
|
@ -1339,25 +1339,6 @@ notifyUser dir = \case
|
||||
push = P.group . P.backticked . IP.patternName $ IP.push
|
||||
pull = P.group . P.backticked . IP.patternName $ IP.pull
|
||||
GitCodebaseError e -> case e of
|
||||
CouldntParseRemoteBranch repo s ->
|
||||
P.wrap $
|
||||
"I couldn't decode the root branch "
|
||||
<> P.string s
|
||||
<> "from the repository at"
|
||||
<> prettyReadGitRepo repo
|
||||
CouldntLoadRootBranch repo hash ->
|
||||
P.wrap $
|
||||
"I couldn't load the designated root hash"
|
||||
<> P.group ("(" <> P.text (Hash.toBase32HexText $ unCausalHash hash) <> ")")
|
||||
<> "from the repository at"
|
||||
<> prettyReadGitRepo repo
|
||||
CouldntLoadSyncedBranch ns h ->
|
||||
P.wrap $
|
||||
"I just finished importing the branch"
|
||||
<> P.red (P.shown h)
|
||||
<> "from"
|
||||
<> P.red (prettyReadRemoteNamespaceWith absurd (RemoteRepo.ReadRemoteNamespaceGit ns))
|
||||
<> "but now I can't find it."
|
||||
CouldntFindRemoteBranch repo path ->
|
||||
P.wrap $
|
||||
"I couldn't find the remote branch at"
|
||||
@ -2299,6 +2280,12 @@ notifyUser dir = \case
|
||||
<> prettyProjectBranchName (view #branch target)
|
||||
<> "into"
|
||||
<> P.group (prettyProjectBranchName (view #branch base) <> ".")
|
||||
InstalledLibdep libdep segment ->
|
||||
pure . P.wrap $
|
||||
"I installed"
|
||||
<> prettyProjectAndBranchName libdep
|
||||
<> "as"
|
||||
<> P.group (P.text (NameSegment.toEscapedText segment) <> ".")
|
||||
|
||||
expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty
|
||||
expectedEmptyPushDest namespace =
|
||||
|
@ -37,7 +37,6 @@ import Unison.LSP.Conversions qualified as Cv
|
||||
import Unison.LSP.Diagnostics (DiagnosticSeverity (..), mkDiagnostic, reportDiagnostics)
|
||||
import Unison.LSP.Orphans ()
|
||||
import Unison.LSP.Types
|
||||
import Unison.LSP.Types qualified as LSP
|
||||
import Unison.LSP.VFS qualified as VFS
|
||||
import Unison.Name (Name)
|
||||
import Unison.Names (Names)
|
||||
@ -104,7 +103,8 @@ checkFile doc = runMaybeT do
|
||||
typecheckingEnv <- computeTypecheckingEnvironment (ShouldUseTndr'Yes parsingEnv) cb ambientAbilities parsedFile
|
||||
let Result.Result typecheckingNotes maybeTypecheckedFile = FileParsers.synthesizeFile typecheckingEnv parsedFile
|
||||
pure (typecheckingNotes, Just parsedFile, maybeTypecheckedFile)
|
||||
(errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText notes
|
||||
filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile
|
||||
(errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText filePPED notes
|
||||
let codeActionRanges =
|
||||
codeActions
|
||||
& foldMap (\(RangedCodeAction {_codeActionRanges, _codeAction}) -> (,_codeAction) <$> _codeActionRanges)
|
||||
@ -155,10 +155,10 @@ fileAnalysisWorker = forever do
|
||||
for freshlyCheckedFiles \(FileAnalysis {fileUri, fileVersion, diagnostics}) -> do
|
||||
reportDiagnostics fileUri (Just fileVersion) $ fold diagnostics
|
||||
|
||||
analyseFile :: (Foldable f) => Uri -> Text -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction])
|
||||
analyseFile fileUri srcText notes = do
|
||||
pped <- PPED.suffixifiedPPE <$> LSP.currentPPED
|
||||
(noteDiags, noteActions) <- analyseNotes fileUri pped (Text.unpack srcText) notes
|
||||
analyseFile :: (Foldable f) => Uri -> Text -> PPED.PrettyPrintEnvDecl -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction])
|
||||
analyseFile fileUri srcText pped notes = do
|
||||
let ppe = PPED.suffixifiedPPE pped
|
||||
(noteDiags, noteActions) <- analyseNotes fileUri ppe (Text.unpack srcText) notes
|
||||
pure (noteDiags, noteActions)
|
||||
|
||||
-- | Returns diagnostics which show a warning diagnostic when editing a term that's conflicted in the
|
||||
@ -357,7 +357,6 @@ analyseNotes fileUri ppe src notes = do
|
||||
| not (isUserBlank v) = pure []
|
||||
| otherwise = do
|
||||
Env {codebase} <- ask
|
||||
ppe <- PPED.suffixifiedPPE <$> currentPPED
|
||||
let cleanedTyp = Context.generalizeAndUnTypeVar typ -- TODO: is this right?
|
||||
refs <- liftIO . Codebase.runTransaction codebase $ Codebase.termsOfType codebase cleanedTyp
|
||||
forMaybe (toList refs) $ \ref -> runMaybeT $ do
|
||||
|
@ -28,24 +28,24 @@ ucmWorker ::
|
||||
STM CausalHash ->
|
||||
STM Path.Absolute ->
|
||||
Lsp ()
|
||||
ucmWorker ppedVar parseNamesVar nameSearchCacheVar currentPathVar getLatestRoot getLatestPath = do
|
||||
ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoot getLatestPath = do
|
||||
Env {codebase, completionsVar} <- ask
|
||||
let loop :: (CausalHash, Path.Absolute) -> Lsp a
|
||||
loop (currentRoot, currentPath) = do
|
||||
Debug.debugM Debug.LSP "LSP path: " currentPath
|
||||
currentBranch0 <- fmap Branch.head . liftIO $ (Codebase.getBranchAtPath codebase currentPath)
|
||||
let parseNames = Branch.toNames currentBranch0
|
||||
let currentNames = Branch.toNames currentBranch0
|
||||
hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength
|
||||
let pped = PPED.makePPED (PPE.hqNamer hl parseNames) (PPE.suffixifyByHash parseNames)
|
||||
let pped = PPED.makePPED (PPE.hqNamer hl currentNames) (PPE.suffixifyByHash currentNames)
|
||||
atomically $ do
|
||||
writeTMVar currentPathVar currentPath
|
||||
writeTMVar parseNamesVar parseNames
|
||||
writeTMVar currentNamesVar currentNames
|
||||
writeTMVar ppedVar pped
|
||||
writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl parseNames)
|
||||
writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl currentNames)
|
||||
-- Re-check everything with the new names and ppe
|
||||
VFS.markAllFilesDirty
|
||||
atomically do
|
||||
writeTMVar completionsVar (namesToCompletionTree parseNames)
|
||||
writeTMVar completionsVar (namesToCompletionTree currentNames)
|
||||
Debug.debugLogM Debug.LSP "LSP Initialized"
|
||||
latest <- atomically $ do
|
||||
latestRoot <- getLatestRoot
|
||||
|
@ -34,6 +34,7 @@ library
|
||||
Unison.Auth.Tokens
|
||||
Unison.Auth.Types
|
||||
Unison.Auth.UserInfo
|
||||
Unison.Cli.DownloadUtils
|
||||
Unison.Cli.Monad
|
||||
Unison.Cli.MonadUtils
|
||||
Unison.Cli.NamesUtils
|
||||
@ -60,6 +61,7 @@ library
|
||||
Unison.Codebase.Editor.HandleInput.EditNamespace
|
||||
Unison.Codebase.Editor.HandleInput.FindAndReplace
|
||||
Unison.Codebase.Editor.HandleInput.FormatFile
|
||||
Unison.Codebase.Editor.HandleInput.InstallLib
|
||||
Unison.Codebase.Editor.HandleInput.Load
|
||||
Unison.Codebase.Editor.HandleInput.Merge2
|
||||
Unison.Codebase.Editor.HandleInput.MoveAll
|
||||
|
@ -7,6 +7,7 @@
|
||||
module Unison.Project
|
||||
( ProjectName,
|
||||
projectNameUserSlug,
|
||||
projectNameToUserProjectSlugs,
|
||||
prependUserSlugToProjectName,
|
||||
ProjectBranchName,
|
||||
projectBranchNameUserSlug,
|
||||
@ -82,6 +83,21 @@ projectNameUserSlug (UnsafeProjectName projectName) =
|
||||
then Just (Text.takeWhile (/= '/') (Text.drop 1 projectName))
|
||||
else Nothing
|
||||
|
||||
-- | Parse a "@arya/lens" into the "arya" and "lens" parts.
|
||||
--
|
||||
-- If there's no "arya" part, returns the empty string there.
|
||||
--
|
||||
-- >>> projectNameToUserProjectSlugs (UnsafeProjectName "@arya/lens")
|
||||
-- ("arya","lens")
|
||||
--
|
||||
-- >>> projectNameToUserProjectSlugs (UnsafeProjectName "lens")
|
||||
-- ("","lens")
|
||||
projectNameToUserProjectSlugs :: ProjectName -> (Text, Text)
|
||||
projectNameToUserProjectSlugs (UnsafeProjectName name) =
|
||||
case Text.span (/= '/') name of
|
||||
(project, "") -> ("", project)
|
||||
(atUser, slashProject) -> (Text.drop 1 atUser, Text.drop 1 slashProject)
|
||||
|
||||
-- | Prepend a user slug to a project name, if it doesn't already have one.
|
||||
--
|
||||
-- >>> prependUserSlugToProjectName "arya" "lens"
|
||||
@ -289,6 +305,15 @@ data ProjectBranchSpecifier :: Type -> Type where
|
||||
-- | By name, or "the latest release"
|
||||
ProjectBranchSpecifier'NameOrLatestRelease :: ProjectBranchSpecifier ProjectBranchNameOrLatestRelease
|
||||
|
||||
projectBranchSpecifierParser :: ProjectBranchSpecifier branch -> Megaparsec.Parsec Void Text branch
|
||||
projectBranchSpecifierParser = \case
|
||||
ProjectBranchSpecifier'Name -> projectBranchNameParser False
|
||||
ProjectBranchSpecifier'NameOrLatestRelease ->
|
||||
asum
|
||||
[ ProjectBranchNameOrLatestRelease'LatestRelease <$ "releases/latest",
|
||||
ProjectBranchNameOrLatestRelease'Name <$> projectBranchNameParser False
|
||||
]
|
||||
|
||||
instance From (ProjectAndBranch ProjectName ProjectBranchName) Text where
|
||||
from (ProjectAndBranch project branch) =
|
||||
Text.Builder.run $
|
||||
@ -377,25 +402,15 @@ projectAndBranchNamesParser specifier = do
|
||||
optional projectNameParser >>= \case
|
||||
Nothing -> do
|
||||
_ <- Megaparsec.char '/'
|
||||
branch <- branchParser
|
||||
branch <- projectBranchSpecifierParser specifier
|
||||
pure (That branch)
|
||||
Just (project, hasTrailingSlash) ->
|
||||
if hasTrailingSlash
|
||||
then do
|
||||
optional branchParser <&> \case
|
||||
optional (projectBranchSpecifierParser specifier) <&> \case
|
||||
Nothing -> This project
|
||||
Just branch -> These project branch
|
||||
else pure (This project)
|
||||
where
|
||||
branchParser :: Megaparsec.Parsec Void Text branch
|
||||
branchParser =
|
||||
case specifier of
|
||||
ProjectBranchSpecifier'Name -> projectBranchNameParser False
|
||||
ProjectBranchSpecifier'NameOrLatestRelease ->
|
||||
asum
|
||||
[ ProjectBranchNameOrLatestRelease'LatestRelease <$ "releases/latest",
|
||||
ProjectBranchNameOrLatestRelease'Name <$> projectBranchNameParser False
|
||||
]
|
||||
|
||||
-- | @project/branch@ syntax, where the branch is optional.
|
||||
instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where
|
||||
@ -409,25 +424,34 @@ instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text wher
|
||||
|
||||
instance TryFrom Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) where
|
||||
tryFrom =
|
||||
maybeTryFrom (Megaparsec.parseMaybe projectWithOptionalBranchParser)
|
||||
maybeTryFrom (Megaparsec.parseMaybe (projectAndOptionalBranchParser ProjectBranchSpecifier'Name))
|
||||
|
||||
-- | Attempt to parse a project and branch name from a string where both are required.
|
||||
instance TryFrom Text (ProjectAndBranch ProjectName ProjectBranchName) where
|
||||
tryFrom =
|
||||
maybeTryFrom $ \txt -> do
|
||||
ProjectAndBranch projectName mayBranchName <- Megaparsec.parseMaybe projectWithOptionalBranchParser txt
|
||||
ProjectAndBranch projectName mayBranchName <- Megaparsec.parseMaybe (projectAndOptionalBranchParser ProjectBranchSpecifier'Name) txt
|
||||
ProjectAndBranch projectName <$> mayBranchName
|
||||
|
||||
instance TryFrom Text (ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) where
|
||||
tryFrom =
|
||||
maybeTryFrom (Megaparsec.parseMaybe (projectAndOptionalBranchParser ProjectBranchSpecifier'NameOrLatestRelease))
|
||||
|
||||
-- Valid things:
|
||||
--
|
||||
-- 1. project
|
||||
-- 2. project/
|
||||
-- 3. project/branch
|
||||
projectWithOptionalBranchParser :: Megaparsec.Parsec Void Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
|
||||
projectWithOptionalBranchParser = do
|
||||
projectAndOptionalBranchParser ::
|
||||
forall branch.
|
||||
ProjectBranchSpecifier branch ->
|
||||
Megaparsec.Parsec Void Text (ProjectAndBranch ProjectName (Maybe branch))
|
||||
projectAndOptionalBranchParser specifier = do
|
||||
(project, hasTrailingSlash) <- projectNameParser
|
||||
branch <- if hasTrailingSlash then optional (projectBranchNameParser False) else pure Nothing
|
||||
pure (ProjectAndBranch project branch)
|
||||
fmap (ProjectAndBranch project) $
|
||||
if hasTrailingSlash
|
||||
then optional (projectBranchSpecifierParser specifier)
|
||||
else pure Nothing
|
||||
|
||||
-- | @project/branch@ syntax, where the project is optional. The branch can optionally be preceded by a forward slash.
|
||||
instance From (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) Text where
|
||||
|
Loading…
Reference in New Issue
Block a user