unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 10:35:57 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'upstream/trunk' into structured-numbered-args

Browse Source
This commit is contained in:
Greg Pfeil 2024-05-29 16:28:32 -06:00
commit e9d2a21d8a
No known key found for this signature in database
GPG Key ID: 1193ACD196ED61F2
39 changed files with 563 additions and 2412 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
.editorconfig Normal file
View File

@ -0,0 +1,11 @@
# Multi-editor style config: https://EditorConfig.org
root = true
[*]
charset = utf-8
end_of_line = lf
indent_style = space
insert_final_newline = true
max_line_length = 120
trim_trailing_whitespace = true

4
.gitignore vendored
View File

@ -24,5 +24,7 @@ dist-newstyle
# Mac developers
**/.DS_Store
/libb2.dylib
# Nix
result

16
development.markdown
View File

@ -126,9 +126,9 @@ This is specified with the normal
Some examples:
```
nix build '.#haskell-nix.unison-cli:lib:unison-cli'
nix build '.#haskell-nix.unison-syntax:test:syntax-tests'
nix build '.#haskell-nix.unison-cli:exe:transcripts'
nix build '.#component-unison-cli:lib:unison-cli'
nix build '.#component-unison-syntax:test:syntax-tests'
nix build '.#component-unison-cli:exe:transcripts'
```
### Development environments
@ -154,7 +154,7 @@ all non-local haskell dependencies (including profiling dependencies)
are provided in the nix shell.
```
nix develop '.#haskell-nix.local'
nix develop '.#cabal-local'
```
#### Get into a development environment for building a specific package
@ -164,17 +164,17 @@ all haskell dependencies of this package are provided by the nix shell
(including profiling dependencies).
```
nix develop '.#haskell-nix.<package-name>'
nix develop '.#cabal-<package-name>'
```
for example:
```
nix develop '.#haskell-nix.unison-cli'
nix develop '.#cabal-unison-cli'
```
or
```
nix develop '.#haskell-nix.unison-parser-typechecker'
nix develop '.#cabal-unison-parser-typechecker'
```
This is useful if you wanted to profile a package. For example, if you
@ -183,7 +183,7 @@ shells, cd into its directory, then run the program with
profiling.
```
nix develop '.#unison-parser-typechecker'
nix develop '.#cabal-unison-parser-typechecker'
cd unison-cli
cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p
```

64
flake.nix
View File

@ -88,42 +88,50 @@
'';
};
};
renameAttrs = fn: nixpkgs.lib.mapAttrs' (name: value: {
inherit value;
name = fn name;});
in
assert nixpkgs-packages.ormolu.version == versions.ormolu;
assert nixpkgs-packages.hls.version == versions.hls;
assert nixpkgs-packages.unwrapped-stack.version == versions.stack;
assert nixpkgs-packages.hpack.version == versions.hpack;
{
packages = nixpkgs-packages // {
default = haskell-nix-flake.defaultPackage;
haskell-nix = haskell-nix-flake.packages;
docker = import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; };
build-tools = pkgs.symlinkJoin {
name = "build-tools";
paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs;
};
all = pkgs.symlinkJoin {
name = "all";
paths =
let
all-other-packages = builtins.attrValues (builtins.removeAttrs self.packages."${system}" [ "all" "build-tools" ]);
devshell-inputs = builtins.concatMap
(devShell: devShell.buildInputs ++ devShell.nativeBuildInputs)
[
self.devShells."${system}".only-tools-nixpkgs
];
in
all-other-packages ++ devshell-inputs;
packages =
nixpkgs-packages
// renameAttrs (name: "component-${name}") haskell-nix-flake.packages
// renameAttrs (name: "docker-${name}") (import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; })
// {
default = haskell-nix-flake.defaultPackage;
build-tools = pkgs.symlinkJoin {
name = "build-tools";
paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs;
};
all = pkgs.symlinkJoin {
name = "all";
paths =
let
all-other-packages = builtins.attrValues (builtins.removeAttrs self.packages."${system}" [ "all" "build-tools" ]);
devshell-inputs = builtins.concatMap
(devShell: devShell.buildInputs ++ devShell.nativeBuildInputs)
[
self.devShells."${system}".only-tools-nixpkgs
];
in
all-other-packages ++ devshell-inputs;
};
};
apps = renameAttrs (name: "component-${name}") haskell-nix-flake.apps // {
default = self.apps."${system}"."component-unison-cli-main:exe:unison";
};
apps = haskell-nix-flake.apps // {
default = self.apps."${system}"."unison-cli-main:exe:unison";
};
devShells = nixpkgs-devShells // {
default = self.devShells."${system}".only-tools-nixpkgs;
haskell-nix = haskell-nix-flake.devShells;
};
devShells =
nixpkgs-devShells
// renameAttrs (name: "cabal-${name}") haskell-nix-flake.devShells
// {
default = self.devShells."${system}".only-tools-nixpkgs;
};
});
}

13
lib/unison-prelude/src/Unison/Debug.hs
View File

@ -25,7 +25,6 @@ import UnliftIO.Environment (lookupEnv)
data DebugFlag
= Auth
| Codebase
| Git
| Integrity
| Merge
| Migration
@ -59,7 +58,6 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
case Text.toUpper . Text.strip $ w of
"AUTH" -> pure Auth
"CODEBASE" -> pure Codebase
"GIT" -> pure Git
"INTEGRITY" -> pure Integrity
"MERGE" -> pure Merge
"MIGRATION" -> pure Migration
@ -77,10 +75,6 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
_ -> empty
{-# NOINLINE debugFlags #-}
debugGit :: Bool
debugGit = Git `Set.member` debugFlags
{-# NOINLINE debugGit #-}
debugSqlite :: Bool
debugSqlite = Sqlite `Set.member` debugFlags
{-# NOINLINE debugSqlite #-}
@ -146,11 +140,11 @@ debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.memb
{-# NOINLINE debugPatternCoverageConstraintSolver #-}
-- | Use for trace-style selective debugging.
-- E.g. 1 + (debug Git "The second number" 2)
-- E.g. 1 + (debug Sync "The second number" 2)
--
-- Or, use in pattern matching to view arguments.
-- E.g.
-- myFunc (debug Git "argA" -> argA) = ...
-- myFunc (debug Sync "argA" -> argA) = ...
debug :: (Show a) => DebugFlag -> String -> a -> a
debug flag msg a =
if shouldDebug flag
@ -160,7 +154,7 @@ debug flag msg a =
-- | Use for selective debug logging in monadic contexts.
-- E.g.
-- do
-- debugM Git "source repo" srcRepo
-- debugM Sync "source repo" srcRepo
-- ...
debugM :: (Show a, Monad m) => DebugFlag -> String -> a -> m ()
debugM flag msg a =
@ -187,7 +181,6 @@ shouldDebug :: DebugFlag -> Bool
shouldDebug = \case
Auth -> debugAuth
Codebase -> debugCodebase
Git -> debugGit
Integrity -> debugIntegrity
Merge -> debugMerge
Migration -> debugMigration

6
lib/unison-prelude/src/Unison/Util/Map.hs
View File

@ -5,6 +5,7 @@ module Unison.Util.Map
bitraverse,
bitraversed,
deleteLookup,
deleteLookupJust,
elemsSet,
foldM,
foldMapM,
@ -106,6 +107,11 @@ deleteLookup :: (Ord k) => k -> Map k v -> (Maybe v, Map k v)
deleteLookup =
Map.alterF (,Nothing)
-- | Like 'deleteLookup', but asserts the value is in the map prior to deletion.
deleteLookupJust :: (HasCallStack, Ord k) => k -> Map k v -> (v, Map k v)
deleteLookupJust =
Map.alterF (maybe (error (reportBug "E525283" "deleteLookupJust: element not found")) (,Nothing))
-- | Like 'Map.elems', but return the values as a set.
elemsSet :: Ord v => Map k v -> Set v
elemsSet =

2
nix/docker.nix
View File

@ -5,6 +5,6 @@
name = "ucm";
tag = "latest";
contents = with pkgs; [ cacert fzf ];
config.Cmd = [ "${haskell-nix."unison-cli:exe:unison"}/bin/unison" ];
config.Cmd = [ "${haskell-nix."unison-cli-main:exe:unison"}/bin/unison" ];
};
}

22
parser-typechecker/src/Unison/Codebase.hs
View File

@ -86,10 +86,6 @@ module Unison.Codebase
syncFromDirectory,
syncToDirectory,
-- ** Remote sync
viewRemoteBranch,
pushGitBranch,
-- * Codebase path
getCodebaseDir,
CodebasePath,
@ -124,13 +120,11 @@ 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 qualified as Git
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace)
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.Type (Codebase (..), GitError)
import Unison.Codebase.Type (Codebase (..))
import Unison.CodebasePath (CodebasePath, getCodebaseDir)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import Unison.DataDeclaration (Decl)
@ -466,20 +460,6 @@ isType c r = case r of
Reference.Builtin {} -> pure $ Builtin.isBuiltinType r
Reference.DerivedId r -> isJust <$> getTypeDeclaration c r
-- * Git stuff
-- | Pull a git branch and view it from the cache, without syncing into the
-- local codebase.
viewRemoteBranch ::
(MonadIO m) =>
Codebase m v a ->
ReadGitRemoteNamespace ->
Git.GitBranchBehavior ->
(Branch m -> m r) ->
m (Either GitError r)
viewRemoteBranch codebase ns gitBranchBehavior action =
viewRemoteBranch' codebase ns gitBranchBehavior (\(b, _dir) -> action b)
unsafeGetComponentLength :: (HasCallStack) => Hash -> Sqlite.Transaction Reference.CycleSize
unsafeGetComponentLength h =
Operations.getCycleLen h >>= \case

317
parser-typechecker/src/Unison/Codebase/Editor/Git.hs
View File

@ -1,317 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Codebase.Editor.Git
( gitIn,
gitTextIn,
gitInCaptured,
withRepo,
withIOError,
withStatus,
withIsolatedRepo,
debugGit,
gitDirToPath,
gitVerbosity,
GitBranchBehavior (..),
GitRepo (..),
-- * Exported for testing
gitCacheDir,
)
where
import Control.Exception qualified
import Control.Monad.Except (MonadError, throwError)
import Data.ByteString.Base16 qualified as ByteString
import Data.Char qualified as Char
import Data.Text qualified as Text
import Shellmet (($?), ($^), ($|))
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath ((</>))
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..))
import Unison.Codebase.GitError (GitProtocolError)
import Unison.Codebase.GitError qualified as GitError
import Unison.Debug qualified as Debug
import Unison.Prelude
import UnliftIO qualified
import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExecutable, getXdgDirectory)
import UnliftIO.IO (hFlush, stdout)
import UnliftIO.Process qualified as UnliftIO
debugGit :: Bool
debugGit = Debug.shouldDebug Debug.Git
gitVerbosity :: [Text]
gitVerbosity =
if debugGit
then []
else ["--quiet"]
-- https://superuser.com/questions/358855/what-characters-are-safe-in-cross-platform-file-names-for-linux-windows-and-os
encodeFileName :: String -> FilePath
encodeFileName s =
let go ('.' : rem) = "$dot$" <> go rem
go ('$' : rem) = "$$" <> go rem
go (c : rem)
| elem @[] c "/\\:*?\"<>|" || not (Char.isPrint c && Char.isAscii c) =
"$x" <> encodeHex [c] <> "$" <> go rem
| otherwise = c : go rem
go [] = []
encodeHex :: String -> String
encodeHex =
Text.unpack
. Text.toUpper
. ByteString.encodeBase16
. encodeUtf8
. Text.pack
in -- 'bare' suffix is to avoid clashes with non-bare repos initialized by earlier versions
-- of ucm.
go s <> "-bare"
gitCacheDir :: (MonadIO m) => Text -> m FilePath
gitCacheDir url =
getXdgDirectory XdgCache $
"unisonlanguage"
</> "gitfiles"
</> encodeFileName (Text.unpack url)
withStatus :: (MonadIO m) => String -> m a -> m a
withStatus str ma = do
flushStr str
a <- ma
flushStr (const ' ' <$> str)
pure a
where
flushStr str = do
liftIO . putStr $ " " ++ str ++ "\r"
hFlush stdout
-- | Run an action on an isolated copy of the provided repo.
-- The repo is deleted when the action exits or fails.
-- A branch or tag to check out from the source repo may be specified.
withIsolatedRepo ::
forall m r.
(MonadUnliftIO m) =>
GitRepo ->
Text ->
Maybe Text ->
(GitRepo -> m r) ->
m (Either GitProtocolError r)
withIsolatedRepo srcPath origin mayGitRef action = do
UnliftIO.withSystemTempDirectory "ucm-isolated-repo" $ \tempDir -> do
let tempRepo = Worktree tempDir
copyCommand tempRepo >>= \case
Left gitErr -> pure $ Left (GitError.CopyException (gitDirToPath srcPath) tempDir (show gitErr))
Right () -> Right <$> action tempRepo
where
copyCommand :: GitRepo -> m (Either IOException ())
copyCommand dest = UnliftIO.tryIO . liftIO $ do
gitGlobal
( ["clone", "--origin", "git-cache"]
-- tags work okay here too.
++ maybe [] (\t -> ["--branch", t]) mayGitRef
++ [Text.pack . gitDirToPath $ srcPath, Text.pack . gitDirToPath $ dest]
)
-- If a specific ref wasn't requested, ensure we have all branches and tags from the source.
-- This is fast since it's a local fetch.
when (isNothing mayGitRef) $ do
-- If the source repo is empty, we can't fetch, but there won't be anything to
-- fetch anyways.
unlessM (isEmptyGitRepo srcPath) $ do
gitIn dest $ ["fetch", "--tags", Text.pack . gitDirToPath $ srcPath] ++ gitVerbosity
gitIn dest $ ["remote", "add", "origin", origin]
-- | Define what to do if the repo we're pulling/pushing doesn't have the specified branch.
data GitBranchBehavior
= -- If the desired branch doesn't exist in the repo,
-- create a new branch by the provided name with a fresh codebase
CreateBranchIfMissing
| -- Fail with an error if the branch doesn't exist.
RequireExistingBranch
-- | Clone or fetch an updated copy of the provided repository and check out the expected ref,
-- then provide the action with a path to the codebase in that repository.
-- Note that the repository provided to the action is temporary, it will be removed when the
-- action completes or fails.
withRepo ::
forall m a.
(MonadUnliftIO m) =>
ReadGitRepo ->
GitBranchBehavior ->
(GitRepo -> m a) ->
m (Either GitProtocolError a)
withRepo repo@(ReadGitRepo {url = uri, ref = mayGitRef}) branchBehavior action = UnliftIO.try $ do
throwExceptT $ checkForGit
gitCachePath <- gitCacheDir uri
-- Ensure we have the main branch in the cache dir no matter what
_ :: GitRepo <- throwExceptT $ cloneIfMissing repo {ref = Nothing} gitCachePath
let gitCacheRepo = Bare gitCachePath
gitRef <- case mayGitRef of
Nothing -> fromMaybe "main" <$> getDefaultBranch gitCacheRepo
Just gitRef -> pure gitRef
doesRemoteRefExist <- fetchAndUpdateRef gitCacheRepo gitRef
if doesRemoteRefExist
then do
-- A ref by the requested name exists on the remote.
withStatus ("Checking out " ++ Text.unpack gitRef ++ " ...") $ do
-- Check out the ref in a new isolated repo
throwEitherM . withIsolatedRepo gitCacheRepo uri (Just gitRef) $ action
else do
-- No ref by the given name exists on the remote
case branchBehavior of
RequireExistingBranch -> UnliftIO.throwIO (GitError.RemoteRefNotFound uri gitRef)
CreateBranchIfMissing ->
withStatus ("Creating new branch " ++ Text.unpack gitRef ++ " ...")
. throwEitherM
. withIsolatedRepo gitCacheRepo uri Nothing
$ \(workTree) -> do
-- It's possible for the branch to exist in the cache even if it's not in the
-- remote, if for instance the branch was deleted from the remote.
-- In that case we delete the branch from the cache and create a new one.
localRefExists <- doesLocalRefExist gitCacheRepo gitRef
when localRefExists $ do
currentBranch <- gitTextIn workTree ["branch", "--show-current"]
-- In the rare case where we've got the branch already checked out,
-- we need to temporarily switch to a different branch so we can delete and
-- reset the branch to an orphan.
when (currentBranch == gitRef) $ gitIn workTree $ ["branch", "-B", "_unison_temp_branch"] ++ gitVerbosity
gitIn workTree $ ["branch", "-D", gitRef] ++ gitVerbosity
gitIn workTree $ ["checkout", "--orphan", gitRef] ++ gitVerbosity
-- Checking out an orphan branch doesn't actually clear the worktree, do that manually.
_ <- gitInCaptured workTree $ ["rm", "--ignore-unmatch", "-rf", "."] ++ gitVerbosity
action workTree
where
-- Check if a ref exists in the repository at workDir.
doesLocalRefExist :: GitRepo -> Text -> m Bool
doesLocalRefExist workDir ref = liftIO $ do
(gitIn workDir (["show-ref", "--verify", ref] ++ gitVerbosity) $> True)
$? pure False
-- fetch the given ref and update the local repositories ref to match the remote.
-- returns whether or not the ref existed on the remote.
fetchAndUpdateRef :: GitRepo -> Text -> m Bool
fetchAndUpdateRef workDir gitRef = do
(succeeded, _, _) <-
gitInCaptured
workDir
( [ "fetch",
"--tags", -- if the gitref is a tag, fetch and update that too.
"--force", -- force updating local refs even if not fast-forward
-- update local refs with the same name they have on the remote.
"--refmap",
"*:*",
"--depth",
"1",
uri, -- The repo to fetch from
gitRef -- The specific reference to fetch
]
++ gitVerbosity
)
pure succeeded
-- | Do a `git clone` (for a not-previously-cached repo).
cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadGitRepo -> FilePath -> m GitRepo
cloneIfMissing repo@(ReadGitRepo {url = uri}) localPath = do
doesDirectoryExist localPath >>= \case
True ->
whenM (not <$> isGitRepo (Bare localPath)) $ do
throwError (GitError.UnrecognizableCacheDir repo localPath)
False -> do
-- directory doesn't exist, so clone anew
cloneRepo
pure $ Bare localPath
where
cloneRepo = do
withStatus ("Downloading from " ++ Text.unpack uri ++ " ...") $
( liftIO $
gitGlobal
( ["clone"]
++ ["--bare"]
++ ["--depth", "1"]
++ [uri, Text.pack localPath]
)
)
`withIOError` (throwError . GitError.CloneException repo . show)
isGitDir <- liftIO $ isGitRepo (Bare localPath)
unless isGitDir . throwError $ GitError.UnrecognizableCheckoutDir repo localPath
-- | See if `git` is on the system path.
checkForGit :: (MonadIO m) => (MonadError GitProtocolError m) => m ()
checkForGit = do
gitPath <- liftIO $ findExecutable "git"
when (isNothing gitPath) $ throwError GitError.NoGit
-- | Returns the name of the default branch of a repository, if one exists.
getDefaultBranch :: (MonadIO m) => GitRepo -> m (Maybe Text)
getDefaultBranch dir = liftIO $ do
(Text.stripPrefix "refs/heads/" <$> gitTextIn dir ["symbolic-ref", "HEAD"])
$? pure Nothing
-- | Does `git` recognize this directory as being managed by git?
isGitRepo :: (MonadIO m) => GitRepo -> m Bool
isGitRepo dir =
liftIO $
(True <$ gitIn dir (["rev-parse"] ++ gitVerbosity)) $? pure False
-- | Returns True if the repo is empty, i.e. has no commits at the current branch,
-- or if the dir isn't a git repo at all.
isEmptyGitRepo :: (MonadIO m) => GitRepo -> m Bool
isEmptyGitRepo dir = liftIO do
(gitTextIn dir (["rev-parse", "HEAD"] ++ gitVerbosity) $> False) $? pure True
-- | Perform an IO action, passing any IO exception to `handler`
withIOError :: (MonadIO m) => IO a -> (IOException -> m a) -> m a
withIOError action handler =
liftIO (fmap Right action `Control.Exception.catch` (pure . Left))
>>= either handler pure
-- | A path to a git repository.
data GitRepo
= Bare FilePath
| Worktree FilePath
deriving (Show)
gitDirToPath :: GitRepo -> FilePath
gitDirToPath = \case
Bare fp -> fp
Worktree fp -> fp
-- | Generate some `git` flags for operating on some arbitary checked out copy
setupGitDir :: GitRepo -> [Text]
setupGitDir dir =
case dir of
Bare localPath ->
["--git-dir", Text.pack localPath]
Worktree localPath ->
[ "--git-dir",
Text.pack (localPath </> ".git"),
"--work-tree",
Text.pack localPath
]
-- | Run a git command in the current work directory.
-- Note: this should only be used for commands like 'clone' which don't interact with an
-- existing repository.
gitGlobal :: (MonadIO m) => [Text] -> m ()
gitGlobal args = do
when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> args)
liftIO $ "git" $^ (args ++ gitVerbosity)
-- | Run a git command in the repository at localPath
gitIn :: (MonadIO m) => GitRepo -> [Text] -> m ()
gitIn localPath args = do
when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args)
liftIO $ "git" $^ (setupGitDir localPath <> args)
-- | like 'gitIn', but silences all output from the command and returns whether the command
-- succeeded.
gitInCaptured :: (MonadIO m) => GitRepo -> [Text] -> m (Bool, Text, Text)
gitInCaptured localPath args = do
when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args)
(exitCode, stdout, stderr) <- UnliftIO.readProcessWithExitCode "git" (Text.unpack <$> setupGitDir localPath <> args) ""
pure (exitCode == ExitSuccess, Text.pack stdout, Text.pack stderr)
-- | Run a git command in the repository at localPath and capture stdout
gitTextIn :: (MonadIO m) => GitRepo -> [Text] -> m Text
gitTextIn localPath args = do
when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args)
liftIO $ "git" $| setupGitDir localPath <> args

68
parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs
View File

@ -2,22 +2,13 @@ module Unison.Codebase.Editor.RemoteRepo where
import Control.Lens (Lens')
import Control.Lens qualified as Lens
import Data.Text qualified as Text
import Data.Void (absurd)
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.NameSegment qualified as NameSegment
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Share.Types
import Unison.Util.Monoid qualified as Monoid
data ReadRepo
= ReadRepoGit ReadGitRepo
| ReadRepoShare ShareCodeserver
deriving stock (Eq, Ord, Show)
data ShareCodeserver
= DefaultCodeserver
@ -44,58 +35,21 @@ displayShareCodeserver cs shareUser path =
CustomCodeserver cu -> "share(" <> tShow cu <> ")."
in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path
data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text}
deriving stock (Eq, Ord, Show)
data WriteRepo
= WriteRepoGit WriteGitRepo
| WriteRepoShare ShareCodeserver
deriving stock (Eq, Ord, Show)
data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text}
deriving stock (Eq, Ord, Show)
writeToRead :: WriteRepo -> ReadRepo
writeToRead = \case
WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo)
WriteRepoShare repo -> ReadRepoShare repo
writeToReadGit :: WriteGitRepo -> ReadGitRepo
writeToReadGit = \case
WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch}
writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void
writeNamespaceToRead = \case
WriteRemoteNamespaceGit WriteGitRemoteNamespace {repo, path} ->
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sch = Nothing, path}
WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} ->
ReadShare'LooseCode ReadShareLooseCode {server, repo, path}
WriteRemoteProjectBranch v -> absurd v
printReadGitRepo :: ReadGitRepo -> Text
printReadGitRepo ReadGitRepo {url, ref} =
"git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) <> ")"
printWriteGitRepo :: WriteGitRepo -> Text
printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")"
-- | print remote namespace
printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text
printReadRemoteNamespace printProject = \case
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sch, path} ->
printReadGitRepo repo <> maybePrintSCH sch <> maybePrintPath path
where
maybePrintSCH = \case
Nothing -> mempty
Just sch -> "#" <> SCH.toText sch
ReadShare'LooseCode ReadShareLooseCode {server, repo, path} -> displayShareCodeserver server repo path
ReadShare'ProjectBranch project -> printProject project
-- | Render a 'WriteRemoteNamespace' as text.
printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text
printWriteRemoteNamespace = \case
WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo, path}) ->
printWriteGitRepo repo <> maybePrintPath path
WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) ->
displayShareCodeserver server repo path
WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch
@ -107,20 +61,12 @@ maybePrintPath path =
else "." <> Path.toText path
data ReadRemoteNamespace a
= ReadRemoteNamespaceGit !ReadGitRemoteNamespace
| ReadShare'LooseCode !ReadShareLooseCode
= ReadShare'LooseCode !ReadShareLooseCode
| -- | A remote project+branch, specified by name (e.g. @unison/base/main).
-- Currently assumed to be hosted on Share, though we could include a ShareCodeserver in here, too.
ReadShare'ProjectBranch !a
deriving stock (Eq, Functor, Show, Generic)
data ReadGitRemoteNamespace = ReadGitRemoteNamespace
{ repo :: !ReadGitRepo,
sch :: !(Maybe ShortCausalHash),
path :: !Path
}
deriving stock (Eq, Show)
data ReadShareLooseCode = ReadShareLooseCode
{ server :: !ShareCodeserver,
repo :: !ShareUserHandle,
@ -136,8 +82,7 @@ isPublic ReadShareLooseCode {path} =
_ -> False
data WriteRemoteNamespace a
= WriteRemoteNamespaceGit !WriteGitRemoteNamespace
| WriteRemoteNamespaceShare !WriteShareRemoteNamespace
= WriteRemoteNamespaceShare !WriteShareRemoteNamespace
| WriteRemoteProjectBranch a
deriving stock (Eq, Functor, Show)
@ -146,23 +91,14 @@ remotePath_ :: Lens' (WriteRemoteNamespace Void) Path
remotePath_ = Lens.lens getter setter
where
getter = \case
WriteRemoteNamespaceGit (WriteGitRemoteNamespace _ path) -> path
WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path
WriteRemoteProjectBranch v -> absurd v
setter remote path =
case remote of
WriteRemoteNamespaceGit (WriteGitRemoteNamespace repo _) ->
WriteRemoteNamespaceGit $ WriteGitRemoteNamespace repo path
WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) ->
WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path
WriteRemoteProjectBranch v -> absurd v
data WriteGitRemoteNamespace = WriteGitRemoteNamespace
{ repo :: !WriteGitRepo,
path :: !Path
}
deriving stock (Eq, Generic, Show)
data WriteShareRemoteNamespace = WriteShareRemoteNamespace
{ server :: !ShareCodeserver,
repo :: !ShareUserHandle,

37
parser-typechecker/src/Unison/Codebase/GitError.hs
View File

@ -1,37 +0,0 @@
module Unison.Codebase.GitError
( CodebasePath,
GitProtocolError (..),
GitCodebaseError (..),
)
where
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo, WriteGitRepo)
import Unison.Codebase.Path (Path)
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Prelude
type CodebasePath = FilePath
data GitProtocolError
= NoGit
| UnrecognizableCacheDir ReadGitRepo CodebasePath
| UnrecognizableCheckoutDir ReadGitRepo CodebasePath
| -- srcPath destPath error-description
CopyException FilePath FilePath String
| CloneException ReadGitRepo String
| PushException WriteGitRepo String
| PushNoOp WriteGitRepo
| -- url commit Diff of what would change on merge with remote
PushDestinationHasNewStuff WriteGitRepo
| CleanupError SomeException
| -- Thrown when a commit, tag, or branch isn't found in a repo.
-- repo ref
RemoteRefNotFound Text Text
deriving stock (Show)
deriving anyclass (Exception)
data GitCodebaseError h
= NoRemoteNamespaceWithHash ReadGitRepo ShortCausalHash
| RemoteNamespaceHashAmbiguous ReadGitRepo ShortCausalHash (Set h)
| CouldntFindRemoteBranch ReadGitRepo Path
deriving (Show)

253
parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs
View File

@ -14,17 +14,13 @@ where
import Control.Monad.Except qualified as Except
import Control.Monad.Extra qualified as Monad
import Data.Char qualified as Char
import Data.Either.Extra ()
import Data.IORef
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Time (getCurrentTime)
import System.Console.ANSI qualified as ANSI
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
import System.FilePath qualified as FilePath
import System.FilePath.Posix qualified as FilePath.Posix
import U.Codebase.HashTags (CausalHash, PatchHash (..))
import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.Operations qualified as Ops
@ -36,15 +32,6 @@ import Unison.Codebase (Codebase, CodebasePath)
import Unison.Codebase qualified as Codebase1
import Unison.Codebase.Branch (Branch (..))
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo)
import Unison.Codebase.Editor.Git qualified as Git
import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..),
ReadGitRepo,
WriteGitRepo (..),
writeToReadGit,
)
import Unison.Codebase.GitError qualified as GitError
import Unison.Codebase.Init (BackupStrategy (..), CodebaseLockOption (..), MigrationStrategy (..), VacuumStrategy (..))
import Unison.Codebase.Init qualified as Codebase
import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1
@ -54,12 +41,11 @@ import Unison.Codebase.RootBranchCache
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.Codebase.SqliteCodebase.GitError qualified as GitError
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.Type (GitPushBehavior, LocalOrRemote (..))
import Unison.Codebase.Type (LocalOrRemote (..))
import Unison.Codebase.Type qualified as C
import Unison.DataDeclaration (Decl)
import Unison.Hash (Hash)
@ -75,9 +61,8 @@ import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Util.Timing (time)
import Unison.WatchKind qualified as UF
import UnliftIO (UnliftIO (..), finally, throwIO, try)
import UnliftIO (UnliftIO (..), finally)
import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import UnliftIO.Exception (catch)
import UnliftIO.STM
debug, debugProcessBranches :: Bool
@ -103,30 +88,6 @@ initWithSetup onCreate =
codebasePath = makeCodebaseDirPath
}
data CodebaseStatus
= ExistingCodebase
| CreatedCodebase
deriving (Eq)
-- | Open the codebase at the given location, or create it if one doesn't already exist.
withOpenOrCreateCodebase ::
(MonadUnliftIO m) =>
Sqlite.Transaction () ->
Codebase.DebugName ->
CodebasePath ->
LocalOrRemote ->
CodebaseLockOption ->
MigrationStrategy ->
((CodebaseStatus, Codebase m Symbol Ann) -> m r) ->
m (Either Codebase1.OpenCodebaseError r)
withOpenOrCreateCodebase onCreate debugName codebasePath localOrRemote lockOption migrationStrategy action = do
createCodebaseOrError onCreate debugName codebasePath lockOption (action' CreatedCodebase) >>= \case
Left (Codebase1.CreateCodebaseAlreadyExists) -> do
sqliteCodebase debugName codebasePath localOrRemote lockOption migrationStrategy (action' ExistingCodebase)
Right r -> pure (Right r)
where
action' openOrCreate codebase = action (openOrCreate, codebase)
-- | Create a codebase at the given location.
createCodebaseOrError ::
(MonadUnliftIO m) =>
@ -379,8 +340,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
putBranch,
syncFromDirectory,
syncToDirectory,
viewRemoteBranch',
pushGitBranch = \repo opts action -> withConn \conn -> pushGitBranch conn repo opts action,
getWatch,
termsOfTypeImpl,
termsMentioningTypeImpl,
@ -571,214 +530,6 @@ syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (l
where
v = const ()
-- FIXME(mitchell) seems like this should have "git" in its name
viewRemoteBranch' ::
forall m r.
(MonadUnliftIO m) =>
ReadGitRemoteNamespace ->
Git.GitBranchBehavior ->
((Branch m, CodebasePath) -> m r) ->
m (Either C.GitError r)
viewRemoteBranch' ReadGitRemoteNamespace {repo, sch, path} gitBranchBehavior action = UnliftIO.try $ do
-- set up the cache dir
time "Git fetch" $
throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do
let remotePath = Git.gitDirToPath remoteRepo
-- In modern UCM all new codebases are created in WAL mode, but it's possible old
-- codebases were pushed to git in DELETE mode, so when pulling remote branches we
-- ensure we're in WAL mode just to be safe.
ensureWALMode conn = Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL
-- Tickle the database before calling into `sqliteCodebase`; this covers the case that the database file either
-- doesn't exist at all or isn't a SQLite database file, but does not cover the case that the database file itself
-- is somehow corrupt, or not even a Unison database.
--
-- FIXME it would probably make more sense to define some proper preconditions on `sqliteCodebase`, and perhaps
-- update its output type, which currently indicates the only way it can fail is with an `UnknownSchemaVersion`
-- error.
(withConnection "codebase exists check" remotePath ensureWALMode) `catch` \exception ->
if Sqlite.isCantOpenException exception
then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath))
else throwIO exception
result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote DoLock (MigrateAfterPrompt Codebase.Backup Codebase.Vacuum) \codebase -> do
-- try to load the requested branch from it
branch <- time "Git fetch (sch)" $ case sch of
-- no sub-branch was specified, so use the root.
Nothing -> time "Get remote root branch" $ Codebase1.getRootBranch codebase
-- load from a specific `ShortCausalHash`
Just sch -> do
branchCompletions <- Codebase1.runTransaction codebase (Codebase1.causalHashesByPrefix sch)
case toList branchCompletions of
[] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch
[h] ->
(Codebase1.getBranchForHash codebase h) >>= \case
Just b -> pure b
Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch
_ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sch branchCompletions
case Branch.getAt path branch of
Just b -> action (b, remotePath)
Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path
case result of
Left err -> throwIO . C.GitSqliteCodebaseError $ C.gitErrorFromOpenCodebaseError remotePath repo err
Right inner -> pure inner
-- | Push a branch to a repo. Optionally attempt to set the branch as the new root, which fails if the branch is not after
-- the existing root.
pushGitBranch ::
forall m e.
(MonadUnliftIO m) =>
Sqlite.Connection ->
WriteGitRepo ->
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 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
-- Use sqlite's VACUUM INTO command to make a copy of the remote codebase into our temp-dir
-- Connect to the copied codebase and sync whatever it is we want to push.
-- sync the branch to the staging codebase using `syncInternal`, which probably needs to be passed in instead of `syncToDirectory`
-- if setting the remote root,
-- do a `before` check on the staging codebase
-- if it passes, proceed (see below)
-- if it fails, throw an exception (which will rollback) and clean up.
-- push from the temp-dir to the remote.
-- Delete the temp-dir.
--
-- set up the cache dir
throwEitherMWith C.GitProtocolError . withRepo readRepo Git.CreateBranchIfMissing $ \pushStaging -> do
newBranchOrErr <- throwEitherMWith (C.GitSqliteCodebaseError . C.gitErrorFromOpenCodebaseError (Git.gitDirToPath pushStaging) readRepo)
. withOpenOrCreateCodebase (pure ()) "push.dest" (Git.gitDirToPath pushStaging) Remote DoLock (MigrateAfterPrompt Codebase.Backup Codebase.Vacuum)
$ \(codebaseStatus, destCodebase) -> do
currentRootBranch <-
Codebase1.runTransaction destCodebase CodebaseOps.getRootBranchExists >>= \case
False -> pure Branch.empty
True -> C.getRootBranch destCodebase
action currentRootBranch >>= \case
Left e -> pure $ Left e
Right newBranch -> do
C.withConnection destCodebase \destConn ->
doSync codebaseStatus destConn newBranch
pure (Right newBranch)
for_ newBranchOrErr $ push pushStaging repo
pure newBranchOrErr
where
readRepo :: ReadGitRepo
readRepo = writeToReadGit repo
doSync :: CodebaseStatus -> Sqlite.Connection -> Branch m -> m ()
doSync codebaseStatus destConn newBranch = do
progressStateRef <- liftIO (newIORef emptySyncProgressState)
Sqlite.runReadOnlyTransaction srcConn \runSrc -> do
Sqlite.runWriteTransaction destConn \runDest -> do
_ <- syncInternal (syncProgress progressStateRef) runSrc runDest newBranch
let overwriteRoot forcePush = do
let newBranchHash = Branch.headHash newBranch
case codebaseStatus of
ExistingCodebase -> do
when (not forcePush) do
-- the call to runDB "handles" the possible DB error by bombing
runDest Ops.loadRootCausalHash >>= \case
Nothing -> pure ()
Just oldRootHash -> do
runDest (CodebaseOps.before oldRootHash newBranchHash) >>= \case
False -> throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo
True -> pure ()
CreatedCodebase -> pure ()
runDest (setRepoRoot newBranchHash)
case behavior of
C.GitPushBehaviorGist -> pure ()
C.GitPushBehaviorFf -> overwriteRoot False
C.GitPushBehaviorForce -> overwriteRoot True
setRepoRoot :: CausalHash -> Sqlite.Transaction ()
setRepoRoot h = do
let err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h
chId <- fromMaybe err <$> Q.loadCausalHashIdByCausalHash h
Q.setNamespaceRoot chId
-- This function makes sure that the result of git status is valid.
-- Valid lines are any of:
--
-- ?? .unison/v2/unison.sqlite3 (initial commit to an empty repo)
-- M .unison/v2/unison.sqlite3 (updating an existing repo)
-- D .unison/v2/unison.sqlite3-wal (cleaning up the WAL from before bugfix)
-- D .unison/v2/unison.sqlite3-shm (ditto)
--
-- Invalid lines are like:
--
-- ?? .unison/v2/unison.sqlite3-wal
--
-- Which will only happen if the write-ahead log hasn't been
-- fully folded into the unison.sqlite3 file.
--
-- Returns `Just (hasDeleteWal, hasDeleteShm)` on success,
-- `Nothing` otherwise. hasDeleteWal means there's the line:
-- D .unison/v2/unison.sqlite3-wal
-- and hasDeleteShm is `True` if there's the line:
-- D .unison/v2/unison.sqlite3-shm
--
parseStatus :: Text -> Maybe (Bool, Bool)
parseStatus status =
if all okLine statusLines
then Just (hasDeleteWal, hasDeleteShm)
else Nothing
where
-- `git status` always displays paths using posix forward-slashes,
-- so we have to convert our expected path to test.
posixCodebasePath =
FilePath.Posix.joinPath (FilePath.splitDirectories codebasePath)
posixLockfilePath = FilePath.replaceExtension posixCodebasePath "lockfile"
statusLines = Text.unpack <$> Text.lines status
t = dropWhile Char.isSpace
okLine (t -> '?' : '?' : (t -> p)) | p == posixCodebasePath || p == posixLockfilePath = True
okLine (t -> 'M' : (t -> p)) | p == posixCodebasePath = True
okLine line = isWalDelete line || isShmDelete line
isWalDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True
isWalDelete _ = False
isShmDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True
isShmDelete _ = False
hasDeleteWal = any isWalDelete statusLines
hasDeleteShm = any isShmDelete statusLines
-- Commit our changes
push :: forall n. (MonadIO n) => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO
push remotePath repo@(WriteGitRepo {url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do
-- has anything changed?
-- note: -uall recursively shows status for all files in untracked directories
-- we want this so that we see
-- `?? .unison/v2/unison.sqlite3` and not
-- `?? .unison/`
status <- gitTextIn remotePath ["status", "--short", "-uall"]
if Text.null status
then pure False
else case parseStatus status of
Nothing ->
error $
"An error occurred during push.\n"
<> "I was expecting only to see "
<> codebasePath
<> " modified, but saw:\n\n"
<> Text.unpack status
<> "\n\n"
<> "Please visit https://github.com/unisonweb/unison/issues/2063\n"
<> "and add any more details about how you encountered this!\n"
Just (hasDeleteWal, hasDeleteShm) -> do
-- Only stage files we're expecting; don't `git add --all .`
-- which could accidentally commit some garbage
gitIn remotePath ["add", Text.pack codebasePath]
when hasDeleteWal $ gitIn remotePath ["rm", Text.pack $ codebasePath <> "-wal"]
when hasDeleteShm $ gitIn remotePath ["rm", Text.pack $ codebasePath <> "-shm"]
gitIn
remotePath
["commit", "-q", "-m", "Sync branch " <> Text.pack (show $ Branch.headHash newRootBranch)]
-- Push our changes to the repo, silencing all output.
-- Even with quiet, the remote (Github) can still send output through,
-- so we capture stdout and stderr.
(successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", url] ++ Git.gitVerbosity ++ maybe [] (pure @[]) mayGitBranch
when (not successful) . throwIO $ GitError.PushException repo (Text.unpack stderr)
pure True
-- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase
-- at the source to the destination.
-- Note: this does not copy the .unisonConfig file.

13
parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs
View File

@ -1,13 +0,0 @@
module Unison.Codebase.SqliteCodebase.GitError where
import U.Codebase.Sqlite.DbId (SchemaVersion)
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo)
import Unison.CodebasePath (CodebasePath)
data GitSqliteCodebaseError
= GitCouldntParseRootBranchHash ReadGitRepo String
| CodebaseFileLockFailed
| NoDatabaseFile ReadGitRepo CodebasePath
| UnrecognizedSchemaVersion ReadGitRepo CodebasePath SchemaVersion
| CodebaseRequiresMigration SchemaVersion SchemaVersion
deriving (Show)

36
parser-typechecker/src/Unison/Codebase/Type.hs
View File

@ -4,21 +4,13 @@
module Unison.Codebase.Type
( Codebase (..),
CodebasePath,
GitPushBehavior (..),
GitError (..),
LocalOrRemote (..),
gitErrorFromOpenCodebaseError,
)
where
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Reference qualified as V2
import Unison.Codebase.Branch (Branch)
import Unison.Codebase.Editor.Git qualified as Git
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo)
import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError)
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..))
import Unison.CodebasePath (CodebasePath)
import Unison.ConstructorType qualified as CT
import Unison.DataDeclaration (Decl)
@ -80,9 +72,6 @@ data Codebase m v a = Codebase
syncFromDirectory :: CodebasePath -> Branch m -> m (),
-- | Copy a branch and all of its dependencies from this codebase into the given codebase.
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 -> 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.
@ -106,28 +95,3 @@ data LocalOrRemote
= Local
| Remote
deriving (Show, Eq, Ord)
data GitPushBehavior
= -- | Don't set root, just sync entities.
GitPushBehaviorGist
| -- | After syncing entities, do a fast-forward check, then set the root.
GitPushBehaviorFf
| -- | After syncing entities, just set the root (force-pushy).
GitPushBehaviorForce
data GitError
= GitProtocolError GitProtocolError
| GitCodebaseError (GitCodebaseError CausalHash)
| GitSqliteCodebaseError GitSqliteCodebaseError
deriving (Show)
instance Exception GitError
gitErrorFromOpenCodebaseError :: CodebasePath -> ReadGitRepo -> OpenCodebaseError -> GitSqliteCodebaseError
gitErrorFromOpenCodebaseError path repo = \case
OpenCodebaseDoesntExist -> NoDatabaseFile repo path
OpenCodebaseUnknownSchemaVersion v ->
UnrecognizedSchemaVersion repo path (fromIntegral v)
OpenCodebaseRequiresMigration fromSv toSv ->
CodebaseRequiresMigration fromSv toSv
OpenCodebaseFileLockFailed -> CodebaseFileLockFailed

5
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.36.0.
-- This file has been generated from package.yaml by hpack version 0.35.2.
--
-- see: https://github.com/sol/hpack
@ -47,11 +47,9 @@ library
Unison.Codebase.CodeLookup
Unison.Codebase.CodeLookup.Util
Unison.Codebase.Editor.DisplayObject
Unison.Codebase.Editor.Git
Unison.Codebase.Editor.RemoteRepo
Unison.Codebase.Execute
Unison.Codebase.FileCodebase
Unison.Codebase.GitError
Unison.Codebase.Init
Unison.Codebase.Init.CreateCodebaseError
Unison.Codebase.Init.OpenCodebaseError
@ -71,7 +69,6 @@ library
Unison.Codebase.SqliteCodebase.Branch.Cache
Unison.Codebase.SqliteCodebase.Branch.Dependencies
Unison.Codebase.SqliteCodebase.Conversions
Unison.Codebase.SqliteCodebase.GitError
Unison.Codebase.SqliteCodebase.Migrations
Unison.Codebase.SqliteCodebase.Migrations.Helpers
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12

35
unison-cli/src/Unison/Cli/DownloadUtils.hs
View File

@ -4,8 +4,6 @@
module Unison.Cli.DownloadUtils
( downloadProjectBranchFromShare,
downloadLooseCodeFromShare,
GitNamespaceHistoryTreatment (..),
downloadLooseCodeFromGitRepo,
)
where
@ -18,27 +16,19 @@ 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 (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
@ -113,26 +103,3 @@ withEntitiesDownloadedProgressCallback action = do
<> 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)

3
unison-cli/src/Unison/Cli/MergeTypes.hs
View File

@ -7,7 +7,7 @@ module Unison.Cli.MergeTypes
)
where
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadShareLooseCode)
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode)
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
-- | What are we merging in?
@ -15,7 +15,6 @@ data MergeSource
= MergeSource'LocalProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName)
| MergeSource'RemoteProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName)
| MergeSource'RemoteLooseCode !ReadShareLooseCode
| MergeSource'RemoteGitRepo !ReadGitRemoteNamespace
type MergeTarget =
ProjectAndBranch ProjectName ProjectBranchName

19
unison-cli/src/Unison/Cli/Pretty.hs
View File

@ -27,7 +27,6 @@ module Unison.Cli.Pretty
prettyProjectName,
prettyProjectNameSlash,
prettyNamespaceKey,
prettyReadGitRepo,
prettyReadRemoteNamespace,
prettyReadRemoteNamespaceWith,
prettyRelative,
@ -46,7 +45,6 @@ module Unison.Cli.Pretty
prettyURI,
prettyUnisonFile,
prettyWhichBranchEmpty,
prettyWriteGitRepo,
prettyWriteRemoteNamespace,
shareOrigin,
unsafePrettyTermResultSigFull',
@ -79,10 +77,8 @@ import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, Missi
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.RemoteRepo
( ReadGitRepo,
ReadRemoteNamespace (..),
( ReadRemoteNamespace (..),
ShareUserHandle (..),
WriteGitRepo,
WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..),
shareUserHandleToText,
@ -239,7 +235,6 @@ prettyMergeSource = \case
MergeSource'LocalProjectBranch branch -> prettyProjectAndBranchName branch
MergeSource'RemoteProjectBranch branch -> "remote " <> prettyProjectAndBranchName branch
MergeSource'RemoteLooseCode info -> prettyReadRemoteNamespace (ReadShare'LooseCode info)
MergeSource'RemoteGitRepo info -> prettyReadRemoteNamespace (ReadRemoteNamespaceGit info)
prettyMergeSourceOrTarget :: MergeSourceOrTarget -> Pretty
prettyMergeSourceOrTarget = \case
@ -348,18 +343,6 @@ prettyTypeName ppe r =
P.syntaxToColor $
prettyHashQualified (PPE.typeName ppe r)
prettyReadGitRepo :: ReadGitRepo -> Pretty
prettyReadGitRepo = \case
RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url)
prettyWriteGitRepo :: WriteGitRepo -> Pretty
prettyWriteGitRepo RemoteRepo.WriteGitRepo {url} = P.blue (P.text url)
-- prettyWriteRepo :: WriteRepo -> Pretty
-- prettyWriteRepo = \case
-- RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url)
-- RemoteRepo.WriteRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s))
-- | Pretty-print a 'WhichBranchEmpty'.
prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty
prettyWhichBranchEmpty = \case

14
unison-cli/src/Unison/Cli/UnisonConfigUtils.hs
View File

@ -1,7 +1,6 @@
-- | @.unisonConfig@ file utilities
module Unison.Cli.UnisonConfigUtils
( gitUrlKey,
remoteMappingKey,
( remoteMappingKey,
resolveConfiguredUrl,
)
where
@ -33,9 +32,6 @@ configKey k p =
NameSegment.toEscapedText
(Path.toSeq $ Path.unabsolute p)
gitUrlKey :: Path.Absolute -> Text
gitUrlKey = configKey "GitUrl"
remoteMappingKey :: Path.Absolute -> Text
remoteMappingKey = configKey "RemoteMapping"
@ -46,13 +42,7 @@ resolveConfiguredUrl :: PushPull -> Path' -> Cli (WriteRemoteNamespace Void)
resolveConfiguredUrl pushPull destPath' = do
destPath <- Cli.resolvePath' destPath'
whenNothingM (remoteMappingForPath pushPull destPath) do
let gitUrlConfigKey = gitUrlKey destPath
-- Fall back to deprecated GitUrl key
Cli.getConfig gitUrlConfigKey >>= \case
Just url ->
(WriteRemoteNamespaceGit <$> P.parse UriParser.deprecatedWriteGitRemoteNamespace (Text.unpack gitUrlConfigKey) url) & onLeft \err ->
Cli.returnEarly (ConfiguredRemoteMappingParseError pushPull destPath url (show err))
Nothing -> Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath)
Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath)
-- | Tries to look up a remote mapping for a given path.
-- Will also resolve paths relative to any mapping which is configured for a parent of that

4
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -79,7 +79,7 @@ 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 (handlePull, mergeBranchAndPropagateDefaultPatch)
import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch)
import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch)
import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft)
import Unison.Codebase.Editor.HandleInput.Run (handleRun)
import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils
@ -949,7 +949,6 @@ loop e = do
Cli.respond output
UpdateBuiltinsI -> Cli.respond NotImplemented
QuitI -> Cli.haltRepl
GistI input -> handleGist input
AuthLoginI -> void $ authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver)
VersionI -> do
Cli.Env {ucmVersion} <- ask
@ -1109,7 +1108,6 @@ inputDescription input =
FindShallowI {} -> wat
StructuredFindI {} -> wat
StructuredFindReplaceI {} -> wat
GistI {} -> wat
HistoryI {} -> wat
LibInstallI {} -> wat
ListDependenciesI {} -> wat

57
unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs
View File

@ -43,7 +43,7 @@ import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Builtin.Decls qualified as Builtin.Decls
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..), MergeSourceAndTarget (..))
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..))
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
@ -61,7 +61,7 @@ import Unison.Codebase.Editor.HandleInput.Update2
typecheckedUnisonFileToBranchAdds,
)
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadShareLooseCode (..))
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..))
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
@ -76,7 +76,7 @@ import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ'
import Unison.Merge.CombineDiffs (CombinedDiffOp (..), combineDiffs)
import Unison.Merge.Database (MergeDatabase (..), makeMergeDatabase, referent2to1)
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency)
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency, lenientCheckDeclCoherency)
import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames)
import Unison.Merge.Diff qualified as Merge
import Unison.Merge.DiffOp (DiffOp (..))
@ -220,7 +220,7 @@ doMerge info = do
let aliceBranchNames = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name
let mergeSource = MergeSourceOrTarget'Source info.bob.source
let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames
let mergeSourceAndTarget = MergeSourceAndTarget { alice = aliceBranchNames, bob = info.bob.source }
let mergeSourceAndTarget = MergeSourceAndTarget {alice = aliceBranchNames, bob = info.bob.source}
Cli.Env {codebase} <- ask
@ -267,19 +267,17 @@ doMerge info = do
Cli.returnEarly (Output.MergeDefnsInLib who)
-- Load Alice/Bob/LCA definitions and decl name lookups
(defns3, declNameLookups3) <- do
(defns3, declNameLookups, lcaDeclToConstructors) <- do
let emptyNametree = Nametree {value = Defns Map.empty Map.empty, children = Map.empty}
let loadDefns branch =
Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName ->
Cli.returnEarly case conflictedName of
ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs
ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs
let load = \case
Nothing ->
pure
( Nametree {value = Defns Map.empty Map.empty, children = Map.empty},
DeclNameLookup Map.empty Map.empty
)
Nothing -> pure (emptyNametree, DeclNameLookup Map.empty Map.empty)
Just (who, branch) -> do
defns <-
Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName ->
Cli.returnEarly case conflictedName of
ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs
ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs
defns <- loadDefns branch
declNameLookup <-
Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err ->
Cli.returnEarly case err of
@ -291,23 +289,23 @@ doMerge info = do
IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name
pure (defns, declNameLookup)
(aliceDefns0, aliceDeclNameLookup) <- load (Just (Just mergeTarget, branches.alice))
(bobDefns0, bobDeclNameLookup) <- load (Just (Just mergeSource, branches.bob))
(lcaDefns0, lcaDeclNameLookup) <- load ((Nothing,) <$> branches.lca)
(aliceDefns0, aliceDeclNameLookup) <- load (Just (mergeTarget, branches.alice))
(bobDefns0, bobDeclNameLookup) <- load (Just (mergeSource, branches.bob))
lcaDefns0 <- maybe (pure emptyNametree) loadDefns branches.lca
lcaDeclToConstructors <- Cli.runTransaction (lenientCheckDeclCoherency db.loadDeclNumConstructors lcaDefns0)
let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns)
let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0}
let declNameLookups3 = ThreeWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup, lca = lcaDeclNameLookup}
let declNameLookups = TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup}
pure (defns3, declNameLookups3)
pure (defns3, declNameLookups, lcaDeclToConstructors)
let defns = ThreeWay.forgetLca defns3
let declNameLookups = ThreeWay.forgetLca declNameLookups3
liftIO (debugFunctions.debugDefns defns3 declNameLookups3)
liftIO (debugFunctions.debugDefns defns3 declNameLookups lcaDeclToConstructors)
-- Diff LCA->Alice and LCA->Bob
diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups3 defns3)
diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns3)
liftIO (debugFunctions.debugDiffs diffs)
@ -407,10 +405,6 @@ doMerge info = do
case Path.toName info.path of
Nothing -> "<root>"
Just name -> Name.toText name
MergeSource'RemoteGitRepo info ->
case Path.toName info.path of
Nothing -> "<root>"
Just name -> Name.toText name
}
renderedConflicts
renderedDependents
@ -854,7 +848,6 @@ findTemporaryBranchName projectId mergeSourceAndTarget = do
MergeSource'LocalProjectBranch (ProjectAndBranch _project branch) -> mangleBranchName branch
MergeSource'RemoteProjectBranch (ProjectAndBranch _project branch) -> "remote-" <> mangleBranchName branch
MergeSource'RemoteLooseCode info -> manglePath info.path
MergeSource'RemoteGitRepo info -> manglePath info.path
mangleBranchName :: ProjectBranchName -> Text.Builder
mangleBranchName name =
case classifyProjectBranchName name of
@ -1032,7 +1025,8 @@ data DebugFunctions = DebugFunctions
{ debugCausals :: TwoOrThreeWay (V2.CausalBranch Transaction) -> IO (),
debugDefns ::
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
ThreeWay DeclNameLookup ->
TwoWay DeclNameLookup ->
Map Name [Maybe Name] ->
IO (),
debugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO (),
debugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO (),
@ -1073,9 +1067,10 @@ realDebugCausals causals = do
realDebugDefns ::
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
ThreeWay DeclNameLookup ->
TwoWay DeclNameLookup ->
Map Name [Maybe Name] ->
IO ()
realDebugDefns defns declNameLookups = do
realDebugDefns defns declNameLookups _lcaDeclNameLookup = do
Text.putStrLn (Text.bold "\n=== Alice definitions ===")
debugDefns1 (bimap BiMultimap.range BiMultimap.range defns.alice)

12
unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs
View File

@ -57,17 +57,7 @@ handlePull unresolvedSourceAndTarget pullMode = do
(source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget
remoteCausalHash <- do
Cli.Env {codebase} <- ask
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
@ -136,7 +126,6 @@ handlePull unresolvedSourceAndTarget pullMode = do
ReadShare'ProjectBranch remoteBranch ->
MergeSource'RemoteProjectBranch (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName)
ReadShare'LooseCode info -> MergeSource'RemoteLooseCode info
ReadRemoteNamespaceGit info -> MergeSource'RemoteGitRepo info
},
lca =
LcaMergeInfo
@ -209,7 +198,6 @@ resolveExplicitSource ::
ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) ->
Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
resolveExplicitSource includeSquashed = \case
ReadRemoteNamespaceGit namespace -> pure (ReadRemoteNamespaceGit namespace)
ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace)
ReadShare'ProjectBranch (This remoteProjectName) -> do
remoteProject <- ProjectUtils.expectRemoteProjectByName remoteProjectName

98
unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs
View File

@ -1,13 +1,11 @@
-- | @push@ input handler
module Unison.Codebase.Editor.HandleInput.Push
( handleGist,
handlePushRemoteBranch,
( handlePushRemoteBranch,
)
where
import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO)
import Control.Lens (over, view, (.~), (^.), _1, _2)
import Control.Monad.Reader (ask)
import Data.Set.NonEmpty qualified as Set.NonEmpty
import Data.Text as Text
import Data.These (These (..))
@ -26,13 +24,9 @@ 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 qualified as Codebase
import Unison.Codebase.Branch (Branch (..))
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.HandleInput.AuthLogin qualified as AuthLogin
import Unison.Codebase.Editor.Input
( GistInput (..),
PushRemoteBranchInput (..),
( PushRemoteBranchInput (..),
PushSource (..),
PushSourceTarget (..),
)
@ -40,20 +34,13 @@ import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.Output.PushPull (PushPull (Push))
import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..),
ReadRemoteNamespace (..),
WriteGitRemoteNamespace (..),
WriteRemoteNamespace (..),
( WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..),
writeToReadGit,
)
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.Type (GitPushBehavior (..))
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
import Unison.Hash qualified as Hash
import Unison.Hash32 (Hash32)
import Unison.Hash32 qualified as Hash32
import Unison.NameSegment (NameSegment (..))
@ -76,25 +63,6 @@ import Unison.Sqlite qualified as Sqlite
import Unison.Sync.Types qualified as Share
import Witch (unsafeFrom)
-- | Handle a @gist@ command.
handleGist :: GistInput -> Cli ()
handleGist (GistInput repo) = do
Cli.Env {codebase} <- ask
sourceBranch <- Cli.getCurrentBranch
result <-
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
Cli.respond $
GistCreated $
ReadRemoteNamespaceGit
ReadGitRemoteNamespace
{ repo = writeToReadGit repo,
sch = Just (SCH.fromHash schLength (Branch.headHash sourceBranch)),
path = Path.empty
}
-- | Handle a @push@ command.
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
@ -105,7 +73,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
Nothing -> do
localPath <- Cli.getCurrentPath
UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case
WriteRemoteNamespaceGit namespace -> pushLooseCodeToGitLooseCode localPath namespace pushBehavior
WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior
WriteRemoteProjectBranch v -> absurd v
Just (localProjectAndBranch, _restPath) ->
@ -113,10 +80,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
force
localProjectAndBranch
Nothing
-- push <implicit> to .some.path (git)
PushSourceTarget1 (WriteRemoteNamespaceGit namespace) -> do
localPath <- Cli.getCurrentPath
pushLooseCodeToGitLooseCode localPath namespace pushBehavior
-- push <implicit> to .some.path (share)
PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do
localPath <- Cli.getCurrentPath
@ -130,10 +93,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
Just (localProjectAndBranch, _restPath) ->
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
-- push .some.path to .some.path (git)
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceGit namespace) -> do
localPath <- Cli.resolvePath' localPath0
pushLooseCodeToGitLooseCode localPath namespace pushBehavior
-- push .some.path to .some.path (share)
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do
localPath <- Cli.resolvePath' localPath0
@ -143,13 +102,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
localPath <- Cli.resolvePath' localPath0
remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
-- push @some/project to .some.path (git)
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceGit namespace) -> do
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
pushLooseCodeToGitLooseCode
(ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
namespace
pushBehavior
-- push @some/project to .some.path (share)
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
@ -168,49 +120,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
PushBehavior.RequireEmpty -> False
PushBehavior.RequireNonEmpty -> False
-- Push a local namespace ("loose code") to a Git-hosted remote namespace ("loose code").
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
let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if
-- this rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch`
-- already.
f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing
case Branch.modifyAtM (gitRemotePath ^. #path) f remoteRoot of
Nothing -> Left (RefusedToPush pushBehavior (WriteRemoteNamespaceGit gitRemotePath))
Just newRemoteRoot -> Right newRemoteRoot
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)
behavior
(\remoteRoot -> pure (withRemoteRoot remoteRoot))
result <-
liftIO push & onLeftM \err ->
Cli.returnEarly (Output.GitError err)
_branch <- result & onLeft Cli.returnEarly
Cli.respond Success
where
-- Per `pushBehavior`, we are either:
--
-- (1) force-pushing, in which case the remote branch state doesn't matter
-- (2) updating an empty branch, which fails if the branch isn't empty (`push.create`)
-- (3) updating a non-empty branch, which fails if the branch is empty (`push`)
shouldPushTo :: PushBehavior -> Branch m -> Bool
shouldPushTo pushBehavior remoteBranch =
case pushBehavior of
PushBehavior.ForcePush -> True
PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch)
PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch))
-- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code").
pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli ()
pushLooseCodeToShareLooseCode _ _ _ = do
@ -656,7 +565,6 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do
Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames)
Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName)))
when (not force) do
whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do
Cli.returnEarly (RemoteProjectBranchHeadMismatch Share.hardCodedUri remoteProjectAndBranchNames)

10
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

@ -1,7 +1,6 @@
module Unison.Codebase.Editor.Input
( Input (..),
BranchSourceI (..),
GistInput (..),
PullSourceTarget (..),
PushRemoteBranchInput (..),
PushSourceTarget (..),
@ -32,7 +31,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Text qualified as Text
import Data.These (These)
import Unison.Codebase.Branch.Merge qualified as Branch
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace)
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace)
import Unison.Codebase.Path (Path, Path')
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path
@ -210,7 +209,6 @@ data Input
| UiI Path'
| DocToMarkdownI Name
| DocsToHtmlI Path' FilePath
| GistI GistInput
| AuthLoginI
| VersionI
| ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName)
@ -239,12 +237,6 @@ data BranchSourceI
BranchSourceI'LooseCodeOrProject LooseCodeOrProject
deriving stock (Eq, Show)
-- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@.
data GistInput = GistInput
{ repo :: WriteGitRepo
}
deriving stock (Eq, Show)
-- | Pull source and target: either neither is specified, or only a source, or both.
data PullSourceTarget
= PullSourceTarget0

11
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -45,7 +45,6 @@ import Unison.Codebase.PushBehavior (PushBehavior)
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.Codebase.Type (GitError)
import Unison.CommandLine.InputPattern qualified as Input
import Unison.DataDeclaration qualified as DD
import Unison.DataDeclaration.ConstructorId (ConstructorId)
@ -267,7 +266,6 @@ data Output
-- todo: eventually replace these sets with [SearchResult' v Ann]
-- and a nicer render.
BustedBuiltins (Set Reference) (Set Reference)
| GitError GitError
| ShareError ShareError
| ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName))
| NoConfiguredRemoteMapping PushPull Path.Absolute
@ -401,11 +399,11 @@ data Output
| MergeConflictedTermName !Name !(NESet Referent)
| MergeConflictedTypeName !Name !(NESet TypeReference)
| MergeConflictInvolvingBuiltin !Name
| MergeConstructorAlias !(Maybe MergeSourceOrTarget) !Name !Name
| MergeConstructorAlias !MergeSourceOrTarget !Name !Name
| MergeDefnsInLib !MergeSourceOrTarget
| MergeMissingConstructorName !(Maybe MergeSourceOrTarget) !Name
| MergeNestedDeclAlias !(Maybe MergeSourceOrTarget) !Name !Name
| MergeStrayConstructor !(Maybe MergeSourceOrTarget) !Name
| MergeMissingConstructorName !MergeSourceOrTarget !Name
| MergeNestedDeclAlias !MergeSourceOrTarget !Name !Name
| MergeStrayConstructor !MergeSourceOrTarget !Name
| InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment
data UpdateOrUpgrade = UOUUpdate | UOUUpgrade
@ -535,7 +533,6 @@ isFailure o = case o of
TestIncrementalOutputEnd {} -> False
TestResults _ _ _ _ _ fails -> not (null fails)
CantUndo {} -> True
GitError {} -> True
BustedBuiltins {} -> True
NoConfiguredRemoteMapping {} -> True
ConfiguredRemoteMappingParseError {} -> True

288
unison-cli/src/Unison/Codebase/Editor/UriParser.hs
View File

@ -1,36 +1,26 @@
module Unison.Codebase.Editor.UriParser
( readRemoteNamespaceParser,
writeGitRepo,
deprecatedWriteGitRemoteNamespace,
writeRemoteNamespace,
writeRemoteNamespaceWith,
parseReadShareLooseCode,
)
where
import Data.Char (isAlphaNum, isDigit, isSpace)
import Data.Sequence as Seq
import Data.Char (isAlphaNum)
import Data.Text qualified as Text
import Data.These (These)
import Data.Void
import Text.Megaparsec qualified as P
import Text.Megaparsec.Char qualified as C
import U.Util.Base32Hex qualified as Base32Hex
import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..),
ReadGitRepo (..),
ReadRemoteNamespace (..),
( ReadRemoteNamespace (..),
ReadShareLooseCode (..),
ShareCodeserver (DefaultCodeserver),
ShareUserHandle (..),
WriteGitRemoteNamespace (..),
WriteGitRepo (..),
WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..),
)
import Unison.Codebase.Path (Path (..))
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
import Unison.NameSegment (NameSegment (..))
import Unison.Prelude
import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser)
@ -41,28 +31,9 @@ import Unison.Util.Pretty.MegaParsec qualified as P
type P = P.Parsec Void Text.Text
-- Here are the git protocols that we know how to parse
-- Local Protocol
-- $ git clone /srv/git/project.git
-- $ git clone /srv/git/project.git[:treeish][:[#hash][.path]]
-- File Protocol
-- $ git clone file:///srv/git/project.git[:treeish][:[#hash][.path]]
-- Smart / Dumb HTTP protocol
-- $ git clone https://example.com/gitproject.git[:treeish][:[#hash][.path]]
-- SSH Protocol
-- $ git clone ssh://[user@]server/project.git[:treeish][:[#hash][.path]]
-- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]]
readRemoteNamespaceParser :: ProjectBranchSpecifier branch -> P (ReadRemoteNamespace (These ProjectName branch))
readRemoteNamespaceParser specifier =
ReadRemoteNamespaceGit <$> readGitRemoteNamespace
<|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier
ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier
<|> ReadShare'LooseCode <$> readShareLooseCode
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ::
@ -81,9 +52,7 @@ parseReadShareLooseCode label input =
in first printError (P.parse readShareLooseCode label (Text.pack input))
-- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4"
-- >>> P.parseMaybe writeRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3"
-- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}))
-- Just (WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "git@github.com:unisonweb/base", branch = Just "v3"}, path = _releases.M3}))
writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName))
writeRemoteNamespace =
writeRemoteNamespaceWith
@ -91,8 +60,7 @@ writeRemoteNamespace =
writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a)
writeRemoteNamespaceWith projectBranchParser =
WriteRemoteNamespaceGit <$> writeGitRemoteNamespace
<|> WriteRemoteProjectBranch <$> projectBranchParser
WriteRemoteProjectBranch <$> projectBranchParser
<|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace
-- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4"
@ -130,252 +98,15 @@ shareUserHandle :: P ShareUserHandle
shareUserHandle = do
ShareUserHandle . Text.pack <$> P.some (P.satisfy \c -> isAlphaNum c || c == '-' || c == '_')
-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf"
-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf."
-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)"
-- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3"
-- >>> P.parseMaybe readGitRemoteNamespace "git( user@server:project.git:branch )#asdf.foo.bar"
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = })
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = })
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Nothing, path = })
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sch = Nothing, path = _releases.M3})
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = foo.bar})
readGitRemoteNamespace :: P ReadGitRemoteNamespace
readGitRemoteNamespace = P.label "generic git repo" $ do
C.string "git("
protocol <- parseGitProtocol
treeish <- P.optional gitTreeishSuffix
let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish}
C.string ")"
nshashPath <- P.optional namespaceHashPath
pure case nshashPath of
Nothing -> ReadGitRemoteNamespace {repo, sch = Nothing, path = Path.empty}
Just (sch, path) -> ReadGitRemoteNamespace {repo, sch, path}
-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)"
-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)"
-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Nothing})
-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"})
--
-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git)"
-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git:branch)"
-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing})
-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"})
--
-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git)"
-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git:base)"
-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing})
-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"})
--
-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git)"
-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git:branch)"
-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git)"
-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git:branch)"
-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing})
-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"})
-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Nothing})
-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"})
--
-- >>> P.parseMaybe writeGitRepo "git(server:project)"
-- >>> P.parseMaybe writeGitRepo "git(user@server:project.git:branch)"
-- Just (WriteGitRepo {url = "server:project", branch = Nothing})
-- Just (WriteGitRepo {url = "user@server:project.git", branch = Just "branch"})
writeGitRepo :: P WriteGitRepo
writeGitRepo = P.label "repo root for writing" $ do
C.string "git("
uri <- parseGitProtocol
treeish <- P.optional gitTreeishSuffix
C.string ")"
pure WriteGitRepo {url = printProtocol uri, branch = treeish}
-- | A parser for the deprecated format of git URLs, which may still exist in old GitURL
-- unisonConfigs.
--
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "/srv/git/project.git:.namespace"
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "/srv/git/project.git:branch:.namespace"
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}, path = namespace})
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}, path = namespace})
--
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "file:///srv/git/project.git"
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "file:///srv/git/project.git:branch"
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}, path = })
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}, path = })
--
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "https://example.com/gitproject.git"
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "https://example.com/gitproject.git:base"
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}, path = })
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}, path = })
--
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://user@server/project.git"
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://user@server/project.git:branch"
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://server/project.git"
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://server/project.git:branch"
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}, path = })
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}, path = })
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}, path = })
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}, path = })
--
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "server:project"
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "user@server:project.git:branch"
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "server:project", branch = Nothing}, path = })
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}, path = })
deprecatedWriteGitRemoteNamespace :: P WriteGitRemoteNamespace
deprecatedWriteGitRemoteNamespace = P.label "generic write repo" $ do
repo <- deprecatedWriteGitRepo
path <- P.optional (C.char ':' *> absolutePath)
pure WriteGitRemoteNamespace {repo, path = fromMaybe Path.empty path}
where
deprecatedWriteGitRepo :: P WriteGitRepo
deprecatedWriteGitRepo = do
P.label "repo root for writing" $ do
uri <- parseGitProtocol
treeish <- P.optional deprecatedTreeishSuffix
pure WriteGitRepo {url = printProtocol uri, branch = treeish}
deprecatedTreeishSuffix :: P Text
deprecatedTreeishSuffix = P.label "git treeish" . P.try $ do
void $ C.char ':'
notdothash <- P.noneOf @[] ".#:"
rest <- P.takeWhileP (Just "not colon") (/= ':')
pure $ Text.cons notdothash rest
-- git(myrepo@git.com).foo.bar
writeGitRemoteNamespace :: P WriteGitRemoteNamespace
writeGitRemoteNamespace = P.label "generic write repo" $ do
repo <- writeGitRepo
path <- P.optional absolutePath
pure WriteGitRemoteNamespace {repo, path = fromMaybe Path.empty path}
data GitProtocol
= HttpsProtocol (Maybe User) HostInfo UrlPath
| SshProtocol (Maybe User) HostInfo UrlPath
| ScpProtocol (Maybe User) Host UrlPath
| FileProtocol UrlPath
| LocalProtocol UrlPath
deriving (Eq, Ord, Show)
printProtocol :: GitProtocol -> Text
-- printProtocol x | traceShow x False = undefined
printProtocol x = case x of
HttpsProtocol muser hostInfo path ->
"https://"
<> printUser muser
<> printHostInfo hostInfo
<> path
SshProtocol muser hostInfo path ->
"ssh://"
<> printUser muser
<> printHostInfo hostInfo
<> path
ScpProtocol muser host path -> printUser muser <> host <> ":" <> path
FileProtocol path -> "file://" <> path
LocalProtocol path -> path
where
printUser = maybe mempty (\(User u) -> u <> "@")
printHostInfo :: HostInfo -> Text
printHostInfo (HostInfo hostname mport) =
hostname <> maybe mempty (Text.cons ':') mport
data Scheme = Ssh | Https
deriving (Eq, Ord, Show)
data User = User Text
deriving (Eq, Ord, Show)
type UrlPath = Text
data HostInfo = HostInfo Text (Maybe Text)
deriving (Eq, Ord, Show)
type Host = Text -- no port
-- doesn't yet handle basic authentication like https://user:pass@server.com
-- (does anyone even want that?)
-- or handle ipv6 addresses (https://en.wikipedia.org/wiki/IPv6#Addressing)
parseGitProtocol :: P GitProtocol
parseGitProtocol =
P.label "parseGitProtocol" $
fileRepo <|> httpsRepo <|> sshRepo <|> scpRepo <|> localRepo
where
localRepo, fileRepo, httpsRepo, sshRepo, scpRepo :: P GitProtocol
parsePath =
P.takeWhile1P
(Just "repo path character")
(\c -> not (isSpace c || c == ':' || c == ')'))
localRepo = LocalProtocol <$> parsePath
fileRepo = P.label "fileRepo" $ do
void $ C.string "file://"
FileProtocol <$> parsePath
httpsRepo = P.label "httpsRepo" $ do
void $ C.string "https://"
HttpsProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath
sshRepo = P.label "sshRepo" $ do
void $ C.string "ssh://"
SshProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath
scpRepo =
P.label "scpRepo" . P.try $
ScpProtocol <$> P.optional userInfo <*> parseHost <* C.string ":" <*> parsePath
userInfo :: P User
userInfo = P.label "userInfo" . P.try $ do
username <- P.takeWhile1P (Just "username character") (/= '@')
void $ C.char '@'
pure $ User username
parseHostInfo :: P HostInfo
parseHostInfo =
P.label "parseHostInfo" $
HostInfo
<$> parseHost
<*> ( P.optional $ do
void $ C.char ':'
P.takeWhile1P (Just "digits") isDigit
)
parseHost = P.label "parseHost" $ hostname <|> ipv4 -- <|> ipv6
where
hostname =
P.takeWhile1P
(Just "hostname character")
(\c -> isAlphaNum c || c == '.' || c == '-')
ipv4 = P.label "ipv4 address" $ do
o1 <- decOctet
void $ C.char '.'
o2 <- decOctet
void $ C.char '.'
o3 <- decOctet
void $ C.char '.'
o4 <- decOctet
pure $ Text.pack $ o1 <> "." <> o2 <> "." <> o3 <> "." <> o4
decOctet = P.count' 1 3 C.digitChar
-- >>> P.parseMaybe namespaceHashPath "#nshashabc.path.foo.bar"
-- Just (Just #nshashabc,path.foo.bar)
--
-- >>> P.parseMaybe namespaceHashPath ".path.foo.bar"
-- Just (Nothing,path.foo.bar)
--
-- >>> P.parseMaybe namespaceHashPath "#nshashabc"
-- Just (Just #nshashabc,)
--
-- >>> P.parseMaybe namespaceHashPath "#nshashabc."
-- Just (Just #nshashabc,)
--
-- >>> P.parseMaybe namespaceHashPath "."
-- Just (Nothing,)
namespaceHashPath :: P (Maybe ShortCausalHash, Path)
namespaceHashPath = do
sch <- P.optional shortCausalHash
p <- P.optional absolutePath
pure (sch, fromMaybe Path.empty p)
-- >>> P.parseMaybe absolutePath "."
-- Just
--
-- >>> P.parseMaybe absolutePath ".path.foo.bar"
-- Just path.foo.bar
absolutePath :: P Path
absolutePath = do
void $ C.char '.'
Path . Seq.fromList <$> P.sepBy nameSegment (C.char '.')
nameSegment :: P NameSegment
nameSegment =
NameSegment.unsafeParseText . Text.pack
@ -383,14 +114,3 @@ nameSegment =
<$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar
<*> P.many (P.satisfy Unison.Syntax.Lexer.wordyIdChar)
)
gitTreeishSuffix :: P Text
gitTreeishSuffix = P.label "git treeish" . P.try $ do
void $ C.char ':'
P.takeWhile1P (Just "not close paren") (/= ')')
shortCausalHash :: P ShortCausalHash
shortCausalHash = P.label "short causal hash" $ do
void $ C.char '#'
ShortCausalHash
<$> P.takeWhile1P (Just "base32hex chars") (`elem` Base32Hex.validChars)

83
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

@ -64,7 +64,6 @@ module Unison.CommandLine.InputPatterns
findVerbose,
findVerboseAll,
forkLocal,
gist,
help,
helpTopics,
history,
@ -165,8 +164,7 @@ import Unison.Codebase.Branch.Merge qualified as Branch
import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input)
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push))
import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace)
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace)
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Editor.SlurpResult qualified as SR
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
@ -217,6 +215,7 @@ import Unison.Syntax.Name qualified as Name (parseTextEither, toText)
import Unison.Syntax.NameSegment qualified as NameSegment
import Unison.Util.ColorText qualified as CT
import Unison.Util.Monoid (intercalateMap)
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Pretty qualified as P
import Unison.Util.Pretty.MegaParsec (prettyPrintParseError)
@ -2858,35 +2857,6 @@ createAuthor =
('"' : quoted) -> init quoted
bare -> bare
gist :: InputPattern
gist =
InputPattern
"push.gist"
["gist"]
I.Visible
[("repository", Required, gitUrlArg)]
( P.lines
[ "Publish the current namespace.",
"",
P.wrapColumn2
[ ( "`gist git(git@github.com:user/repo)`",
"publishes the contents of the current namespace into the specified git repo."
)
],
"",
P.indentN 2 . P.wrap $
"Note: Gists are not yet supported on Unison Share, though you can just do a normal"
<> "`push.create` of the current namespace to your Unison Share codebase wherever you like!"
]
)
( \case
[repoString] ->
fmap (Input.GistI . Input.GistInput)
. parseWriteGitRepo "gist git repo"
=<< unsupportedStructuredArgument "a VCS repository" repoString
_ -> Left (showPatternHelp gist)
)
authLogin :: InputPattern
authLogin =
InputPattern
@ -3231,7 +3201,6 @@ validInputs =
sfind,
sfindReplace,
forkLocal,
gist,
help,
helpTopics,
history,
@ -3423,39 +3392,12 @@ filePathArg =
fzfResolver = Nothing
}
-- Arya: I could imagine completions coming from previous pulls
gitUrlArg :: ArgumentType
gitUrlArg =
ArgumentType
{ typeName = "git-url",
suggestions =
let complete s = pure [Completion s s False]
in \input _ _ _ -> case input of
"gh" -> complete "git(https://github.com/"
"gl" -> complete "git(https://gitlab.com/"
"bb" -> complete "git(https://bitbucket.com/"
"ghs" -> complete "git(git@github.com:"
"gls" -> complete "git(git@gitlab.com:"
"bbs" -> complete "git(git@bitbucket.com:"
_ -> pure [],
fzfResolver = Nothing
}
-- | Refers to a namespace on some remote code host.
remoteNamespaceArg :: ArgumentType
remoteNamespaceArg =
ArgumentType
{ typeName = "remote-namespace",
suggestions =
let complete s = pure [Completion s s False]
in \input _cb http _p -> case input of
"gh" -> complete "git(https://github.com/"
"gl" -> complete "git(https://gitlab.com/"
"bb" -> complete "git(https://bitbucket.com/"
"ghs" -> complete "git(git@github.com:"
"gls" -> complete "git(git@gitlab.com:"
"bbs" -> complete "git(git@bitbucket.com:"
_ -> sharePathCompletion http input,
suggestions = \input _cb http _p -> sharePathCompletion http input,
fzfResolver = Nothing
}
@ -3907,27 +3849,18 @@ parseHashQualifiedName s =
Right
$ HQ.parseText (Text.pack s)
parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo
parseWriteGitRepo label input = do
first
(fromString . show) -- turn any parsing errors into a Pretty.
(Megaparsec.parse (UriParser.writeGitRepo <* Megaparsec.eof) label (Text.pack input))
explainRemote :: PushPull -> P.Pretty CT.ColorText
explainRemote pushPull =
P.group $
P.lines
[ P.wrap $ "where `remote` is a hosted codebase, such as:",
[ P.wrap $ "where `remote` is a project or project branch, such as:",
P.indentN 2 . P.column2 $
[ ("Unison Share", P.backticked "user.public.some.remote.path"),
("Git + root", P.backticked $ "git(" <> gitRepo <> "user/repo)"),
("Git + path", P.backticked $ "git(" <> gitRepo <> "user/repo).some.remote.path"),
("Git + branch", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch)"),
("Git + branch + path", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch).some.remote.path")
[ ("Project (defaults to the /main branch)", P.backticked "@unison/base"),
("Project Branch", P.backticked "@unison/base/feature"),
("Contributor Branch", P.backticked "@unison/base/@johnsmith/feature")
]
<> Monoid.whenM (pushPull == Pull) [("Project Release", P.backticked "@unison/base/releases/1.0.0")]
]
where
gitRepo = PushPull.fold @(P.Pretty P.ColorText) "git@github.com:" "https://github.com/" pushPull
megaparse :: Megaparsec.Parsec Void Text a -> Text -> Either (P.Pretty P.ColorText) a
megaparse parser input =

157
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -35,7 +35,6 @@ import U.Codebase.Branch (NamespaceStats (..))
import U.Codebase.Branch.Diff (NameChanges (..))
import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Reference qualified as Reference
import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion))
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import Unison.ABT qualified as ABT
@ -65,7 +64,6 @@ import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
import Unison.Codebase.Editor.StructuredArgument qualified as SA
import Unison.Codebase.Editor.TodoOutput qualified as TO
import Unison.Codebase.GitError
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors)
import Unison.Codebase.Patch (Patch (..))
import Unison.Codebase.Patch qualified as Patch
@ -75,9 +73,7 @@ import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..))
import Unison.Codebase.TermEdit qualified as TermEdit
import Unison.Codebase.Type (GitError (GitCodebaseError, GitProtocolError, GitSqliteCodebaseError))
import Unison.Codebase.TypeEdit qualified as TypeEdit
import Unison.CommandLine (bigproblem, note, tip)
import Unison.CommandLine.FZFResolvers qualified as FZFResolvers
@ -1097,133 +1093,6 @@ notifyUser dir = \case
pure . P.wrap $
"I loaded " <> P.text sourceName <> " and didn't find anything."
else pure mempty
GitError e -> pure $ case e of
GitSqliteCodebaseError e -> case e of
CodebaseFileLockFailed ->
P.wrap $
"It looks to me like another ucm process is using this codebase. Only one ucm process can use a codebase at a time."
NoDatabaseFile repo localPath ->
P.wrap $
"I didn't find a codebase in the repository at"
<> prettyReadGitRepo repo
<> "in the cache directory at"
<> P.backticked' (P.string localPath) "."
CodebaseRequiresMigration (SchemaVersion fromSv) (SchemaVersion toSv) -> do
P.wrap $
"The specified codebase codebase is on version "
<> P.shown fromSv
<> " but needs to be on version "
<> P.shown toSv
UnrecognizedSchemaVersion repo localPath (SchemaVersion v) ->
P.wrap $
"I don't know how to interpret schema version "
<> P.shown v
<> "in the repository at"
<> prettyReadGitRepo repo
<> "in the cache directory at"
<> P.backticked' (P.string localPath) "."
GitCouldntParseRootBranchHash repo s ->
P.wrap $
"I couldn't parse the string"
<> P.red (P.string s)
<> "into a namespace hash, when opening the repository at"
<> P.group (prettyReadGitRepo repo <> ".")
GitProtocolError e -> case e of
NoGit ->
P.wrap $
"I couldn't find git. Make sure it's installed and on your path."
CleanupError e ->
P.wrap $
"I encountered an exception while trying to clean up a git cache directory:"
<> P.group (P.shown e)
CloneException repo msg ->
P.wrap $
"I couldn't clone the repository at"
<> prettyReadGitRepo repo
<> ";"
<> "the error was:"
<> (P.indentNAfterNewline 2 . P.group . P.string) msg
CopyException srcRepoPath destPath msg ->
P.wrap $
"I couldn't copy the repository at"
<> P.string srcRepoPath
<> "into"
<> P.string destPath
<> ";"
<> "the error was:"
<> (P.indentNAfterNewline 2 . P.group . P.string) msg
PushNoOp repo ->
P.wrap $
"The repository at" <> prettyWriteGitRepo repo <> "is already up-to-date."
PushException repo msg ->
P.wrap $
"I couldn't push to the repository at"
<> prettyWriteGitRepo repo
<> ";"
<> "the error was:"
<> (P.indentNAfterNewline 2 . P.group . P.string) msg
RemoteRefNotFound repo ref ->
P.wrap $
"I couldn't find the ref " <> P.green (P.text ref) <> " in the repository at " <> P.blue (P.text repo) <> ";"
UnrecognizableCacheDir uri localPath ->
P.wrap $
"A cache directory for"
<> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri)
<> "already exists at"
<> P.backticked' (P.string localPath) ","
<> "but it doesn't seem to"
<> "be a git repository, so I'm not sure what to do next. Delete it?"
UnrecognizableCheckoutDir uri localPath ->
P.wrap $
"I tried to clone"
<> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri)
<> "into a cache directory at"
<> P.backticked' (P.string localPath) ","
<> "but I can't recognize the"
<> "result as a git repository, so I'm not sure what to do next."
PushDestinationHasNewStuff repo ->
P.callout "⏸" . P.lines $
[ P.wrap $
"The repository at"
<> prettyWriteGitRepo repo
<> "has some changes I don't know about.",
"",
P.wrap $ "Try" <> pull <> "to merge these changes locally, then" <> push <> "again."
]
where
push = P.group . P.backticked . IP.patternName $ IP.push
pull = P.group . P.backticked . IP.patternName $ IP.pull
GitCodebaseError e -> case e of
CouldntFindRemoteBranch repo path ->
P.wrap $
"I couldn't find the remote branch at"
<> P.shown path
<> "in the repository at"
<> prettyReadGitRepo repo
NoRemoteNamespaceWithHash repo sch ->
P.wrap $
"The repository at"
<> prettyReadGitRepo repo
<> "doesn't contain a namespace with the hash prefix"
<> (P.blue . P.text . SCH.toText) sch
RemoteNamespaceHashAmbiguous repo sch hashes ->
P.lines
[ P.wrap $
"The namespace hash"
<> prettySCH sch
<> "at"
<> prettyReadGitRepo repo
<> "is ambiguous."
<> "Did you mean one of these hashes?",
"",
P.indentN 2 $
P.lines
( prettySCH . SCH.fromHash ((Text.length . SCH.toText) sch * 2)
<$> Set.toList hashes
),
"",
P.wrap "Try again with a few more hash characters to disambiguate."
]
BustedBuiltins (Set.toList -> new) (Set.toList -> old) ->
-- todo: this could be prettier! Have a nice list like `find` gives, but
-- that requires querying the codebase to determine term types. Probably
@ -1272,7 +1141,7 @@ notifyUser dir = \case
"Type `help " <> PushPull.fold "push" "pull" pp <> "` for more information."
]
-- | ConfiguredGitUrlParseError PushPull Path' Text String
-- | ConfiguredRemoteMappingParseError PushPull Path' Text String
ConfiguredRemoteMappingParseError pp p url err ->
pure . P.fatalCallout . P.lines $
[ P.wrap $
@ -1493,12 +1362,10 @@ notifyUser dir = \case
"There's a merge conflict on"
<> P.group (prettyName name <> ",")
<> "but it's a builtin on one or both branches. We can't yet handle merge conflicts on builtins."
MergeConstructorAlias maybeAliceOrBob name1 name2 ->
MergeConstructorAlias aliceOrBob name1 name2 ->
pure . P.wrap $
"On"
<> case maybeAliceOrBob of
Nothing -> "the LCA,"
Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> prettyName name1
<> "and"
<> prettyName name2
@ -1509,32 +1376,26 @@ notifyUser dir = \case
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "there's a type or term directly in the `lib` namespace, but I expected only library dependencies to be in there."
<> "Please remove it before merging."
MergeMissingConstructorName maybeAliceOrBob name ->
MergeMissingConstructorName aliceOrBob name ->
pure . P.wrap $
"On"
<> case maybeAliceOrBob of
Nothing -> "the LCA,"
Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName name
<> "is missing a name for one of its constructors. Please add one before merging."
MergeNestedDeclAlias maybeAliceOrBob shorterName longerName ->
MergeNestedDeclAlias aliceOrBob shorterName longerName ->
pure . P.wrap $
"On"
<> case maybeAliceOrBob of
Nothing -> "the LCA,"
Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName longerName
<> "is an alias of"
<> P.group (prettyName shorterName <> ".")
<> "Type aliases cannot be nested. Please make them disjoint before merging."
MergeStrayConstructor maybeAliceOrBob name ->
MergeStrayConstructor aliceOrBob name ->
pure . P.wrap $
"On"
<> case maybeAliceOrBob of
Nothing -> "the LCA,"
Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the constructor"
<> prettyName name
<> "is not in a subnamespace of a name of its type."

2
unison-cli/tests/Main.hs
View File

@ -6,7 +6,6 @@ import System.IO
import System.IO.CodePage (withCP65001)
import Unison.Test.ClearCache qualified as ClearCache
import Unison.Test.Cli.Monad qualified as Cli.Monad
import Unison.Test.GitSync qualified as GitSync
import Unison.Test.LSP qualified as LSP
import Unison.Test.UriParser qualified as UriParser
@ -16,7 +15,6 @@ test =
[ LSP.test,
ClearCache.test,
Cli.Monad.test,
GitSync.test,
UriParser.test
]

732
unison-cli/tests/Unison/Test/GitSync.hs
View File

@ -1,732 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Test.GitSync where
import Data.Maybe (fromJust)
import Data.String.Here.Interpolated (i)
import Data.Text qualified as Text
import EasyTest
import Shellmet ()
import System.Directory (removePathForcibly)
import System.FilePath ((</>))
import System.IO.Temp qualified as Temp
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.Symbol (Symbol)
import Unison.Test.Ucm (CodebaseFormat, Transcript)
import Unison.Test.Ucm qualified as Ucm
import Unison.WatchKind (pattern TestWatch)
transcriptOutputFile :: String -> FilePath
transcriptOutputFile name =
(".." </> "unison-src" </> "transcripts" </> ("GitSync22." ++ name ++ ".output.md"))
-- keep it off for CI, since the random temp dirs it generates show up in the
-- output, which causes the test output to change, and the "no change" check
-- to fail
writeTranscriptOutput :: Bool
writeTranscriptOutput = False
test :: Test ()
test =
scope "gitsync22" . tests $
fastForwardPush
: nonFastForwardPush
: destroyedRemote
: flip
map
[(Ucm.CodebaseFormat2, "sc")]
\(fmt, name) ->
scope name $
tests
[ pushPullTest
"pull-over-deleted-namespace"
fmt
( \repo ->
[i|
```unison:hide
x = 1
```
```ucm:hide
.> add
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```unison:hide
child.y = 2
```
Should be able to pull a branch from the repo over top of our deleted local branch.
```ucm
.> add
.> delete.namespace child
.> pull git(${repo}) child
```
|]
),
pushPullTest
"pull.without-history"
fmt
( \repo ->
[i|
```unison:hide
child.x = 1
```
```ucm:hide
.> add
```
```unison:hide
child.y = 2
```
```ucm:hide
.> add
```
```unison:hide
child.x = 3
```
```ucm:hide
.> update
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
Should be able to pull the branch from the remote without its history.
Note that this only tests that the pull succeeds, since (at time of writing) we don't
track/test transcript output for these tests in the unison repo.
```ucm
.> pull.without-history git(${repo}):.child .child
.> history .child
```
|]
),
pushPullTest
"push-over-deleted-namespace"
fmt
( \repo ->
[i|
```unison:hide
child.x = 1
y = 2
```
```ucm:hide
.> add
.> delete.namespace child
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```unison:hide
child.z = 3
```
Should be able to push a branch over top of a deleted remote branch.
```ucm
.> add
.> push.create git(${repo}).child child
```
|]
),
pushPullTest
"typeAlias"
fmt
( \repo ->
[i|
```ucm
.> alias.type ##Nat builtin.Nat
.> history
.> history builtin
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```ucm
.> pull git(${repo})
```
```unison
x : Nat
x = 3
```
|]
),
pushPullTest
"topLevelTerm"
fmt
( \repo ->
[i|
```unison:hide
y = 3
```
```ucm
.> add
.> history
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```ucm
.> pull git(${repo})
.> find
```
```unison
> y
```
|]
),
pushPullTest
"subNamespace"
fmt
( \repo ->
[i|
```ucm
.> alias.type ##Nat builtin.Nat
```
```unison
unique type a.b.C = C Nat
a.b.d = 4
```
```ucm
.> add
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```ucm
.> pull.silent git(${repo})
.> find
```
```unison
> a.b.C.C a.b.d
```
|]
),
pushPullTest
"accessPatch"
fmt
( \repo ->
[i|
```ucm
.> alias.type ##Nat builtin.Nat
```
```unison:hide
unique type A = A Nat
foo = A.A 3
```
```ucm
.> debug.file
.> add
```
```unison:hide
unique type A = A Nat Nat
foo = A.A 3 3
```
```ucm
.> debug.file
.> update
```
```ucm
.> view.patch patch
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```ucm
.> pull.silent git(${repo})
.> view.patch patch
```
|]
),
pushPullTest
"history"
fmt
( \repo ->
[i|
```unison
foo = 3
```
```ucm
.> add
```
```unison
foo = 4
```
```ucm
.> update
.> history
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```ucm
.> pull git(${repo})
.> history
.> reset-root #l43v9nr16v
.> history
```
|] -- Not sure why this hash is here.
-- Is it to test `reset-root`?
-- Or to notice a change in hashing?
-- Or to test that two distinct points of history were pulled?
-- It would be great to not need the explicit hash here,
-- since it does change periodically.
-- Though, I guess that should also be rare, so maybe this is fine.
),
pushPullTest
"one-term"
fmt
-- simplest-author
( \repo ->
[i|
```unison
c = 3
```
```ucm
.> debug.file
.myLib> add
.myLib> push.create git(${repo})
```
|]
)
-- simplest-user
( \repo ->
[i|
```ucm
.yourLib> pull git(${repo})
```
```unison
> c
```
|]
),
pushPullTest
"one-type"
fmt
-- simplest-author
( \repo ->
[i|
```unison
structural type Foo = Foo
```
```ucm
.myLib> debug.file
.myLib> add
.myLib> push.create git(${repo})
```
|]
)
-- simplest-user
( \repo ->
[i|
```ucm
.yourLib> pull git(${repo})
```
```unison
> Foo.Foo
```
|]
),
pushPullTest
"patching"
fmt
( \repo ->
[i|
```ucm
.myLib> alias.term ##Nat.+ +
```
```unison
improveNat x = x + 3
```
```ucm
.myLib> add
.myLib> ls
.myLib> move.namespace .myLib .workaround1552.myLib.v1
.workaround1552.myLib> ls
.workaround1552.myLib> fork v1 v2
.workaround1552.myLib.v2>
```
```unison
improveNat x = x + 100
```
```ucm
.workaround1552.myLib.v2> update
.workaround1552.myLib> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```ucm
.myApp> pull git(${repo}).v1 external.yourLib
.myApp> alias.term ##Nat.* *
````
```unison
greatApp = improveNat 5 * improveNat 6
> greatApp
```
```ucm
.myApp> add
.myApp> pull git(${repo}).v2 external.yourLib
```
```unison
> greatApp
```
```ucm
.myApp> patch external.yourLib.patch
```
```unison
> greatApp
```
|]
),
-- TODO: remove the alias.type .defns.A A line once patch syncing is fixed
pushPullTest
"lightweightPatch"
fmt
( \repo ->
[i|
```ucm
.> builtins.merge
```
```unison
structural type A = A Nat
structural type B = B Int
x = 3
y = 4
```
```ucm
.defns> add
.patches> replace .defns.A .defns.B
.patches> alias.type .defns.A A
.patches> replace .defns.x .defns.y
.patches> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```ucm
.> builtins.merge
.> pull git(${repo}) patches
.> view.patch patches.patch
```
|]
),
watchPushPullTest
"test-watches"
fmt
( \repo ->
[i|
```ucm
.> builtins.merge
```
```unison
test> pass = [Ok "Passed"]
```
```ucm
.> add
.> push.create git(${repo})
```
|]
)
( \repo ->
[i|
```ucm
.> pull git(${repo})
```
|]
)
( \cb -> do
Codebase.runTransaction cb do
void . fmap (fromJust . sequence) $
traverse (Codebase.getWatch cb TestWatch)
=<< Codebase.watches TestWatch
),
gistTest fmt,
pushPullBranchesTests fmt,
pushPullTest
"fix2068_a_"
fmt
-- this triggers
{-
gitsync22.sc.fix2068(a) EXCEPTION!!!: Called SqliteCodebase.setNamespaceRoot on unknown causal hash CausalHash (fromBase32Hex "codddvgt1ep57qpdkhe2j4pe1ehlpi5iitcrludtb8ves1aaqjl453onvfphqg83vukl7bbrj49itceqfob2b3alf47u4vves5s7pog")
CallStack (from HasCallStack):
error, called at src/Unison/Codebase/SqliteCodebase.hs:1072:17 in unison-parser-typechecker-0.0.0-6U6boimwb8GAC5qrhLfs8h:Unison.Codebase.SqliteCodebase
-}
( \repo ->
[i|
```ucm
.> alias.type ##Nat builtin.Nat2
.> alias.type ##Int builtin.Int2
.> push.create git(${repo}).foo.bar
```
|]
)
( \repo ->
[i|
```ucm
.> pull git(${repo}) pulled
.> view pulled.foo.bar.builtin.Nat2
.> view pulled.foo.bar.builtin.Int2
```
|]
),
pushPullTest
"fix2068_b_"
fmt
-- this triggers
{-
- gitsync22.sc.fix2068(b) EXCEPTION!!!: I couldn't find the hash ndn6fa85ggqtbgffqhd4d3bca2d08pgp3im36oa8k6p257aid90ovjq75htmh7lmg7akaqneva80ml1o21iscjmp9n1uc3lmqgg9rgg that I just synced to the cached copy of /private/var/folders/6m/p3szds2j67d8vwmxr51yrf5c0000gn/T/git-simple-1047398c149d3d5c/repo.git in "/Users/pchiusano/.cache/unisonlanguage/gitfiles/$x2F$private$x2F$var$x2F$folders$x2F$6m$x2F$p3szds2j67d8vwmxr51yrf5c0000gn$x2F$T$x2F$git-simple-1047398c149d3d5c$x2F$repo$dot$git".
CallStack (from HasCallStack):
error, called at src/Unison/Codebase/SqliteCodebase.hs:1046:13 in unison-parser-typechecker-0.0.0-6U6boimwb8GAC5qrhLfs8h:Unison.Codebase.SqliteCodebase
-}
( \repo ->
[i|
```ucm
.> alias.type ##Nat builtin.Nat2
.> alias.type ##Int builtin.Int2
.> push.create git(${repo})
.> push.create git(${repo}).foo.bar
```
|]
)
( \repo ->
[i|
```ucm
.> pull git(${repo}) pulled
.> view pulled.foo.bar.builtin.Nat2
.> view pulled.foo.bar.builtin.Int2
```
|]
)
]
pushPullTest :: String -> CodebaseFormat -> (FilePath -> Transcript) -> (FilePath -> Transcript) -> Test ()
pushPullTest name fmt authorScript userScript = scope name do
io do
repo <- initGitRepo
author <- Ucm.initCodebase fmt
authorOutput <- Ucm.runTranscript author (authorScript repo)
user <- Ucm.initCodebase fmt
userOutput <- Ucm.runTranscript user (userScript repo)
when writeTranscriptOutput $
writeUtf8
(transcriptOutputFile name)
(Text.pack $ authorOutput <> "\n-------\n" <> userOutput)
-- if we haven't crashed, clean up!
removePathForcibly repo
Ucm.deleteCodebase author
Ucm.deleteCodebase user
ok
watchPushPullTest :: String -> CodebaseFormat -> (FilePath -> Transcript) -> (FilePath -> Transcript) -> (Codebase IO Symbol Ann -> IO ()) -> Test ()
watchPushPullTest name fmt authorScript userScript codebaseCheck = scope name do
io do
repo <- initGitRepo
author <- Ucm.initCodebase fmt
authorOutput <- Ucm.runTranscript author (authorScript repo)
user <- Ucm.initCodebase fmt
userOutput <- Ucm.runTranscript user (userScript repo)
Ucm.lowLevel user codebaseCheck
when writeTranscriptOutput $
writeUtf8
(transcriptOutputFile name)
(Text.pack $ authorOutput <> "\n-------\n" <> userOutput)
-- if we haven't crashed, clean up!
removePathForcibly repo
Ucm.deleteCodebase author
Ucm.deleteCodebase user
ok
gistTest :: CodebaseFormat -> Test ()
gistTest fmt =
pushPullTest "gist" fmt authorScript userScript
where
authorScript repo =
[i|
```unison:hide
y = 3
```
```ucm
.> add
.> gist git(${repo})
```
|]
userScript repo =
[i|
```ucm
.> pull git(${repo})#td09c6jlks
.> find
```
```unison
> y
```
|]
pushPullBranchesTests :: CodebaseFormat -> Test ()
pushPullBranchesTests fmt = scope "branches" $ do
simplePushPull
multiplePushPull
emptyBranchFailure
where
simplePushPull =
let authorScript repo =
[i|
```unison:hide
y = 3
```
```ucm
.> add
.> push.create git(${repo}:mybranch).path
```
|]
userScript repo =
[i|
```ucm
.> pull git(${repo}:mybranch) .dest
.> view .dest.path.y
```
|]
in pushPullTest "simple" fmt authorScript userScript
emptyBranchFailure =
let authorScript _repo = ""
userScript repo =
[i|
```ucm:error
.> pull git(${repo}:mybranch) .dest
```
|]
in pushPullTest "empty" fmt authorScript userScript
multiplePushPull =
let authorScript repo =
[i|
```unison:hide
ns1.x = 10
ns2.y = 20
```
```ucm
.> add
.> push.create git(${repo}:mybranch).ns1 .ns1
.> push.create git(${repo}:mybranch).ns2 .ns2
```
```unison
ns1.x = 11
ns1.new = 12
```
```ucm
.> update
.> push git(${repo}:mybranch).ns1 .ns1
```
|]
userScript repo =
[i|
```ucm
.> pull git(${repo}:mybranch).ns1 .ns1
.> pull git(${repo}:mybranch).ns2 .ns2
.> view .ns1.x
.> view .ns1.new
.> view .ns2.y
```
|]
in pushPullTest "multiple" fmt authorScript userScript
fastForwardPush :: Test ()
fastForwardPush = scope "fastforward-push" do
io do
repo <- initGitRepo
author <- Ucm.initCodebase Ucm.CodebaseFormat2
void $
Ucm.runTranscript
author
[i|
```ucm
.lib> alias.type ##Nat Nat
.lib> push.create git(${repo})
.lib> alias.type ##Int Int
.lib> push git(${repo})
```
|]
ok
nonFastForwardPush :: Test ()
nonFastForwardPush = scope "non-fastforward-push" do
io do
repo <- initGitRepo
author <- Ucm.initCodebase Ucm.CodebaseFormat2
void $
Ucm.runTranscript
author
[i|
```ucm:error
.lib> alias.type ##Nat Nat
.lib> push git(${repo})
.lib2> alias.type ##Int Int
.lib2> push git(${repo})
```
|]
ok
destroyedRemote :: Test ()
destroyedRemote = scope "destroyed-remote" do
io do
repo <- initGitRepo
codebase <- Ucm.initCodebase Ucm.CodebaseFormat2
void $
Ucm.runTranscript
codebase
[i|
```ucm
.lib> alias.type ##Nat Nat
.lib> push.create git(${repo})
```
|]
reinitRepo repo
void $
Ucm.runTranscript
codebase
[i|
```ucm
.lib> push.create git(${repo})
```
|]
ok
where
reinitRepo repoStr@(Text.pack -> repo) = do
removePathForcibly repoStr
"git" ["init", "--bare", repo]
initGitRepo :: IO FilePath
initGitRepo = do
tmp <- Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory ("git-simple")
let repo = tmp </> "repo.git"
"git" ["init", "--bare", Text.pack repo]
pure repo

44
unison-cli/tests/Unison/Test/UriParser.hs
View File

@ -6,7 +6,7 @@ import Data.These (These (..))
import Data.Void (Void)
import EasyTest
import Text.Megaparsec qualified as P
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..), ReadRemoteNamespace (..), ShareCodeserver (..), ShareUserHandle (..), WriteGitRemoteNamespace (..), WriteGitRepo (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), pattern ReadGitRemoteNamespace, pattern ReadShareLooseCode)
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), ShareCodeserver (..), ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), pattern ReadShareLooseCode)
import Unison.Codebase.Editor.UriParser qualified as UriParser
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
@ -23,22 +23,7 @@ test =
[ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]),
("project", branchR (This "project")),
("/branch", branchR (That "branch")),
("project/branch", branchR (These "project" "branch")),
("git(/srv/git/project.git)", gitR "/srv/git/project.git" Nothing Nothing []),
("git(/srv/git/project.git:abc)#def.hij.klm", gitR "/srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
("git(srv/git/project.git)", gitR "srv/git/project.git" Nothing Nothing []),
("git(srv/git/project.git:abc)#def.hij.klm", gitR "srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
("git(file:///srv/git/project.git)", gitR "file:///srv/git/project.git" Nothing Nothing []),
("git(file:///srv/git/project.git:abc)#def.hij.klm", gitR "file:///srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
("git(file://srv/git/project.git)", gitR "file://srv/git/project.git" Nothing Nothing []),
("git(file://srv/git/project.git:abc)#def.hij.klm", gitR "file://srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
("git(https://example.com/git/project.git)", gitR "https://example.com/git/project.git" Nothing Nothing []),
("git(https://user@example.com/git/project.git:abc)#def.hij.klm", gitR "https://user@example.com/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
("git(ssh://git@8.8.8.8:222/user/project.git)", gitR "ssh://git@8.8.8.8:222/user/project.git" Nothing Nothing []),
("git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", gitR "ssh://git@github.com/user/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
("git(git@github.com:user/project.git)", gitR "git@github.com:user/project.git" Nothing Nothing []),
("git(github.com:user/project.git)", gitR "github.com:user/project.git" Nothing Nothing []),
("git(git@github.com:user/project.git:abc)#def.hij.klm", gitR "git@github.com:user/project.git" (Just "abc") (sch "def") ["hij", "klm"])
("project/branch", branchR (These "project" "branch"))
]
[".unisonweb.base"],
parserTests
@ -47,33 +32,12 @@ test =
[ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]),
("project", branchW (This "project")),
("/branch", branchW (That "branch")),
("project/branch", branchW (These "project" "branch")),
("git(/srv/git/project.git)", gitW "/srv/git/project.git" Nothing []),
("git(srv/git/project.git)", gitW "srv/git/project.git" Nothing []),
("git(file:///srv/git/project.git)", gitW "file:///srv/git/project.git" Nothing []),
("git(file://srv/git/project.git)", gitW "file://srv/git/project.git" Nothing []),
("git(https://example.com/git/project.git)", gitW "https://example.com/git/project.git" Nothing []),
("git(ssh://git@8.8.8.8:222/user/project.git)", gitW "ssh://git@8.8.8.8:222/user/project.git" Nothing []),
("git(git@github.com:user/project.git)", gitW "git@github.com:user/project.git" Nothing []),
("git(github.com:user/project.git)", gitW "github.com:user/project.git" Nothing [])
("project/branch", branchW (These "project" "branch"))
]
[ ".unisonweb.base",
"git(/srv/git/project.git:abc)#def.hij.klm",
"git(srv/git/project.git:abc)#def.hij.klm",
"git(file:///srv/git/project.git:abc)#def.hij.klm",
"git(file://srv/git/project.git:abc)#def.hij.klm",
"git(https://user@example.com/git/project.git:abc)#def.hij.klm",
"git(ssh://git@github.com/user/project.git:abc)#def.hij.klm",
"git(git@github.com:user/project.git:abc)#def.hij.klm"
[ ".unisonweb.base"
]
]
gitR :: Text -> Maybe Text -> Maybe ShortCausalHash -> [NameSegment] -> ReadRemoteNamespace void
gitR url ref sch path = ReadRemoteNamespaceGit (ReadGitRemoteNamespace (ReadGitRepo url ref) sch (Path.fromList path))
gitW :: Text -> Maybe Text -> [NameSegment] -> WriteRemoteNamespace void
gitW url branch path = WriteRemoteNamespaceGit (WriteGitRemoteNamespace (WriteGitRepo url branch) (Path.fromList path))
looseR :: Text -> [NameSegment] -> ReadRemoteNamespace void
looseR user path =
ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (Path.fromList path))

3
unison-cli/unison-cli.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.36.0.
-- This file has been generated from package.yaml by hpack version 0.35.2.
--
-- see: https://github.com/sol/hpack
@ -428,7 +428,6 @@ test-suite cli-tests
other-modules:
Unison.Test.ClearCache
Unison.Test.Cli.Monad
Unison.Test.GitSync
Unison.Test.LSP
Unison.Test.Ucm
Unison.Test.UriParser

17
unison-core/src/Unison/DataDeclaration.hs
View File

@ -33,10 +33,11 @@ module Unison.DataDeclaration
constructors_,
asDataDecl_,
declAsDataDecl_,
setConstructorNames,
)
where
import Control.Lens (Iso', Lens', imap, iso, lens, over, _3)
import Control.Lens (Iso', Lens', imap, iso, lens, over, set, _2, _3)
import Control.Monad.State (evalState)
import Data.Map qualified as Map
import Data.Set qualified as Set
@ -164,6 +165,20 @@ constructorVars dd = fst <$> constructors dd
constructorNames :: (Var v) => DataDeclaration v a -> [Text]
constructorNames dd = Var.name <$> constructorVars dd
-- | Overwrite the constructor names with the given list, given in canonical order, which is assumed to be of the
-- correct length.
--
-- Presumably this is called because the decl was loaded from the database outside of the context of a namespace,
-- since it's not stored with names there, so we had plugged in dummy names like "Constructor1", "Constructor2", ...
--
-- Then, at some point, we discover the constructors' names in a namespace, and now we'd like to combine the two
-- together to get a Decl structure in memory with good/correct names for constructors.
setConstructorNames :: [v] -> Decl v a -> Decl v a
setConstructorNames constructorNames =
over
(declAsDataDecl_ . constructors_)
(zipWith (set _2) constructorNames)
-- This function is unsound, since the `rid` and the `decl` have to match.
-- It should probably be hashed directly from the Decl, once we have a
-- reliable way of doing that. —AI

183
unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs
View File

@ -82,10 +82,11 @@
module Unison.Merge.DeclCoherencyCheck
( IncoherentDeclReason (..),
checkDeclCoherency,
lenientCheckDeclCoherency,
)
where
import Control.Lens (view, (%=), (.=))
import Control.Lens (over, view, (%=), (.=), _2)
import Control.Monad.Except (ExceptT)
import Control.Monad.Except qualified as Except
import Control.Monad.State.Strict (StateT)
@ -101,6 +102,7 @@ import Data.Maybe (fromJust)
import Data.Set qualified as Set
import U.Codebase.Reference (Reference' (..), TypeReference, TypeReferenceId)
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Merge.DeclNameLookup (DeclNameLookup (..))
import Unison.Name (Name)
import Unison.Name qualified as Name
@ -108,9 +110,8 @@ import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Sqlite (Transaction)
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.Map qualified as Map (deleteLookup, upsertF)
import Unison.Util.Map qualified as Map (deleteLookup, deleteLookupJust, upsertF)
import Unison.Util.Nametree (Nametree (..))
data IncoherentDeclReason
@ -129,9 +130,11 @@ data IncoherentDeclReason
| IncoherentDeclReason'StrayConstructor !Name
checkDeclCoherency ::
(TypeReferenceId -> Transaction Int) ->
forall m.
Monad m =>
(TypeReferenceId -> m Int) ->
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
Transaction (Either IncoherentDeclReason DeclNameLookup)
m (Either IncoherentDeclReason DeclNameLookup)
checkDeclCoherency loadDeclNumConstructors =
Except.runExceptT
. fmap (view #declNameLookup)
@ -140,10 +143,10 @@ checkDeclCoherency loadDeclNumConstructors =
where
go ::
[NameSegment] ->
(Nametree (Defns (Map NameSegment Referent) (Map NameSegment TypeReference))) ->
StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason Transaction) ()
go prefix (Nametree Defns {terms, types} children) = do
for_ (Map.toList terms) \case
(Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason m) ()
go prefix (Nametree defns children) = do
for_ (Map.toList defns.terms) \case
(_, Referent.Ref _) -> pure ()
(_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure ()
(name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do
@ -152,35 +155,33 @@ checkDeclCoherency loadDeclNumConstructors =
#expectedConstructors .= expectedConstructors1
where
f ::
Maybe (Name, IntMap MaybeConstructorName) ->
Either IncoherentDeclReason (Name, IntMap MaybeConstructorName)
Maybe (Name, ConstructorNames) ->
Either IncoherentDeclReason (Name, ConstructorNames)
f = \case
Nothing -> Left (IncoherentDeclReason'StrayConstructor (fullName name))
Just (typeName, expected) -> (typeName,) <$> IntMap.alterF g (fromIntegral @Word64 @Int conId) expected
where
g :: Maybe MaybeConstructorName -> Either IncoherentDeclReason (Maybe MaybeConstructorName)
g = \case
Nothing -> error "didnt put expected constructor id"
Just NoConstructorNameYet -> Right (Just (YesConstructorName (fullName name)))
Just (YesConstructorName firstName) ->
Left (IncoherentDeclReason'ConstructorAlias firstName (fullName name))
Nothing -> Left (IncoherentDeclReason'StrayConstructor name1)
Just (typeName, expected) ->
case recordConstructorName conId name1 expected of
Left existingName -> Left (IncoherentDeclReason'ConstructorAlias existingName name1)
Right expected1 -> Right (typeName, expected1)
where
name1 = fullName name
childrenWeWentInto <-
forMaybe (Map.toList types) \case
forMaybe (Map.toList defns.types) \case
(_, ReferenceBuiltin _) -> pure Nothing
(name, ReferenceDerived typeRef) -> do
DeclCoherencyCheckState {expectedConstructors} <- State.get
whatHappened <- do
let recordNewDecl ::
Maybe (Name, IntMap MaybeConstructorName) ->
Compose (ExceptT IncoherentDeclReason Transaction) WhatHappened (Name, IntMap MaybeConstructorName)
Maybe (Name, ConstructorNames) ->
Compose (ExceptT IncoherentDeclReason m) WhatHappened (Name, ConstructorNames)
recordNewDecl =
Compose . \case
Just (shorterTypeName, _) -> Except.throwError (IncoherentDeclReason'NestedDeclAlias shorterTypeName typeName)
Nothing ->
lift (loadDeclNumConstructors typeRef) <&> \case
0 -> UninhabitedDecl
n -> InhabitedDecl (typeName, IntMap.fromAscList [(i, NoConstructorNameYet) | i <- [0 .. n - 1]])
n -> InhabitedDecl (typeName, emptyConstructorNames n)
lift (getCompose (Map.upsertF recordNewDecl typeRef expectedConstructors))
case whatHappened of
UninhabitedDecl -> do
@ -197,18 +198,88 @@ checkDeclCoherency loadDeclNumConstructors =
let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) =
Map.deleteLookup typeRef expectedConstructors
constructorNames <-
unMaybeConstructorNames maybeConstructorNames & onNothing do
sequence (IntMap.elems maybeConstructorNames) & onNothing do
Except.throwError (IncoherentDeclReason'MissingConstructorName typeName)
#expectedConstructors .= expectedConstructors1
#declNameLookup %= \declNameLookup ->
DeclNameLookup
{ constructorToDecl =
List.foldl'
(\acc constructorName -> Map.insert constructorName typeName acc)
declNameLookup.constructorToDecl
constructorNames,
declToConstructors = Map.insert typeName constructorNames declNameLookup.declToConstructors
}
#declNameLookup . #constructorToDecl %= \constructorToDecl ->
List.foldl'
(\acc constructorName -> Map.insert constructorName typeName acc)
constructorToDecl
constructorNames
#declNameLookup . #declToConstructors %= Map.insert typeName constructorNames
pure (Just name)
where
typeName = fullName name
let childrenWeHaventGoneInto = children `Map.withoutKeys` Set.fromList childrenWeWentInto
for_ (Map.toList childrenWeHaventGoneInto) \(name, child) -> go (name : prefix) child
where
fullName name =
Name.fromReverseSegments (name :| prefix)
-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns a mapping from decl name to
-- constructor names, where constructor names can be missing.
--
-- This function exists merely to extract a best-effort decl-name-to-constructor-name mapping for the LCA of a merge.
-- We require Alice and Bob to have coherent decls, but their LCA is out of the user's control and may have incoherent
-- decls, and whether or not it does, we still need to compute *some* syntactic hash for its decls.
lenientCheckDeclCoherency ::
forall m.
Monad m =>
(TypeReferenceId -> m Int) ->
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
m (Map Name [Maybe Name])
lenientCheckDeclCoherency loadDeclNumConstructors =
fmap (view #declToConstructors)
. (`State.execStateT` LenientDeclCoherencyCheckState Map.empty Map.empty)
. go []
where
go ::
[NameSegment] ->
(Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
StateT LenientDeclCoherencyCheckState m ()
go prefix (Nametree defns children) = do
for_ (Map.toList defns.terms) \case
(_, Referent.Ref _) -> pure ()
(_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure ()
(name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do
#expectedConstructors %= Map.adjust (Map.map (lenientRecordConstructorName conId (fullName name))) typeRef
childrenWeWentInto <-
forMaybe (Map.toList defns.types) \case
(_, ReferenceBuiltin _) -> pure Nothing
(name, ReferenceDerived typeRef) -> do
whatHappened <- do
let recordNewDecl :: m (WhatHappened (Map Name ConstructorNames))
recordNewDecl =
loadDeclNumConstructors typeRef <&> \case
0 -> UninhabitedDecl
n -> InhabitedDecl (Map.singleton typeName (emptyConstructorNames n))
state <- State.get
lift (getCompose (Map.upsertF (\_ -> Compose recordNewDecl) typeRef state.expectedConstructors))
case whatHappened of
UninhabitedDecl -> do
#declToConstructors %= Map.insert typeName []
pure Nothing
InhabitedDecl expectedConstructors1 -> do
let child = Map.findWithDefault (Nametree (Defns Map.empty Map.empty) Map.empty) name children
#expectedConstructors .= expectedConstructors1
go (name : prefix) child
state <- State.get
let (maybeConstructorNames, expectedConstructors) =
Map.alterF f typeRef state.expectedConstructors
where
f ::
Maybe (Map Name ConstructorNames) ->
(ConstructorNames, Maybe (Map Name ConstructorNames))
f =
-- fromJust is safe here because we upserted `typeRef` key above
-- deleteLookupJust is safe here because we upserted `typeName` key above
fromJust
>>> Map.deleteLookupJust typeName
>>> over _2 \m -> if Map.null m then Nothing else Just m
#expectedConstructors .= expectedConstructors
#declToConstructors %= Map.insert typeName (IntMap.elems maybeConstructorNames)
pure (Just name)
where
typeName = fullName name
@ -220,23 +291,47 @@ checkDeclCoherency loadDeclNumConstructors =
Name.fromReverseSegments (name :| prefix)
data DeclCoherencyCheckState = DeclCoherencyCheckState
{ expectedConstructors :: !(Map TypeReferenceId (Name, IntMap MaybeConstructorName)),
{ expectedConstructors :: !(Map TypeReferenceId (Name, ConstructorNames)),
declNameLookup :: !DeclNameLookup
}
deriving stock (Generic)
data MaybeConstructorName
= NoConstructorNameYet
| YesConstructorName !Name
data LenientDeclCoherencyCheckState = LenientDeclCoherencyCheckState
{ expectedConstructors :: !(Map TypeReferenceId (Map Name ConstructorNames)),
declToConstructors :: !(Map Name [Maybe Name])
}
deriving stock (Generic)
unMaybeConstructorNames :: IntMap MaybeConstructorName -> Maybe [Name]
unMaybeConstructorNames =
traverse f . IntMap.elems
-- A partial mapping from constructor id to name; a collection of constructor names starts out with the correct number
-- of keys (per the number of data constructors) all mapped to Nothing. Then, as names are discovered by walking a
-- name tree, Nothings become Justs.
type ConstructorNames =
IntMap (Maybe Name)
-- Make an empty set of constructor names given the number of constructors.
emptyConstructorNames :: Int -> ConstructorNames
emptyConstructorNames numConstructors =
IntMap.fromAscList [(i, Nothing) | i <- [0 .. numConstructors - 1]]
recordConstructorName :: HasCallStack => ConstructorId -> Name -> ConstructorNames -> Either Name ConstructorNames
recordConstructorName conId conName =
IntMap.alterF f (fromIntegral @Word64 @Int conId)
where
f :: MaybeConstructorName -> Maybe Name
f :: Maybe (Maybe Name) -> Either Name (Maybe (Maybe Name))
f = \case
NoConstructorNameYet -> Nothing
YesConstructorName name -> Just name
Nothing -> error (reportBug "E397219" ("recordConstructorName: didn't expect constructor id " ++ show conId))
Just Nothing -> Right (Just (Just conName))
Just (Just existingName) -> Left existingName
lenientRecordConstructorName :: ConstructorId -> Name -> ConstructorNames -> ConstructorNames
lenientRecordConstructorName conId conName =
IntMap.adjust f (fromIntegral @Word64 @Int conId)
where
f :: Maybe Name -> Maybe Name
f = \case
Nothing -> Just conName
-- Ignore constructor alias, just keep first name we found
Just existingName -> Just existingName
data WhatHappened a
= UninhabitedDecl

25
unison-merge/src/Unison/Merge/DeclNameLookup.hs
View File

@ -2,19 +2,13 @@ module Unison.Merge.DeclNameLookup
( DeclNameLookup (..),
expectDeclName,
expectConstructorNames,
setConstructorNames,
)
where
import Control.Lens (over)
import Data.Map.Strict qualified as Map
import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as DataDeclaration
import Unison.Name (Name)
import Unison.Prelude
import Unison.Syntax.Name qualified as Name
import Unison.Var (Var)
-- | A lookup from decl-to-constructor name and vice-versa.
--
@ -57,22 +51,3 @@ expectConstructorNames DeclNameLookup {declToConstructors} x =
case Map.lookup x declToConstructors of
Nothing -> error (reportBug "E077058" ("Expected decl name key " <> show x <> " in decl name lookup"))
Just y -> y
-- | Set the constructor names of a data declaration.
--
-- Presumably this is used because the decl was loaded from the database outside of the context of a namespace, because
-- it's not stored with names there, so we plugged in dummy names like "Constructor1", "Constructor2", ...
--
-- Then, at some point, a `DeclNameLookup` was constructed for the corresponding namespace, and now we'd like to
-- combine the two together to get a Decl structure in memory with good/correct names for constructors.
setConstructorNames :: forall a v. Var v => DeclNameLookup -> Name -> Decl v a -> Decl v a
setConstructorNames declNameLookup name =
case Map.lookup name declNameLookup.declToConstructors of
Nothing -> id
Just constructorNames ->
over
(DataDeclaration.declAsDataDecl_ . DataDeclaration.constructors_)
( zipWith
(\realConName (ann, _junkConName, typ) -> (ann, Name.toVar realConName, typ))
constructorNames
)

58
unison-merge/src/Unison/Merge/Diff.hs
View File

@ -9,23 +9,30 @@ import Data.Semialign (alignWith)
import Data.Set qualified as Set
import Data.These (These (..))
import U.Codebase.Reference (TypeReference)
import Unison.Hash (Hash)
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as DataDeclaration
import Unison.Hash (Hash (Hash))
import Unison.HashQualified' qualified as HQ'
import Unison.Merge.Database (MergeDatabase (..))
import Unison.Merge.DeclNameLookup (DeclNameLookup)
import Unison.Merge.DeclNameLookup qualified as DeclNameLookup
import Unison.Merge.DiffOp (DiffOp (..))
import Unison.Merge.Synhash qualified as Synhash
import Unison.Merge.Synhash
import Unison.Merge.Synhashed (Synhashed (..))
import Unison.Merge.ThreeWay (ThreeWay (..))
import Unison.Merge.ThreeWay qualified as ThreeWay
import Unison.Merge.TwoWay (TwoWay (..))
import Unison.Merge.Updated (Updated (..))
import Unison.Name (Name)
import Unison.Parser.Ann (Ann)
import Unison.Prelude hiding (catMaybes)
import Unison.PrettyPrintEnv (PrettyPrintEnv (..))
import Unison.PrettyPrintEnv qualified as Ppe
import Unison.Reference (Reference' (..), TypeReferenceId)
import Unison.Referent (Referent)
import Unison.Sqlite (Transaction)
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith)
@ -40,12 +47,29 @@ import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith)
-- branches. If the hash of a name did not change, it will not appear in the map.
nameBasedNamespaceDiff ::
MergeDatabase ->
ThreeWay DeclNameLookup ->
TwoWay DeclNameLookup ->
Map Name [Maybe Name] ->
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
Transaction (TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference))
nameBasedNamespaceDiff db declNameLookups defns = do
diffs <- sequence (synhashDefns <$> declNameLookups <*> defns)
pure (diffNamespaceDefns diffs.lca <$> TwoWay {alice = diffs.alice, bob = diffs.bob})
nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns = do
lcaHashes <-
synhashDefnsWith
hashTerm
( \name -> \case
ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin)
ReferenceDerived ref ->
case sequence (lcaDeclToConstructors Map.! name) of
-- If we don't have a name for every constructor, that's okay, just use a dummy syntactic hash here.
-- This is safe; Alice/Bob can't have such a decl (it violates a merge precondition), so there's no risk
-- that we accidentally get an equal hash and classify a real update as unchanged.
Nothing -> pure (Hash mempty)
Just names -> do
decl <- loadDeclWithGoodConstructorNames names ref
pure (synhashDerivedDecl ppe name decl)
)
defns.lca
hashes <- sequence (synhashDefns <$> declNameLookups <*> ThreeWay.forgetLca defns)
pure (diffNamespaceDefns lcaHashes <$> hashes)
where
synhashDefns ::
DeclNameLookup ->
@ -55,16 +79,20 @@ nameBasedNamespaceDiff db declNameLookups defns = do
-- FIXME: use cache so we only synhash each thing once
synhashDefnsWith hashTerm hashType
where
hashTerm :: Referent -> Transaction Hash
hashTerm =
Synhash.hashTerm db.loadV1Term ppe
hashType :: Name -> TypeReference -> Transaction Hash
hashType name =
Synhash.hashDecl
(fmap (DeclNameLookup.setConstructorNames declNameLookup name) . db.loadV1Decl)
ppe
name
hashType name = \case
ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin)
ReferenceDerived ref -> do
decl <- loadDeclWithGoodConstructorNames (DeclNameLookup.expectConstructorNames declNameLookup name) ref
pure (synhashDerivedDecl ppe name decl)
loadDeclWithGoodConstructorNames :: [Name] -> TypeReferenceId -> Transaction (Decl Symbol Ann)
loadDeclWithGoodConstructorNames names =
fmap (DataDeclaration.setConstructorNames (map Name.toVar names)) . db.loadV1Decl
hashTerm :: Referent -> Transaction Hash
hashTerm =
synhashTerm db.loadV1Term ppe
ppe :: PrettyPrintEnv
ppe =

50
unison-merge/src/Unison/Merge/Synhash.hs
View File

@ -24,9 +24,10 @@
-- "foo" would have the same syntactic hash. This indicates (to our merge algorithm) that this was an auto-propagated
-- update.
module Unison.Merge.Synhash
( hashType,
hashTerm,
hashDecl,
( synhashType,
synhashTerm,
synhashBuiltinDecl,
synhashDerivedDecl,
)
where
@ -72,8 +73,8 @@ isDeclTag, isTermTag :: H.Token Hash
isDeclTag = H.Tag 0
isTermTag = H.Tag 1
hashBuiltinDecl :: Text -> Hash
hashBuiltinDecl name =
synhashBuiltinDecl :: Text -> Hash
synhashBuiltinDecl name =
H.accumulate [isBuiltinTag, isDeclTag, H.Text name]
hashBuiltinTerm :: Text -> Hash
@ -104,23 +105,6 @@ hashConstructorNameToken declName conName =
)
in H.Text (Name.toText strippedConName)
-- | Syntactically hash a decl, using reference names rather than hashes. Two decls will have the same syntactic hash if
-- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same,
-- the constructors appear in the same order and have the same names, and the constructors' types have the same
-- syntactic hashes.
hashDecl ::
(Monad m, Var v) =>
(TypeReferenceId -> m (Decl v a)) ->
PrettyPrintEnv ->
Name ->
TypeReference ->
m Hash
hashDecl loadDecl ppe name = \case
ReferenceBuiltin builtin -> pure (hashBuiltinDecl builtin)
ReferenceDerived ref -> do
decl <- loadDecl ref
pure (hashDerivedDecl ppe name decl)
hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash
hashDerivedTerm ppe t =
H.accumulate $ isNotBuiltinTag : hashTermTokens ppe t
@ -148,8 +132,12 @@ hashDeclTokens :: Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token]
hashDeclTokens ppe name decl =
hashConstructorType (DD.constructorType decl) : hashDataDeclTokens ppe name (DD.asDataDecl decl)
hashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash
hashDerivedDecl ppe name decl =
-- | Syntactically hash a decl, using reference names rather than hashes. Two decls will have the same syntactic hash if
-- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same,
-- the constructors appear in the same order and have the same names, and the constructors' types have the same
-- syntactic hashes.
synhashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash
synhashDerivedDecl ppe name decl =
H.accumulate $ isNotBuiltinTag : hashDeclTokens ppe name decl
hashHQNameToken :: HashQualified Name -> Token
@ -218,8 +206,14 @@ hashReferentTokens ppe referent =
-- | Syntactically hash a term, using reference names rather than hashes.
-- Two terms will have the same syntactic hash if they would
-- print the the same way under the given pretty-print env.
hashTerm :: forall m v a. (Monad m, Var v) => (TypeReferenceId -> m (Term v a)) -> PrettyPrintEnv -> V1.Referent -> m Hash
hashTerm loadTerm ppe = \case
synhashTerm ::
forall m v a.
(Monad m, Var v) =>
(TypeReferenceId -> m (Term v a)) ->
PrettyPrintEnv ->
V1.Referent ->
m Hash
synhashTerm loadTerm ppe = \case
V1.Referent.Con ref CT.Data -> pure (hashDerivedTerm ppe (Term.constructor @v () ref))
V1.Referent.Con ref CT.Effect -> pure (hashDerivedTerm ppe (Term.request @v () ref))
V1.Referent.Ref (ReferenceBuiltin builtin) -> pure (hashBuiltinTerm builtin)
@ -269,8 +263,8 @@ hashTermFTokens ppe = \case
-- | Syntactically hash a type, using reference names rather than hashes.
-- Two types will have the same syntactic hash if they would
-- print the the same way under the given pretty-print env.
hashType :: Var v => PrettyPrintEnv -> Type v a -> Hash
hashType ppe t =
synhashType :: Var v => PrettyPrintEnv -> Type v a -> Hash
synhashType ppe t =
H.accumulate $ hashTypeTokens ppe t
hashTypeTokens :: forall v a. Var v => PrettyPrintEnv -> Type v a -> [Token]

67
unison-src/transcripts/merge.md
View File

@ -1300,3 +1300,70 @@ project/alice> merge /bob
```ucm:hide
.> project.delete project
```
## LCA precondition violations
The LCA is not subject to most precondition violations, which is good, because the user can't easily manipulate it!
Here's an example. We'll delete a constructor name from the LCA and still be able to merge Alice and Bob's stuff
together.
```ucm:hide
.> project.create-empty project
project/main> builtins.mergeio
```
LCA:
```unison
structural type Foo = Bar Nat | Baz Nat Nat
```
```ucm
project/main> add
project/main> delete.term Foo.Baz
```
Alice's branch:
```ucm
project/main> branch alice
project/alice> delete.type Foo
project/alice> delete.term Foo.Bar
```
```unison
alice : Nat
alice = 100
```
```ucm
project/alice> add
```
Bob's branch:
```ucm
project/main> branch bob
project/bob> delete.type Foo
project/bob> delete.term Foo.Bar
```
```unison
bob : Nat
bob = 101
```
```ucm
project/bob> add
```
Now we merge:
```ucm
project/alice> merge /bob
```
```ucm:hide
.> project.delete project
```

136
unison-src/transcripts/merge.output.md
View File

@ -1144,3 +1144,139 @@ project/alice> merge /bob
there. Please remove it before merging.
```
## LCA precondition violations
The LCA is not subject to most precondition violations, which is good, because the user can't easily manipulate it!
Here's an example. We'll delete a constructor name from the LCA and still be able to merge Alice and Bob's stuff
together.
LCA:
```unison
structural type Foo = Bar Nat | Baz Nat Nat
```
```ucm
Loading changes detected in scratch.u.
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
structural type Foo
```
```ucm
project/main> add
⍟ I've added these definitions:
structural type Foo
project/main> delete.term Foo.Baz
Done.
```
Alice's branch:
```ucm
project/main> branch alice
Done. I've created the alice branch based off of main.
Tip: To merge your work back into the main branch, first
`switch /main` then `merge /alice`.
project/alice> delete.type Foo
Done.
project/alice> delete.term Foo.Bar
Done.
```
```unison
alice : Nat
alice = 100
```
```ucm
Loading changes detected in scratch.u.
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
alice : Nat
```
```ucm
project/alice> add
⍟ I've added these definitions:
alice : Nat
```
Bob's branch:
```ucm
project/main> branch bob
Done. I've created the bob branch based off of main.
Tip: To merge your work back into the main branch, first
`switch /main` then `merge /bob`.
project/bob> delete.type Foo
Done.
project/bob> delete.term Foo.Bar
Done.
```
```unison
bob : Nat
bob = 101
```
```ucm
Loading changes detected in scratch.u.
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
bob : Nat
```
```ucm
project/bob> add
⍟ I've added these definitions:
bob : Nat
```
Now we merge:
```ucm
project/alice> merge /bob
I merged project/bob into project/alice.
```