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

⅄ trunk → 24-05-20-upgrade-commit

Browse Source
This commit is contained in:
Mitchell Rosen 2024-05-30 14:47:10 -04:00
commit 83d6946c60
90 changed files with 1870 additions and 5507 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

2
.github/workflows/ci.yaml vendored
View File

@ -378,7 +378,7 @@ jobs:
contents: |
```ucm
.> project.create-empty jit-setup
jit-setup/main> pull ${{ env.jit_version }} lib.jit
jit-setup/main> lib.install ${{ env.jit_version }}
```
```unison
go = generateSchemeBoot "${{ env.jit_generated_src_scheme }}"

4
.github/workflows/nix-dev-cache.yaml vendored
View File

@ -23,12 +23,12 @@ jobs:
- macOS-12
steps:
- uses: actions/checkout@v4
- uses: cachix/install-nix-action@v22
- uses: cachix/install-nix-action@v27
with:
extra_nix_config: |
extra-trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=
extra-substituters = https://cache.iog.io
- uses: cachix/cachix-action@v12
- uses: cachix/cachix-action@v15
with:
name: unison
authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'

4
.gitignore vendored
View File

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

3
README.md
View File

@ -1,7 +1,8 @@
The Unison language
===================
[![Build Status](https://github.com/unisonweb/unison/actions/workflows/ci.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/ci.yaml?query=branch%3Atrunk)
[![CI Status](https://github.com/unisonweb/unison/actions/workflows/ci.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/ci.yaml?query=branch%3Atrunk)
[![Pre-Release Status](https://github.com/unisonweb/unison/actions/workflows/pre-release.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/pre-release.yaml)
* [Overview](#overview)
* [Building using Stack](#building-using-stack)

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

9
parser-typechecker/src/Unison/Codebase/BranchUtil.hs
View File

@ -15,8 +15,6 @@ module Unison.Codebase.BranchUtil
makeAddTermName,
makeDeleteTermName,
makeAnnihilateTermName,
makeDeletePatch,
makeReplacePatch,
)
where
@ -24,7 +22,6 @@ import Data.Map qualified as Map
import Data.Set qualified as Set
import Unison.Codebase.Branch (Branch, Branch0)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
import Unison.HashQualified' (HashQualified (HashQualified, NameOnly))
@ -83,12 +80,6 @@ makeAnnihilateTermName (p, name) = (p, Branch.annihilateTermName name)
makeAnnihilateTypeName :: Path.Split -> (Path, Branch0 m -> Branch0 m)
makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name)
makeReplacePatch :: (Applicative m) => Path.Split -> Patch -> (Path, Branch0 m -> Branch0 m)
makeReplacePatch (p, name) patch = (p, Branch.replacePatch name patch)
makeDeletePatch :: Path.Split -> (Path, Branch0 m -> Branch0 m)
makeDeletePatch (p, name) = (p, Branch.deletePatch name)
makeAddTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m)
makeAddTypeName (p, name) r = (p, Branch.addTypeName r name)

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,

11
parser-typechecker/src/Unison/Codebase/Execute.hs
View File

@ -14,17 +14,19 @@ import Unison.Codebase.MainTerm (getMainTerm)
import Unison.Codebase.MainTerm qualified as MainTerm
import Unison.Codebase.Runtime (Runtime)
import Unison.Codebase.Runtime qualified as Runtime
import Unison.HashQualified qualified as HQ
import Unison.Name (Name)
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualified qualified as HQ (toText)
import Unison.Util.Pretty qualified as P
execute ::
Codebase.Codebase IO Symbol Ann ->
Runtime Symbol ->
Text ->
HQ.HashQualified Name ->
IO (Either Runtime.Error ())
execute codebase runtime mainName =
(`finally` Runtime.terminate runtime) . runExceptT $ do
@ -34,9 +36,8 @@ execute codebase runtime mainName =
let mainType = Runtime.mainType runtime
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType
case mt of
MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.text s)
MainTerm.NotFound s -> throwError ("Not found: " <> P.text s)
MainTerm.BadType s _ -> throwError (P.text s <> " is not of type '{IO} ()")
MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s))
MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()")
MainTerm.Success _ tm _ -> do
let codeLookup = Codebase.toCodeLookup codebase
ppe = PPE.empty

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)

43
parser-typechecker/src/Unison/Codebase/MainTerm.hs
View File

@ -16,7 +16,6 @@ import Unison.Parser.Ann qualified as Parser.Ann
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Referent qualified as Referent
import Unison.Syntax.HashQualified qualified as HQ (parseText)
import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Type (Type)
@ -26,37 +25,33 @@ import Unison.Var (Var)
import Unison.Var qualified as Var
data MainTerm v
= NotAFunctionName Text
| NotFound Text
| BadType Text (Maybe (Type v Ann))
= NotFound (HQ.HashQualified Name)
| BadType (HQ.HashQualified Name) (Maybe (Type v Ann))
| Success (HQ.HashQualified Name) (Term v Ann) (Type v Ann)
getMainTerm ::
(Monad m, Var v) =>
(Reference -> m (Maybe (Type v Ann))) ->
Names.Names ->
Text ->
HQ.HashQualified Name ->
Type.Type v Ann ->
m (MainTerm v)
getMainTerm loadTypeOfTerm parseNames mainName mainType =
case HQ.parseText mainName of
Nothing -> pure (NotAFunctionName mainName)
Just hq -> do
let refs = Names.lookupHQTerm Names.IncludeSuffixes hq parseNames
let a = Parser.Ann.External
case toList refs of
[] -> pure (NotFound mainName)
[Referent.Ref ref] -> do
typ <- loadTypeOfTerm ref
case typ of
Just typ ->
if Typechecker.fitsScheme typ mainType
then do
let tm = DD.forceTerm a a (Term.ref a ref)
return (Success hq tm typ)
else pure (BadType mainName $ Just typ)
_ -> pure (BadType mainName Nothing)
_ -> pure (error "multiple matching refs") -- TODO: make a real exception
getMainTerm loadTypeOfTerm parseNames mainName mainType = do
let refs = Names.lookupHQTerm Names.IncludeSuffixes mainName parseNames
let a = Parser.Ann.External
case toList refs of
[] -> pure (NotFound mainName)
[Referent.Ref ref] -> do
typ <- loadTypeOfTerm ref
case typ of
Just typ ->
if Typechecker.fitsScheme typ mainType
then do
let tm = DD.forceTerm a a (Term.ref a ref)
return (Success mainName tm typ)
else pure (BadType mainName $ Just typ)
_ -> pure (BadType mainName Nothing)
_ -> pure (error "multiple matching refs") -- TODO: make a real exception
-- forall x. '{ io2.IO, Exception } x
builtinMain :: (Var v) => a -> Type.Type v a

9
parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs
View File

@ -2,6 +2,7 @@ module Unison.Codebase.ShortCausalHash
( toString,
toHash,
fromHash,
fromFullHash,
fromText,
ShortCausalHash (..),
)
@ -27,6 +28,14 @@ fromHash :: (Coercible h Hash.Hash) => Int -> h -> ShortCausalHash
fromHash len =
ShortCausalHash . Text.take len . Hash.toBase32HexText . coerce
-- | This allows a full hash to be preserved as a `ShortCausalHash`.
--
-- `ShortCausalHash` is used for input when we expect a user to enter a hash on the command line, so they aren’t
-- required to enter the full hash. However, these inputs may also come from an internal source, and in such cases,
-- there is no reason to truncate the hash.
fromFullHash :: (Coercible h Hash.Hash) => h -> ShortCausalHash
fromFullHash = ShortCausalHash . Hash.toBase32HexText . coerce
-- abc -> SCH abc
-- #abc -> SCH abc
fromText :: Text -> Maybe ShortCausalHash

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

10
parser-typechecker/src/Unison/Util/Convert.hs
View File

@ -1,10 +0,0 @@
module Unison.Util.Convert where
class Convert a b where
convert :: a -> b
class Parse a b where
parse :: a -> Maybe b
instance (Parse a a2, Parse b b2) => Parse (a, b) (a2, b2) where
parse (a, b) = (,) <$> parse a <*> parse b

6
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
@ -178,7 +175,6 @@ library
Unison.UnisonFile.Names
Unison.UnisonFile.Summary
Unison.UnisonFile.Type
Unison.Util.Convert
Unison.Util.CycleTable
Unison.Util.CyclicEq
Unison.Util.CyclicOrd

24
unison-cli/src/ArgParse.hs
View File

@ -17,6 +17,7 @@ import Options.Applicative
ParserPrefs,
ReadM,
action,
argument,
auto,
columns,
command,
@ -32,6 +33,7 @@ import Options.Applicative
info,
infoOption,
long,
maybeReader,
metavar,
option,
parserFailure,
@ -53,21 +55,21 @@ import System.Environment (lookupEnv)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path
import Unison.CommandLine.Types (ShouldWatchFiles (..))
import Unison.HashQualified (HashQualified)
import Unison.LSP (LspFormattingConfig (..))
import Unison.Name (Name)
import Unison.Prelude
import Unison.PrettyTerminal qualified as PT
import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
import Unison.Server.CodebaseServer qualified as Server
import Unison.Syntax.HashQualified qualified as HQ
import Unison.Util.Pretty (Width (..))
-- The name of a symbol to execute.
type SymbolName = Text
-- | Valid ways to provide source code to the run command
data RunSource
= RunFromPipe SymbolName
| RunFromSymbol SymbolName
| RunFromFile FilePath SymbolName
= RunFromPipe (HashQualified Name)
| RunFromSymbol (HashQualified Name)
| RunFromFile FilePath (HashQualified Name)
| RunCompiled FilePath
deriving (Show, Eq)
@ -368,22 +370,26 @@ versionParser = pure PrintVersion
runArgumentParser :: Parser [String]
runArgumentParser = many (strArgument (metavar "RUN-ARGS"))
runHQParser :: Parser (HashQualified Name)
runHQParser =
argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL")
runSymbolParser :: Parser Command
runSymbolParser =
Run . RunFromSymbol <$> strArgument (metavar "SYMBOL") <*> runArgumentParser
Run . RunFromSymbol <$> runHQParser <*> runArgumentParser
runFileParser :: Parser Command
runFileParser =
Run
<$> ( RunFromFile
<$> fileArgument "path/to/file"
<*> strArgument (metavar "SYMBOL")
<*> runHQParser
)
<*> runArgumentParser
runPipeParser :: Parser Command
runPipeParser =
Run . RunFromPipe <$> strArgument (metavar "SYMBOL") <*> runArgumentParser
Run . RunFromPipe <$> runHQParser <*> runArgumentParser
runCompiledParser :: Parser Command
runCompiledParser =

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

13
unison-cli/src/Unison/Cli/MonadUtils.hs
View File

@ -67,9 +67,6 @@ module Unison.Cli.MonadUtils
-- ** Getting patches
getPatchAt,
getMaybePatchAt,
expectPatchAt,
assertNoPatchAt,
-- * Latest touched Unison file
getLatestFile,
@ -514,16 +511,6 @@ getMaybePatchAt path0 = do
branch <- getBranch0At path
liftIO (Branch.getMaybePatch name branch)
-- | Get the patch at a path, or return early if there's no such patch.
expectPatchAt :: Path.Split' -> Cli Patch
expectPatchAt path =
getMaybePatchAt path & onNothingM (Cli.returnEarly (Output.PatchNotFound path))
-- | Assert that there's no patch at a path, or return early if there is one.
assertNoPatchAt :: Path.Split' -> Cli ()
assertNoPatchAt path = do
whenJustM (getMaybePatchAt path) \_ -> Cli.returnEarly (Output.PatchAlreadyExists path)
------------------------------------------------------------------------------------------------------------------------
-- Latest (typechecked) unison file utils

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

@ -27,7 +27,6 @@ module Unison.Cli.Pretty
prettyProjectName,
prettyProjectNameSlash,
prettyNamespaceKey,
prettyReadGitRepo,
prettyReadRemoteNamespace,
prettyReadRemoteNamespaceWith,
prettyRelative,
@ -37,6 +36,7 @@ module Unison.Cli.Pretty
prettySemver,
prettyShareLink,
prettySharePath,
prettyShareURI,
prettySlashProjectBranchName,
prettyTermName,
prettyTypeName,
@ -45,7 +45,6 @@ module Unison.Cli.Pretty
prettyURI,
prettyUnisonFile,
prettyWhichBranchEmpty,
prettyWriteGitRepo,
prettyWriteRemoteNamespace,
shareOrigin,
unsafePrettyTermResultSigFull',
@ -78,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,
@ -140,6 +137,11 @@ type Pretty = P.Pretty P.ColorText
prettyURI :: URI -> Pretty
prettyURI = P.bold . P.blue . P.shown
prettyShareURI :: URI -> Pretty
prettyShareURI host
| URI.uriToString id host "" == "https://api.unison-lang.org" = P.bold (P.blue "Unison Share")
| otherwise = P.bold (P.blue (P.shown host))
prettyReadRemoteNamespace :: ReadRemoteNamespace Share.RemoteProjectBranch -> Pretty
prettyReadRemoteNamespace =
prettyReadRemoteNamespaceWith \remoteProjectBranch ->
@ -233,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
@ -342,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
@ -361,8 +350,8 @@ prettyWhichBranchEmpty = \case
WhichBranchEmptyPath path -> prettyPath' path
-- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef
displayBranchHash :: CausalHash -> String
displayBranchHash = ("#" <>) . Text.unpack . Hash.toBase32HexText . unCausalHash
displayBranchHash :: CausalHash -> Text
displayBranchHash = ("#" <>) . Hash.toBase32HexText . unCausalHash
prettyHumanReadableTime :: UTCTime -> UTCTime -> Pretty
prettyHumanReadableTime now time =
@ -394,15 +383,15 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) =
-- Special-case Unison Share since we know its project branch URLs
if URI.uriToString id host "" == "https://api.unison-lang.org"
then
P.hiBlack . P.text $
P.group $
"https://share.unison-lang.org/"
<> into @Text remoteProject
<> prettyProjectName remoteProject
<> "/code/"
<> into @Text remoteBranch
<> prettyProjectBranchName remoteBranch
else
prettyProjectAndBranchName (ProjectAndBranch remoteProject remoteBranch)
<> " on "
<> P.hiBlack (P.shown host)
<> P.shown host
stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path
stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism

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

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

@ -5,6 +5,7 @@ module Unison.Codebase.Editor.HandleInput (loop) where
-- TODO: Don't import backend
import Control.Arrow ((&&&))
import Control.Error.Util qualified as ErrorUtil
import Control.Lens hiding (from)
import Control.Monad.Reader (ask)
@ -27,7 +28,6 @@ import Text.Megaparsec qualified as Megaparsec
import U.Codebase.Branch.Diff qualified as V2Branch.Diff
import U.Codebase.Causal qualified as V2Causal
import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Reference qualified as V2 (Reference)
import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
@ -79,8 +79,8 @@ import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename)
import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
import Unison.Codebase.Editor.HandleInput.Projects (handleProjects)
import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch, propagatePatch)
import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch)
import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch)
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
@ -99,6 +99,7 @@ import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Editor.Slurp qualified as Slurp
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
import Unison.Codebase.Editor.StructuredArgument qualified as SA
import Unison.Codebase.Editor.TodoOutput qualified as TO
import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase)
import Unison.Codebase.Metadata qualified as Metadata
@ -107,15 +108,8 @@ import Unison.Codebase.Patch qualified as Patch
import Unison.Codebase.Path (Path, Path' (..))
import Unison.Codebase.Path qualified as HQSplit'
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
import Unison.Codebase.TermEdit (TermEdit (..))
import Unison.Codebase.TermEdit qualified as TermEdit
import Unison.Codebase.TermEdit.Typing qualified as TermEdit
import Unison.Codebase.TypeEdit (TypeEdit)
import Unison.Codebase.TypeEdit qualified as TypeEdit
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
import Unison.CommandLine.Completion qualified as Completion
import Unison.CommandLine.DisplayValues qualified as DisplayValues
@ -133,7 +127,6 @@ import Unison.LabeledDependency qualified as LD
import Unison.LabeledDependency qualified as LabeledDependency
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment (..))
import Unison.NameSegment qualified as NameSegment
import Unison.Names (Names (Names))
import Unison.Names qualified as Names
@ -149,18 +142,16 @@ import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
import Unison.Project (ProjectAndBranch (..))
import Unison.Project.Util (projectContextFromPath)
import Unison.Reference (Reference, TermReference)
import Unison.Reference (Reference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Runtime.IOSource qualified as IOSource
import Unison.Server.Backend (ShallowListEntry (..))
import Unison.Server.Backend qualified as Backend
import Unison.Server.CodebaseServer qualified as Server
import Unison.Server.Doc.Markdown.Render qualified as Md
import Unison.Server.Doc.Markdown.Types qualified as Md
import Unison.Server.NameSearch.FromNames qualified as NameSearch
import Unison.Server.QueryResult
import Unison.Server.SearchResult (SearchResult)
import Unison.Server.SearchResult qualified as SR
import Unison.Share.Codeserver qualified as Codeserver
@ -202,73 +193,13 @@ import UnliftIO.Directory qualified as Directory
loop :: Either Event Input -> Cli ()
loop e = do
case e of
Left (IncomingRootBranch hashes) -> Cli.time "IncomingRootBranch" do
schLength <- Cli.runTransaction Codebase.branchHashLength
rootBranch <- Cli.getRootBranch
Cli.respond $
WarnIncomingRootBranch
(SCH.fromHash schLength $ Branch.headHash rootBranch)
(Set.map (SCH.fromHash schLength) hashes)
Left (UnisonFileChanged sourceName text) -> Cli.time "UnisonFileChanged" do
-- We skip this update if it was programmatically generated
Cli.getLatestFile >>= \case
Just (_, True) -> (#latestFile . _Just . _2) .= False
_ -> loadUnisonFile sourceName text
Right input ->
let typeReferences :: [SearchResult] -> [Reference]
typeReferences rs =
[r | SR.Tp (SR.TypeResult _ r _) <- rs]
termReferences :: [SearchResult] -> [Reference]
termReferences rs =
[r | SR.Tm (SR.TermResult _ (Referent.Ref r) _) <- rs]
termResults rs = [r | SR.Tm r <- rs]
typeResults rs = [r | SR.Tp r <- rs]
doRemoveReplacement :: HQ.HashQualified Name -> Maybe PatchPath -> Bool -> Cli ()
doRemoveReplacement from patchPath isTerm = do
let patchPath' = fromMaybe Cli.defaultPatchPath patchPath
patch <- Cli.getPatchAt patchPath'
QueryResult misses allHits <- hqNameQuery Names.IncludeSuffixes [from]
let tpRefs = Set.fromList $ typeReferences allHits
tmRefs = Set.fromList $ termReferences allHits
(hits, opHits) =
let tmResults = Set.fromList $ SR.termName <$> termResults allHits
tpResults = Set.fromList $ SR.typeName <$> typeResults allHits
in case isTerm of
True -> (tmResults, tpResults)
False -> (tpResults, tmResults)
go :: Text -> Reference -> Cli ()
go description fr = do
let termPatch = over Patch.termEdits (R.deleteDom fr) patch
typePatch = over Patch.typeEdits (R.deleteDom fr) patch
(patchPath'', patchName) <- Cli.resolveSplit' patchPath'
-- Save the modified patch
Cli.stepAtM
description
( Path.unabsolute patchPath'',
Branch.modifyPatches
patchName
(const (if isTerm then termPatch else typePatch))
)
-- Say something
Cli.respond Success
when (Set.null hits) do
Cli.respond (SearchTermsNotFoundDetailed isTerm misses (Set.toList opHits))
description <- inputDescription input
traverse_ (go description) (if isTerm then tmRefs else tpRefs)
saveAndApplyPatch :: Path -> NameSegment -> Patch -> Cli ()
saveAndApplyPatch patchPath'' patchName patch' = do
description <- inputDescription input
Cli.stepAtM
(description <> " (1/2)")
( patchPath'',
Branch.modifyPatches patchName (const patch')
)
-- Apply the modified patch to the current path
-- since we might be able to propagate further.
currentPath <- Cli.getCurrentPath
void $ propagatePatch description patch' currentPath
Cli.respond Success
previewResponse sourceName sr uf = do
let previewResponse sourceName sr uf = do
names <- Cli.currentNames
let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf names
filePPED <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile
@ -291,19 +222,22 @@ loop e = do
Cli.respond $ PrintMessage pretty
ShowReflogI -> do
let numEntriesToShow = 500
entries <-
Cli.runTransaction do
schLength <- Codebase.branchHashLength
Codebase.getReflog numEntriesToShow <&> fmap (first $ SCH.fromHash schLength)
(schLength, entries) <-
Cli.runTransaction $
(,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow
let moreEntriesToLoad = length entries == numEntriesToShow
let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad)
let numberedEntries = expandedEntries <&> \(_time, hash, _reason) -> "#" <> SCH.toString hash
let (shortEntries, numberedEntries) =
unzip $
expandedEntries <&> \(time, hash, reason) ->
let (exp, sa) = (SCH.fromHash schLength &&& SA.Namespace) hash
in ((time, exp, reason), sa)
Cli.setNumberedArgs numberedEntries
Cli.respond $ ShowReflog expandedEntries
Cli.respond $ ShowReflog shortEntries
where
expandEntries ::
([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool) ->
Maybe ((Maybe UTCTime, SCH.ShortCausalHash, Text), ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool))
([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool) ->
Maybe ((Maybe UTCTime, CausalHash, Text), ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool))
expandEntries ([], Just expectedHash, moreEntriesToLoad) =
if moreEntriesToLoad
then Nothing
@ -471,27 +405,6 @@ loop e = do
hasConfirmed <- confirmedCommand input
description <- inputDescription input
doMoveBranch description hasConfirmed src' dest'
MovePatchI src' dest' -> do
description <- inputDescription input
p <- Cli.expectPatchAt src'
Cli.assertNoPatchAt dest'
src <- Cli.resolveSplit' src'
dest <- Cli.resolveSplit' dest'
Cli.stepManyAt
description
[ BranchUtil.makeDeletePatch (Path.convert src),
BranchUtil.makeReplacePatch (Path.convert dest) p
]
Cli.respond Success
CopyPatchI src dest' -> do
description <- inputDescription input
p <- Cli.expectPatchAt src
Cli.assertNoPatchAt dest'
dest <- Cli.resolveSplit' dest'
Cli.stepAt
description
(BranchUtil.makeReplacePatch (Path.convert dest) p)
Cli.respond Success
SwitchBranchI path' -> do
path <- Cli.resolvePath' path'
branchExists <- Cli.branchExistsAtPath' path'
@ -735,14 +648,6 @@ loop e = do
DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs
DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs
DeleteTarget'Patch src' -> do
_ <- Cli.expectPatchAt src'
description <- inputDescription input
src <- Cli.resolveSplit' src'
Cli.stepAt
description
(BranchUtil.makeDeletePatch (Path.convert src))
Cli.respond Success
DeleteTarget'Namespace insistence Nothing -> do
hasConfirmed <- confirmedCommand input
if hasConfirmed || insistence == Force
@ -752,16 +657,15 @@ loop e = do
Cli.respond DeletedEverything
else Cli.respond DeleteEverythingConfirmation
DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
branch <- Cli.expectBranchAtPath' (Path.unsplit' p)
branch <- Cli.expectBranchAtPath (Path.unsplit p)
description <- inputDescription input
absPath <- Cli.resolveSplit' p
let toDelete =
Names.prefix0
(Path.unsafeToName (Path.unsplit (Path.convert absPath)))
(Path.unsafeToName (Path.unsplit (p)))
(Branch.toNames (Branch.head branch))
afterDelete <- do
rootNames <- Branch.toNames <$> Cli.getRootBranch0
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty rootNames)
names <- Cli.currentNames
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
case (null endangerments, insistence) of
(True, _) -> pure (Cli.respond Success)
(False, Force) -> do
@ -773,7 +677,7 @@ loop e = do
ppeDecl <- Cli.currentPrettyPrintEnvDecl
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
Cli.returnEarlyWithoutOutput
parentPathAbs <- Cli.resolvePath' parentPath
parentPathAbs <- Cli.resolvePath parentPath
-- We have to modify the parent in order to also wipe out the history at the
-- child.
Cli.updateAt description parentPathAbs \parentBranch ->
@ -786,21 +690,12 @@ loop e = do
traverse_ (displayI outputLoc) namesToDisplay
ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query
EditNamespaceI paths -> handleEditNamespace LatestFileLocation paths
FindPatchI -> do
branch <- Cli.getCurrentBranch0
let patches =
[ Path.unsafeToName $ Path.snoc p seg
| (p, b) <- Branch.toList0 branch,
(seg, _) <- Map.toList (Branch._edits b)
]
Cli.respond $ ListOfPatches $ Set.fromList patches
Cli.setNumberedArgs $ fmap (Text.unpack . Name.toText) patches
FindShallowI pathArg -> do
Cli.Env {codebase} <- ask
pathArgAbs <- Cli.resolvePath' pathArg
entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
Cli.setNumberedArgs $ fmap entryToHQString entries
Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
pped <- Cli.currentPrettyPrintEnvDecl
let suffixifiedPPE = PPED.suffixifiedPPE pped
-- This used to be a delayed action which only forced the loading of the root
@ -810,115 +705,9 @@ loop e = do
-- in an improvement, so perhaps it's not worth the effort.
let buildPPE = pure suffixifiedPPE
Cli.respond $ ListShallow buildPPE entries
where
entryToHQString :: ShallowListEntry v Ann -> String
entryToHQString e =
fixup $ Text.unpack case e of
ShallowTypeEntry te -> Backend.typeEntryDisplayName te
ShallowTermEntry te -> Backend.termEntryDisplayName te
ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns
ShallowPatchEntry ns -> NameSegment.toEscapedText ns
where
fixup s = case pathArgStr of
"" -> s
p | last p == '.' -> p ++ s
p -> p ++ "." ++ s
pathArgStr = show pathArg
FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input
StructuredFindI _fscope ws -> handleStructuredFindI ws
StructuredFindReplaceI ws -> handleStructuredFindReplaceI ws
ReplaceI from to patchPath -> do
Cli.Env {codebase} <- ask
hqLength <- Cli.runTransaction Codebase.hashLength
let patchPath' = fromMaybe Cli.defaultPatchPath patchPath
patch <- Cli.getPatchAt patchPath'
QueryResult fromMisses' fromHits <- hqNameQuery Names.IncludeSuffixes [from]
QueryResult toMisses' toHits <- hqNameQuery Names.IncludeSuffixes [to]
let termsFromRefs = termReferences fromHits
termsToRefs = termReferences toHits
typesFromRefs = typeReferences fromHits
typesToRefs = typeReferences toHits
--- Here are all the kinds of misses
--- [X] [X]
--- [Type] [Term]
--- [Term] [Type]
--- [Type] [X]
--- [Term] [X]
--- [X] [Type]
--- [X] [Term]
-- Type hits are term misses
termFromMisses = fromMisses' <> (SR.typeName <$> typeResults fromHits)
termToMisses = toMisses' <> (SR.typeName <$> typeResults toHits)
-- Term hits are type misses
typeFromMisses = fromMisses' <> (SR.termName <$> termResults fromHits)
typeToMisses = toMisses' <> (SR.termName <$> termResults toHits)
termMisses = termFromMisses <> termToMisses
typeMisses = typeFromMisses <> typeToMisses
replaceTerms :: Reference -> Reference -> Cli ()
replaceTerms fr tr = do
(mft, mtt) <-
Cli.runTransaction do
mft <- Codebase.getTypeOfTerm codebase fr
mtt <- Codebase.getTypeOfTerm codebase tr
pure (mft, mtt)
let termNotFound =
Cli.returnEarly
. TermNotFound'
. SH.shortenTo hqLength
. Reference.toShortHash
ft <- mft & onNothing (termNotFound fr)
tt <- mtt & onNothing (termNotFound tr)
let patch' =
-- The modified patch
over
Patch.termEdits
( R.insert fr (Replace tr (TermEdit.typing tt ft))
. R.deleteDom fr
)
patch
(patchPath'', patchName) <- Cli.resolveSplit' patchPath'
saveAndApplyPatch (Path.convert patchPath'') patchName patch'
replaceTypes :: Reference -> Reference -> Cli ()
replaceTypes fr tr = do
let patch' =
-- The modified patch
over
Patch.typeEdits
(R.insert fr (TypeEdit.Replace tr) . R.deleteDom fr)
patch
(patchPath'', patchName) <- Cli.resolveSplit' patchPath'
saveAndApplyPatch (Path.convert patchPath'') patchName patch'
ambiguous :: HQ.HashQualified Name -> [TermReference] -> Cli a
ambiguous t rs =
Cli.returnEarly case t of
HQ.HashOnly h -> HashAmbiguous h rs'
(Path.parseHQSplit' . Text.unpack . HQ.toText -> Right n) -> DeleteNameAmbiguous hqLength n rs' Set.empty
_ -> BadName (HQ.toText t)
where
rs' = Set.map Referent.Ref $ Set.fromList rs
mismatch typeName termName = Cli.respond $ TypeTermMismatch typeName termName
case (termsFromRefs, termsToRefs, typesFromRefs, typesToRefs) of
([], [], [], []) -> Cli.respond $ SearchTermsNotFound termMisses
([_], [], [], [_]) -> mismatch to from
([], [_], [_], []) -> mismatch from to
([_], [], _, _) -> Cli.respond $ SearchTermsNotFound termMisses
([], [_], _, _) -> Cli.respond $ SearchTermsNotFound termMisses
(_, _, [_], []) -> Cli.respond $ SearchTermsNotFound typeMisses
(_, _, [], [_]) -> Cli.respond $ SearchTermsNotFound typeMisses
([fr], [tr], [], []) -> replaceTerms fr tr
([], [], [fr], [tr]) -> replaceTypes fr tr
(froms, [_], [], []) -> ambiguous from froms
([], [], froms, [_]) -> ambiguous from froms
([_], tos, [], []) -> ambiguous to tos
([], [], [_], tos) -> ambiguous to tos
(_, _, _, _) -> error "unpossible"
LoadI maybePath -> handleLoad maybePath
ClearI -> Cli.respond ClearScreen
AddI requestedNames -> do
@ -958,12 +747,6 @@ loop e = do
branchPath <- Cli.resolvePath' branchPath'
doShowTodoOutput patch branchPath
TestI testInput -> Tests.handleTest testInput
PropagatePatchI patchPath scopePath' -> do
description <- inputDescription input
patch <- Cli.getPatchAt patchPath
scopePath <- Cli.resolvePath' scopePath'
updated <- propagatePatch description patch scopePath
when (not updated) (Cli.respond $ NothingToPatch patchPath scopePath')
ExecuteI main args -> handleRun False main args
MakeStandaloneI output main -> doCompile False output main
CompileSchemeI output main ->
@ -1024,19 +807,15 @@ loop e = do
_ <- Cli.updateAtM description destPath \destb ->
liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
Cli.respond Success
ListEditsI maybePath -> do
patch <- Cli.getPatchAt (fromMaybe Cli.defaultPatchPath maybePath)
pped <- Cli.currentPrettyPrintEnvDecl
let suffixifiedPPE = PPED.suffixifiedPPE pped
Cli.respondNumbered $ ListEdits patch suffixifiedPPE
PullI sourceTarget pullMode -> handlePull sourceTarget pullMode
PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput
ListDependentsI hq -> handleDependents hq
ListDependenciesI hq -> handleDependencies hq
NamespaceDependenciesI path -> handleNamespaceDependencies path
DebugNumberedArgsI -> do
schLength <- Cli.runTransaction Codebase.branchHashLength
numArgs <- use #numberedArgs
Cli.respond (DumpNumberedArgs numArgs)
Cli.respond (DumpNumberedArgs schLength numArgs)
DebugTypecheckedUnisonFileI -> do
hqLength <- Cli.runTransaction Codebase.hashLength
uf <- Cli.expectLatestTypecheckedFile
@ -1169,20 +948,12 @@ loop e = do
nameChanges <- V2Branch.Diff.allNameChanges Nothing treeDiff
pure (DisplayDebugNameDiff nameChanges)
Cli.respond output
DeprecateTermI {} -> Cli.respond NotImplemented
DeprecateTypeI {} -> Cli.respond NotImplemented
RemoveTermReplacementI from patchPath -> doRemoveReplacement from patchPath True
RemoveTypeReplacementI from patchPath -> doRemoveReplacement from patchPath False
UpdateBuiltinsI -> Cli.respond NotImplemented
QuitI -> Cli.haltRepl
GistI input -> handleGist input
AuthLoginI -> void $ authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver)
VersionI -> do
Cli.Env {ucmVersion} <- ask
Cli.respond $ PrintVersion ucmVersion
DiffNamespaceToPatchI diffNamespaceToPatchInput -> do
description <- inputDescription input
handleDiffNamespaceToPatch description diffNamespaceToPatchInput
ProjectRenameI name -> handleProjectRename name
ProjectSwitchI name -> projectSwitch name
ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name
@ -1254,14 +1025,6 @@ inputDescription input =
src <- p' src0
dest <- p' dest0
pure ("move " <> src <> " " <> dest)
MovePatchI src0 dest0 -> do
src <- ps' src0
dest <- ps' dest0
pure ("move.patch " <> src <> " " <> dest)
CopyPatchI src0 dest0 -> do
src <- ps' src0
dest <- ps' dest0
pure ("copy.patch " <> src <> " " <> dest)
DeleteI dtarget -> do
case dtarget of
DeleteTarget'TermOrType DeleteOutput'NoDiff things0 -> do
@ -1283,25 +1046,13 @@ inputDescription input =
thing <- traverse hqs' thing0
pure ("delete.type.verbose " <> Text.intercalate " " thing)
DeleteTarget'Namespace Try opath0 -> do
opath <- ops' opath0
opath <- ops opath0
pure ("delete.namespace " <> opath)
DeleteTarget'Namespace Force opath0 -> do
opath <- ops' opath0
opath <- ops opath0
pure ("delete.namespace.force " <> opath)
DeleteTarget'Patch path0 -> do
path <- ps' path0
pure ("delete.patch " <> path)
DeleteTarget'ProjectBranch _ -> wat
DeleteTarget'Project _ -> wat
ReplaceI src target p0 -> do
p <- opatch p0
pure $
"replace "
<> HQ.toText src
<> " "
<> HQ.toText target
<> " "
<> p
AddI _selection -> pure "add"
UpdateI p0 _selection -> do
p <-
@ -1311,12 +1062,8 @@ inputDescription input =
UsePatch p0 -> (" " <>) <$> ps' p0
pure ("update.old" <> p)
Update2I -> pure ("update")
PropagatePatchI p0 scope0 -> do
p <- ps' p0
scope <- p' scope0
pure ("patch " <> p <> " " <> scope)
UndoI {} -> pure "undo"
ExecuteI s args -> pure ("execute " <> Text.unwords (s : fmap Text.pack args))
ExecuteI s args -> pure ("execute " <> Text.unwords (HQ.toText s : fmap Text.pack args))
IOTestI hq -> pure ("io.test " <> HQ.toText hq)
IOTestAllI -> pure "io.test.all"
UpdateBuiltinsI -> pure "builtins.update"
@ -1326,20 +1073,9 @@ inputDescription input =
MergeIOBuiltinsI (Just path) -> ("builtins.mergeio " <>) <$> p path
MakeStandaloneI out nm -> pure ("compile " <> Text.pack out <> " " <> HQ.toText nm)
ExecuteSchemeI nm args ->
pure $ "run.native " <> Text.unwords (nm : fmap Text.pack args)
pure $ "run.native " <> Text.unwords (HQ.toText nm : fmap Text.pack args)
CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi)
CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name)
RemoveTermReplacementI src p0 -> do
p <- opatch p0
pure ("delete.term-replacement" <> HQ.toText src <> " " <> p)
RemoveTypeReplacementI src p0 -> do
p <- opatch p0
pure ("delete.type-replacement" <> HQ.toText src <> " " <> p)
DiffNamespaceToPatchI input -> do
branchId1 <- hp' (input ^. #branchId1)
branchId2 <- hp' (input ^. #branchId2)
patch <- ps' (input ^. #patch)
pure (Text.unwords ["diff.namespace.to-patch", branchId1, branchId2, patch])
ClearI {} -> pure "clear"
DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name)
--
@ -1366,23 +1102,18 @@ inputDescription input =
DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input)
DebugFormatI -> pure "debug.format"
DebugTypecheckedUnisonFileI {} -> wat
DeprecateTermI {} -> wat
DeprecateTypeI {} -> wat
DiffNamespaceI {} -> wat
DisplayI {} -> wat
DocsI {} -> wat
DocsToHtmlI {} -> wat
FindI {} -> wat
FindPatchI {} -> wat
FindShallowI {} -> wat
StructuredFindI {} -> wat
StructuredFindReplaceI {} -> wat
GistI {} -> wat
HistoryI {} -> wat
LibInstallI {} -> wat
ListDependenciesI {} -> wat
ListDependentsI {} -> wat
ListEditsI {} -> wat
LoadI {} -> wat
MergeI {} -> wat
NamesI {} -> wat
@ -1420,10 +1151,8 @@ inputDescription input =
p' = fmap tShow . Cli.resolvePath'
brp :: BranchRelativePath -> Cli Text
brp = fmap from . ProjectUtils.resolveBranchRelativePath
ops' :: Maybe Path.Split' -> Cli Text
ops' = maybe (pure ".") ps'
opatch :: Maybe Path.Split' -> Cli Text
opatch = ps' . fromMaybe Cli.defaultPatchPath
ops :: Maybe Path.Split -> Cli Text
ops = maybe (pure ".") ps
wat = error $ show input ++ " is not expected to alter the branch"
hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text
hhqs' = \case
@ -1435,6 +1164,7 @@ inputDescription input =
pure (p <> "." <> HQ'.toTextWith NameSegment.toEscapedText hq)
hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq)
ps' = p' . Path.unsplit'
ps = p . Path.unsplit
looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text
looseCodeOrProjectToText = \case
This path -> p' path
@ -1506,7 +1236,7 @@ handleFindI isVerbose fscope ws input = do
(mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs)
pure $ uniqueBy SR.toReferent srs
let respondResults results = do
Cli.setNumberedArgs $ fmap (searchResultToHQString searchRoot) results
Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results
results' <- Cli.runTransaction (Backend.loadSearchResults codebase results)
Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results'
results <- getResults names
@ -1558,12 +1288,10 @@ handleDependencies hq = do
let types = [(PPE.typeName suffixifiedPPE r, r) | LabeledDependency.TypeReference r <- toList dependencies]
let terms = [(PPE.termName suffixifiedPPE r, r) | LabeledDependency.TermReferent r <- toList dependencies]
pure (types, terms)
let types = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ fst <$> results)
let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results)
Cli.setNumberedArgs $
map (Text.unpack . Reference.toText . snd) types
<> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms
Cli.respond $ ListDependencies suffixifiedPPE lds (fst <$> types) (fst <$> terms)
let types = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) . join $ fst <$> results
let terms = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) . join $ snd <$> results
Cli.setNumberedArgs . map SA.HashQualified $ types <> terms
Cli.respond $ ListDependencies suffixifiedPPE lds types terms
handleDependents :: HQ.HashQualified Name -> Cli ()
handleDependents hq = do
@ -1580,7 +1308,7 @@ handleDependents hq = do
results <- for (toList lds) \ld -> do
-- The full set of dependent references, any number of which may not have names in the current namespace.
dependents <-
let tp r = Codebase.dependents Queries.ExcludeOwnComponent r
let tp = Codebase.dependents Queries.ExcludeOwnComponent
tm = \case
Referent.Ref r -> Codebase.dependents Queries.ExcludeOwnComponent r
Referent.Con (ConstructorReference r _cid) _ct ->
@ -1596,78 +1324,11 @@ handleDependents hq = do
Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r
pure (isTerm, HQ'.toHQ shortName, r)
pure results
let sort = nubOrdOn snd . Name.sortByText (HQ.toText . fst)
let sort = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst)
let types = sort [(n, r) | (False, n, r) <- join results]
let terms = sort [(n, r) | (True, n, r) <- join results]
Cli.setNumberedArgs $ map (Text.unpack . Reference.toText . view _2) (types <> terms)
Cli.respond (ListDependents ppe lds (fst <$> types) (fst <$> terms))
handleDiffNamespaceToPatch :: Text -> DiffNamespaceToPatchInput -> Cli ()
handleDiffNamespaceToPatch description input = do
Cli.Env {codebase} <- ask
absBranchId1 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId1)
absBranchId2 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId2)
patch <- do
Cli.runTransactionWithRollback \rollback -> do
branch1 <- Cli.resolveAbsBranchIdV2 rollback absBranchId1
branch2 <- Cli.resolveAbsBranchIdV2 rollback absBranchId2
branchDiff <- V2Branch.Diff.diffBranches branch1 branch2 >>= V2Branch.Diff.nameBasedDiff
termEdits <-
(branchDiff ^. #terms)
& Relation.domain
& Map.toList
& traverse \(oldRef, newRefs) -> makeTermEdit codebase oldRef newRefs
pure
Patch
{ _termEdits =
termEdits
& catMaybes
& Relation.fromList,
_typeEdits =
(branchDiff ^. #types)
& Relation.domain
& Map.toList
& mapMaybe (\(oldRef, newRefs) -> makeTypeEdit oldRef newRefs)
& Relation.fromList
}
-- Display the patch that we are about to create.
suffixifiedPPE <- PPED.suffixifiedPPE <$> Cli.currentPrettyPrintEnvDecl
Cli.respondNumbered (ListEdits patch suffixifiedPPE)
(patchPath, patchName) <- Cli.resolveSplit' (input ^. #patch)
-- Add the patch to the in-memory root branch and flush it all to SQLite.
-- If there's already a patch at the given path, overwrite it.
Cli.stepAtM
description
(Path.unabsolute patchPath, Branch.modifyPatches patchName (const patch))
where
-- Given {old reference} and {new references}, create term edit patch entries as follows:
--
-- * If the {new references} is a singleton set {new reference}, proceed. (Otherwise, the patch we might create
-- would not be a function, which is a bogus/conflicted patch).
-- * Look up {old reference} and {new reference} types in the codebase (which can technically fail, due to
-- non-transactionality of this command, though we don't typically delete anything from SQLite), and create a
-- patch entry that maps {old reference} to {new reference} with the typing relationship.
makeTermEdit ::
Codebase m Symbol Ann ->
V2.Reference ->
Set V2.Reference ->
Sqlite.Transaction (Maybe (Reference, TermEdit))
makeTermEdit codebase (Conversions.reference2to1 -> oldRef) newRefs =
runMaybeT do
newRef <- Conversions.reference2to1 <$> MaybeT (pure (Set.asSingleton newRefs))
oldRefType <- MaybeT (Codebase.getTypeOfTerm codebase oldRef)
newRefType <- MaybeT (Codebase.getTypeOfTerm codebase newRef)
pure (oldRef, TermEdit.Replace newRef (TermEdit.typing oldRefType newRefType))
-- Same idea as 'makeTermEdit', but simpler, because there's nothing to look up in the database.
makeTypeEdit :: V2.Reference -> Set V2.Reference -> Maybe (Reference, TypeEdit)
makeTypeEdit (Conversions.reference2to1 -> oldRef) newRefs =
Set.asSingleton newRefs <&> \newRef -> (oldRef, TypeEdit.Replace (Conversions.reference2to1 newRef))
Cli.setNumberedArgs . map SA.HashQualified $ types <> terms
Cli.respond (ListDependents ppe lds types terms)
-- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`.
handleShowDefinition :: OutputLocation -> ShowDefinitionScope -> NonEmpty (HQ.HashQualified Name) -> Cli ()
@ -1779,10 +1440,9 @@ doShowTodoOutput patch scopePath = do
if TO.noConflicts todo && TO.noEdits todo
then Cli.respond NoConflictsOrEdits
else do
Cli.setNumberedArgs
( Text.unpack . Reference.toText . view _2
<$> fst (TO.todoFrontierDependents todo)
)
Cli.setNumberedArgs $
SA.HashQualified . HQ.HashOnly . Reference.toShortHash . view _2
<$> fst (TO.todoFrontierDependents todo)
pped <- Cli.currentPrettyPrintEnvDecl
Cli.respondNumbered $ TodoOutput pped todo
@ -1828,16 +1488,6 @@ confirmedCommand i = do
loopState <- State.get
pure $ Just i == (loopState ^. #lastInput)
-- | restores the full hash to these search results, for _numberedArgs purposes
searchResultToHQString :: Maybe Path -> SearchResult -> String
searchResultToHQString oprefix = \case
SR.Tm' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify (addPrefix <$> n) r
SR.Tp' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify (addPrefix <$> n) (Referent.Ref r)
_ -> error "impossible match failure"
where
addPrefix :: Name -> Name
addPrefix = maybe id Path.prefixName2 oprefix
-- return `name` and `name.<everything>...`
_searchBranchPrefix :: Branch m -> Name -> [SearchResult]
_searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of
@ -2110,7 +1760,7 @@ displayI outputLoc hq = do
let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names
doDisplay outputLoc ns tm
docsI :: Path.HQSplit' -> Cli ()
docsI :: Name -> Cli ()
docsI src = do
findInScratchfileByName
where
@ -2118,14 +1768,8 @@ docsI src = do
(fileByName) First check the file for `foo.doc`, and if found do `display foo.doc`
(codebaseByName) Lastly check for `foo.doc` in the codebase and if found do `display foo.doc`
-}
hq :: HQ.HashQualified Name
hq =
let hq' :: HQ'.HashQualified Name
hq' = Path.unsafeToName' <$> Name.convert src
in Name.convert hq'
dotDoc :: HQ.HashQualified Name
dotDoc = hq <&> \n -> Name.joinDot n (Name.fromSegment "doc")
dotDoc = Name.convert . Name.joinDot src $ Name.fromSegment "doc"
findInScratchfileByName :: Cli ()
findInScratchfileByName = do
@ -2215,15 +1859,6 @@ addWatch watchName (Just uf) = do
)
_ -> addWatch watchName Nothing
hqNameQuery :: Names.SearchType -> [HQ.HashQualified Name] -> Cli QueryResult
hqNameQuery searchType query = do
Cli.Env {codebase} <- ask
names <- Cli.currentNames
Cli.runTransaction do
hqLength <- Codebase.hashLength
let nameSearch = NameSearch.makeNameSearch hqLength names
Backend.hqNameQuery codebase nameSearch searchType query
looseCodeOrProjectToPath :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path'
looseCodeOrProjectToPath = \case
Left pth -> pth

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

@ -18,6 +18,7 @@ import Unison.Cli.Pretty qualified as P
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.StructuredArgument qualified as SA
import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ'
import Unison.Name (Name)
@ -81,15 +82,14 @@ handleStructuredFindI rule = do
Referent.Ref _ <- pure r
Just shortName <- [PPE.terms (PPED.suffixifiedPPE ppe) r]
pure (HQ'.toHQ shortName, r)
let ok t@(_, Referent.Ref (Reference.DerivedId r)) = do
let ok (hq, Referent.Ref (Reference.DerivedId r)) = do
oe <- Cli.runTransaction (Codebase.getTerm codebase r)
pure $ (t, maybe False (\e -> any ($ e) rules) oe)
ok t = pure (t, False)
pure $ (hq, maybe False (\e -> any ($ e) rules) oe)
ok (hq, _) = pure (hq, False)
results0 <- traverse ok results
let results = Alphabetical.sortAlphabeticallyOn fst [(hq, r) | ((hq, r), True) <- results0]
let toNumArgs = Text.unpack . Reference.toText . Referent.toReference . view _2
Cli.setNumberedArgs $ map toNumArgs results
Cli.respond (ListStructuredFind (fst <$> results))
let results = Alphabetical.sortAlphabetically [hq | (hq, True) <- results0]
Cli.setNumberedArgs $ map SA.HashQualified results
Cli.respond (ListStructuredFind results)
lookupRewrite ::
(HQ.HashQualified Name -> Output) ->

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

@ -117,25 +117,22 @@ fresh bump taken x =
makeDependencyName :: ProjectName -> ProjectBranchName -> NameSegment
makeDependencyName projectName branchName =
NameSegment.unsafeParseText $
Text.intercalate "_" $
fold
[ case projectNameToUserProjectSlugs projectName of
(user, project) ->
fold
[ if Text.null user then [] else [user],
[project]
],
case classifyProjectBranchName branchName of
ProjectBranchNameKind'Contributor user branch -> [user, underscorify branch]
ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"]
ProjectBranchNameKind'Release ver -> semverSegments ver
ProjectBranchNameKind'NothingSpecial -> [underscorify branchName]
]
Text.replace "-" "_" $
Text.intercalate "_" $
fold
[ case projectNameToUserProjectSlugs projectName of
(user, project) ->
fold
[ if Text.null user then [] else [user],
[project]
],
case classifyProjectBranchName branchName of
ProjectBranchNameKind'Contributor user branch -> [user, into @Text branch]
ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"]
ProjectBranchNameKind'Release ver -> semverSegments ver
ProjectBranchNameKind'NothingSpecial -> [into @Text branchName]
]
where
semverSegments :: Semver -> [Text]
semverSegments (Semver x y z) =
[tShow x, tShow y, tShow z]
underscorify :: ProjectBranchName -> Text
underscorify =
Text.replace "-" "_" . into @Text

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

@ -62,7 +62,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)
@ -77,7 +77,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 (..))
@ -245,19 +245,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
@ -269,23 +267,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)
@ -385,10 +383,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
@ -862,7 +856,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
@ -1040,7 +1033,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 (),
@ -1081,9 +1075,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
@ -135,7 +125,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
@ -208,7 +197,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

104
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
@ -650,10 +559,11 @@ makeSetHeadAfterUploadAction ::
Share.RemoteProjectBranch ->
Cli AfterUploadAction
makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do
let remoteProjectAndBranchNames = ProjectAndBranch (remoteBranch ^. #projectName) (remoteBranch ^. #branchName)
let remoteProjectAndBranchNames = ProjectAndBranch remoteBranch.projectName remoteBranch.branchName
when (localBranchHead == Share.API.hashJWTHash (remoteBranch ^. #branchHead)) do
Cli.returnEarly (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames)
when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) 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

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

@ -20,6 +20,8 @@ import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.MainTerm qualified as MainTerm
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Hash qualified as Hash
import Unison.HashQualified qualified as HQ
import Unison.Name (Name)
import Unison.Parser.Ann (Ann (External))
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
@ -40,7 +42,7 @@ import Unison.UnisonFile qualified as UF
import Unison.UnisonFile.Names qualified as UF
import Unison.Var qualified as Var
handleRun :: Bool -> Text -> [String] -> Cli ()
handleRun :: Bool -> HQ.HashQualified Name -> [String] -> Cli ()
handleRun native main args = do
(unisonFile, mainResType) <- do
(sym, term, typ, otyp) <- getTerm main
@ -75,7 +77,7 @@ data GetTermResult
-- | Look up runnable term with the given name in the codebase or
-- latest typechecked unison file. Return its symbol, term, type, and
-- the type of the evaluated term.
getTerm :: Text -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann)
getTerm :: HQ.HashQualified Name -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann)
getTerm main =
getTerm' main >>= \case
NoTermWithThatName -> do
@ -90,7 +92,7 @@ getTerm main =
Cli.returnEarly $ Output.BadMainFunction "run" main ty suffixifiedPPE [mainType]
GetTermSuccess x -> pure x
getTerm' :: Text -> Cli GetTermResult
getTerm' :: HQ.HashQualified Name -> Cli GetTermResult
getTerm' mainName =
let getFromCodebase = do
Cli.Env {codebase, runtime} <- ask
@ -99,7 +101,6 @@ getTerm' mainName =
mainToFile
=<< MainTerm.getMainTerm loadTypeOfTerm names mainName (Runtime.mainType runtime)
where
mainToFile (MainTerm.NotAFunctionName _) = pure NoTermWithThatName
mainToFile (MainTerm.NotFound _) = pure NoTermWithThatName
mainToFile (MainTerm.BadType _ ty) = pure $ maybe NoTermWithThatName TermHasBadType ty
mainToFile (MainTerm.Success hq tm typ) =
@ -108,7 +109,8 @@ getTerm' mainName =
pure (GetTermSuccess (v, tm, typ, otyp))
getFromFile uf = do
let components = join $ UF.topLevelComponents uf
let mainComponent = filter ((\v -> Var.name v == mainName) . view _1) components
-- __TODO__: We shouldn’t need to serialize mainName` for this check
let mainComponent = filter ((\v -> Var.name v == HQ.toText mainName) . view _1) components
case mainComponent of
[(v, _, tm, ty)] ->
checkType ty \otyp ->

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

@ -31,7 +31,6 @@ import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Reference (Reference)
import Unison.Referent (Referent, pattern Con, pattern Ref)
import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualified qualified as HQ (toText)
import Unison.Type (Type)
import Unison.Typechecker qualified as Typechecker
@ -118,9 +117,8 @@ resolveMainRef main = do
pped <- Cli.prettyPrintEnvDeclFromNames names
let suffixifiedPPE = PPED.suffixifiedPPE pped
let mainType = Runtime.mainType runtime
smain = HQ.toText main
lookupTermRefWithType codebase main >>= \case
[(rf, ty)]
| Typechecker.fitsScheme ty mainType -> pure (rf, suffixifiedPPE)
| otherwise -> Cli.returnEarly (BadMainFunction "main" smain ty suffixifiedPPE [mainType])
_ -> Cli.returnEarly (NoMainFunction smain suffixifiedPPE [mainType])
| otherwise -> Cli.returnEarly (BadMainFunction "main" main ty suffixifiedPPE [mainType])
_ -> Cli.returnEarly (NoMainFunction main suffixifiedPPE [mainType])

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

@ -28,6 +28,8 @@ import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils
import Unison.Codebase.Editor.Input (TestInput (..))
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Runtime qualified as Runtime
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.HashQualified qualified as HQ
@ -38,6 +40,7 @@ import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Reference (TermReferenceId)
import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent
import Unison.ShortHash qualified as SH
@ -53,9 +56,6 @@ import Unison.Util.Monoid (foldMapM)
import Unison.Util.Relation qualified as R
import Unison.Util.Set qualified as Set
import Unison.WatchKind qualified as WK
import Unison.Codebase.Path (Path)
import Unison.Reference (TermReferenceId)
import qualified Unison.Codebase.Path as Path
-- | Handle a @test@ command.
-- Run pure tests in the current subnamespace.
@ -137,7 +137,7 @@ handleIOTest main = do
(fails, oks) <-
refs & foldMapM \(ref, typ) -> do
when (not $ isIOTest typ) do
Cli.returnEarly (BadMainFunction "io.test" (HQ.toText main) typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime))
Cli.returnEarly (BadMainFunction "io.test" main typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime))
runIOTest suffixifiedPPE ref
Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails

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

@ -1,8 +1,6 @@
module Unison.Codebase.Editor.Input
( Input (..),
BranchSourceI (..),
DiffNamespaceToPatchInput (..),
GistInput (..),
PullSourceTarget (..),
PushRemoteBranchInput (..),
PushSourceTarget (..),
@ -32,9 +30,8 @@ where
import Data.List.NonEmpty (NonEmpty)
import Data.Text qualified as Text
import Data.These (These)
import U.Codebase.HashTags (CausalHash)
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
@ -52,7 +49,6 @@ import Unison.Util.Pretty qualified as P
data Event
= UnisonFileChanged SourceName Source
| IncomingRootBranch (Set CausalHash)
deriving stock (Show)
type Source = Text -- "id x = x\nconst a b = a"
@ -144,8 +140,6 @@ data Input
MoveTermI Path.HQSplit' Path.Split'
| MoveTypeI Path.HQSplit' Path.Split'
| MoveBranchI Path.Path' Path.Path'
| MovePatchI Path.Split' Path.Split'
| CopyPatchI Path.Split' Path.Split'
| -- delete = unname
DeleteI DeleteTarget
| -- edits stuff:
@ -157,20 +151,12 @@ data Input
| Update2I
| PreviewUpdateI (Set Name)
| TodoI (Maybe PatchPath) Path'
| PropagatePatchI PatchPath Path'
| ListEditsI (Maybe PatchPath)
| -- -- create and remove update directives
DeprecateTermI PatchPath Path.HQSplit'
| DeprecateTypeI PatchPath Path.HQSplit'
| ReplaceI (HQ.HashQualified Name) (HQ.HashQualified Name) (Maybe PatchPath)
| RemoveTermReplacementI (HQ.HashQualified Name) (Maybe PatchPath)
| RemoveTypeReplacementI (HQ.HashQualified Name) (Maybe PatchPath)
| UndoI
| -- First `Maybe Int` is cap on number of results, if any
-- Second `Maybe Int` is cap on diff elements shown, if any
HistoryI (Maybe Int) (Maybe Int) BranchId
| -- execute an IO thunk with args
ExecuteI Text [String]
ExecuteI (HQ.HashQualified Name) [String]
| -- save the result of a previous Execute
SaveExecuteResultI Name
| -- execute an IO [Result]
@ -180,7 +166,7 @@ data Input
| -- make a standalone binary file
MakeStandaloneI String (HQ.HashQualified Name)
| -- execute an IO thunk using scheme
ExecuteSchemeI Text [String]
ExecuteSchemeI (HQ.HashQualified Name) [String]
| -- compile to a scheme file
CompileSchemeI Text (HQ.HashQualified Name)
| TestI TestInput
@ -188,11 +174,10 @@ data Input
| -- Display provided definitions.
DisplayI OutputLocation (NonEmpty (HQ.HashQualified Name))
| -- Display docs for provided terms.
DocsI (NonEmpty Path.HQSplit')
DocsI (NonEmpty Name)
| -- other
FindI Bool FindScope [String] -- FindI isVerbose findScope query
| FindShallowI Path'
| FindPatchI
| StructuredFindI FindScope (HQ.HashQualified Name) -- sfind findScope query
| StructuredFindReplaceI (HQ.HashQualified Name) -- sfind.replace rewriteQuery
| -- Show provided definitions.
@ -224,10 +209,8 @@ data Input
| UiI Path'
| DocToMarkdownI Name
| DocsToHtmlI Path' FilePath
| GistI GistInput
| AuthLoginI
| VersionI
| DiffNamespaceToPatchI DiffNamespaceToPatchInput
| ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName)
| ProjectRenameI ProjectName
| ProjectSwitchI ProjectAndBranchNames
@ -255,22 +238,6 @@ data BranchSourceI
BranchSourceI'LooseCodeOrProject LooseCodeOrProject
deriving stock (Eq, Show)
data DiffNamespaceToPatchInput = DiffNamespaceToPatchInput
{ -- The first/earlier namespace.
branchId1 :: BranchId,
-- The second/later namespace.
branchId2 :: BranchId,
-- Where to store the patch that corresponds to the diff between the namespaces.
patch :: Path.Split'
}
deriving stock (Eq, Generic, 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
@ -334,8 +301,7 @@ data DeleteTarget
= DeleteTarget'TermOrType DeleteOutput [Path.HQSplit']
| DeleteTarget'Term DeleteOutput [Path.HQSplit']
| DeleteTarget'Type DeleteOutput [Path.HQSplit']
| DeleteTarget'Namespace Insistence (Maybe Path.Split')
| DeleteTarget'Patch Path.Split'
| DeleteTarget'Namespace Insistence (Maybe Path.Split)
| DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
| DeleteTarget'Project ProjectName
deriving stock (Eq, Show)

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

@ -17,7 +17,6 @@ module Unison.Codebase.Editor.Output
where
import Data.List.NonEmpty (NonEmpty)
import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Time (UTCTime)
import Network.URI (URI)
@ -28,7 +27,7 @@ import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import Unison.Auth.Types (CredentialFailure)
import Unison.Cli.MergeTypes (MergeSourceOrTarget, MergeSourceAndTarget)
import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget)
import Unison.Cli.Share.Projects.Types qualified as Share
import Unison.Codebase.Editor.Input
import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput)
@ -37,16 +36,15 @@ import Unison.Codebase.Editor.Output.PushPull (PushPull)
import Unison.Codebase.Editor.RemoteRepo
import Unison.Codebase.Editor.SlurpResult (SlurpResult (..))
import Unison.Codebase.Editor.SlurpResult qualified as SR
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
import Unison.Codebase.Editor.TodoOutput qualified as TO
import Unison.Codebase.IntegrityCheck (IntegrityResult (..))
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path')
import Unison.Codebase.Path qualified as Path
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)
@ -85,7 +83,12 @@ type ListDetailed = Bool
type SourceName = Text
type NumberedArgs = [String]
-- |
--
-- __NB__: This only temporarily holds `Text`. Until all of the inputs are
-- updated to handle `StructuredArgument`s, we need to ensure that the
-- serialization remains unchanged.
type NumberedArgs = [StructuredArgument]
type HashLength = Int
@ -128,7 +131,6 @@ data NumberedOutput
HashLength
[(CausalHash, Names.Diff)]
HistoryTail -- 'origin point' of this view of history.
| ListEdits Patch PPE.PrettyPrintEnv
| ListProjects [Sqlite.Project]
| ListBranches ProjectName [(ProjectBranchName, [(URI, ProjectName, ProjectBranchName)])]
| AmbiguousSwitch ProjectName (ProjectAndBranch ProjectName ProjectBranchName)
@ -155,13 +157,13 @@ data Output
| InvalidSourceName String
| SourceLoadFailed String
| -- No main function, the [Type v Ann] are the allowed types
NoMainFunction Text PPE.PrettyPrintEnv [Type Symbol Ann]
NoMainFunction (HQ.HashQualified Name) PPE.PrettyPrintEnv [Type Symbol Ann]
| -- | Function found, but has improper type
-- Note: the constructor name is misleading here; we weren't necessarily looking for a "main".
BadMainFunction
Text
-- ^ what we were trying to do (e.g. "run", "io.test")
Text
(HQ.HashQualified Name)
-- ^ name of function
(Type Symbol Ann)
-- ^ bad type of function
@ -173,7 +175,6 @@ data Output
| CreatedNewBranch Path.Absolute
| BranchAlreadyExists Path'
| FindNoLocalMatches
| PatchAlreadyExists Path.Split'
| NoExactTypeMatches
| TypeAlreadyExists Path.Split' (Set Reference)
| TypeParseError String (Parser.Err Symbol)
@ -192,13 +193,11 @@ data Output
| EmptyProjectBranchPush (ProjectAndBranch ProjectName ProjectBranchName)
| NameNotFound Path.HQSplit'
| NamesNotFound [Name]
| PatchNotFound Path.Split'
| TypeNotFound Path.HQSplit'
| TermNotFound Path.HQSplit'
| MoveNothingFound Path'
| TypeNotFound' ShortHash
| TermNotFound' ShortHash
| TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name)
| NoLastRunResult
| SaveTermNameConflict Name
| SearchTermsNotFound [HQ.HashQualified Name]
@ -231,7 +230,6 @@ data Output
-- list of all the definitions within this branch
| ListOfDefinitions FindScope PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann]
| ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann]
| ListOfPatches (Set Name)
| ListStructuredFind [HQ.HashQualified Name]
| -- ListStructuredFind patternMatchingUsages termBodyUsages
-- show the result of add/update
@ -268,18 +266,14 @@ 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
| ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String
| TermMissingType Reference
| AboutToPropagatePatch
| -- todo: tell the user to run `todo` on the same patch they just used
NothingToPatch PatchPath Path'
| PatchNeedsToBeConflictFree
| PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference)
| WarnIncomingRootBranch ShortCausalHash (Set ShortCausalHash)
| StartOfCurrentPathHistory
| ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)]
| PullAlreadyUpToDate
@ -306,7 +300,7 @@ data Output
| ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
| -- | List dependents of a type or term.
ListDependents PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
| DumpNumberedArgs NumberedArgs
| DumpNumberedArgs HashLength NumberedArgs
| DumpBitBooster CausalHash (Map CausalHash [CausalHash])
| DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)]
| BadName Text
@ -405,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
| NoUpgradeInProgress
@ -490,7 +484,6 @@ isFailure o = case o of
BranchAlreadyExists {} -> True
-- we do a global search after finding no local matches, so let's not call this a failure yet
FindNoLocalMatches {} -> False
PatchAlreadyExists {} -> True
NoExactTypeMatches -> True
BranchEmpty {} -> True
EmptyLooseCodePush {} -> True
@ -510,13 +503,11 @@ isFailure o = case o of
BranchNotFound {} -> True
NameNotFound {} -> True
NamesNotFound _ -> True
PatchNotFound {} -> True
TypeNotFound {} -> True
TypeNotFound' {} -> True
TermNotFound {} -> True
MoveNothingFound {} -> True
TermNotFound' {} -> True
TypeTermMismatch {} -> True
SearchTermsNotFound ts -> not (null ts)
SearchTermsNotFoundDetailed _ misses otherHits -> not (null misses && null otherHits)
DeleteBranchConfirmation {} -> False
@ -526,7 +517,6 @@ isFailure o = case o of
DeletedEverything -> False
ListNames _ _ tys tms -> null tms && null tys
ListOfDefinitions _ _ _ ds -> null ds
ListOfPatches s -> Set.null s
ListStructuredFind tms -> null tms
SlurpOutput _ _ sr -> not $ SR.isOk sr
ParseErrors {} -> True
@ -544,15 +534,12 @@ isFailure o = case o of
TestIncrementalOutputEnd {} -> False
TestResults _ _ _ _ _ fails -> not (null fails)
CantUndo {} -> True
GitError {} -> True
BustedBuiltins {} -> True
NoConfiguredRemoteMapping {} -> True
ConfiguredRemoteMappingParseError {} -> True
PatchNeedsToBeConflictFree {} -> True
PatchInvolvesExternalDependents {} -> True
AboutToPropagatePatch {} -> False
NothingToPatch {} -> False
WarnIncomingRootBranch {} -> False
StartOfCurrentPathHistory -> True
NotImplemented -> True
DumpNumberedArgs {} -> False
@ -666,7 +653,6 @@ isNumberedFailure = \case
DeletedDespiteDependents {} -> False
History {} -> False
ListBranches {} -> False
ListEdits {} -> False
ListProjects {} -> False
ShowDiffAfterCreateAuthor {} -> False
ShowDiffAfterDeleteBranch {} -> False

29
unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs Normal file
View File

@ -0,0 +1,29 @@
module Unison.Codebase.Editor.StructuredArgument where
import GHC.Generics (Generic)
import U.Codebase.HashTags (CausalHash)
import Unison.Codebase.Editor.Input
import Unison.Codebase.Path (Path, Path')
import Unison.Codebase.Path qualified as Path
import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ'
import Unison.Name (Name)
import Unison.Parser.Ann (Ann)
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
import Unison.Server.Backend (ShallowListEntry)
import Unison.Server.SearchResult (SearchResult)
import Unison.Symbol (Symbol)
-- | The types that can be referenced by a numeric command argument.
data StructuredArgument
= AbsolutePath Path.Absolute
| Name Name
| HashQualified (HQ.HashQualified Name)
| Project ProjectName
| ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
| Namespace CausalHash
| NameWithBranchPrefix AbsBranchId Name
| HashQualifiedWithBranchPrefix AbsBranchId (HQ'.HashQualified Name)
| ShallowListEntry Path' (ShallowListEntry Symbol Ann)
| SearchResult (Maybe Path) SearchResult
deriving (Eq, Generic, Show)

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)

30
unison-cli/src/Unison/CommandLine.hs
View File

@ -46,6 +46,7 @@ import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch0)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Input (Event (..), Input (..))
import Unison.Codebase.Editor.Output (NumberedArgs)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Watch qualified as Watch
import Unison.CommandLine.FZFResolvers qualified as FZFResolvers
@ -123,14 +124,14 @@ parseInput ::
-- | Current path from root
Path.Absolute ->
-- | Numbered arguments
[String] ->
NumberedArgs ->
-- | Input Pattern Map
Map String InputPattern ->
-- | command:arguments
[String] ->
-- Returns either an error message or the fully expanded arguments list and parsed input.
-- If the output is `Nothing`, the user cancelled the input (e.g. ctrl-c)
IO (Either (P.Pretty CT.ColorText) (Maybe ([String], Input)))
IO (Either (P.Pretty CT.ColorText) (Maybe (InputPattern.Arguments, Input)))
parseInput codebase currentPath numberedArgs patterns segments = runExceptT do
let getCurrentBranch0 :: IO (Branch0 IO)
getCurrentBranch0 = Branch.head <$> Codebase.getBranchAtPath codebase currentPath
@ -140,16 +141,16 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do
[] -> throwE ""
command : args -> case Map.lookup command patterns of
Just pat@(InputPattern {parse, help}) -> do
let expandedNumbers :: [String]
let expandedNumbers :: InputPattern.Arguments
expandedNumbers =
foldMap (expandNumber numberedArgs) args
foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args
lift (fzfResolve codebase projCtx getCurrentBranch0 pat expandedNumbers) >>= \case
Left (NoFZFResolverForArgumentType _argDesc) -> throwError help
Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc)
Left FZFCancelled -> pure Nothing
Right resolvedArgs -> do
parsedInput <- except . parse $ resolvedArgs
pure $ Just (command : resolvedArgs, parsedInput)
pure $ Just (Left command : resolvedArgs, parsedInput)
Nothing ->
throwE
. warn
@ -168,11 +169,9 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do
]
-- Expand a numeric argument like `1` or a range like `3-9`
expandNumber :: [String] -> String -> [String]
expandNumber numberedArgs s = case expandedNumber of
Nothing -> [s]
Just nums ->
[s | i <- nums, Just s <- [vargs Vector.!? (i - 1)]]
expandNumber :: NumberedArgs -> String -> Maybe NumberedArgs
expandNumber numberedArgs s =
(\nums -> [arg | i <- nums, Just arg <- [vargs Vector.!? (i - 1)]]) <$> expandedNumber
where
vargs = Vector.fromList numberedArgs
rangeRegex = "([0-9]+)-([0-9]+)" :: String
@ -193,13 +192,13 @@ data FZFResolveFailure
| NoFZFOptions Text {- argument description -}
| FZFCancelled
fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> [String] -> IO (Either FZFResolveFailure [String])
fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments)
fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do
-- We resolve args in two steps, first we check that all arguments that will require a fzf
-- resolver have one, and only if so do we prompt the user to actually do a fuzzy search.
-- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver
-- for a later arg.
argumentResolvers :: [ExceptT FZFResolveFailure IO [String]] <-
argumentResolvers :: [ExceptT FZFResolveFailure IO InputPattern.Arguments] <-
(Align.align (InputPattern.args pat) args)
& traverse \case
This (argName, opt, InputPattern.ArgumentType {fzfResolver})
@ -212,7 +211,7 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do
These _ arg -> pure $ pure [arg]
argumentResolvers & foldMapM id
where
fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO [String]
fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments
fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do
currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch
options <- liftIO $ getOptions codebase projCtx currentBranch
@ -223,8 +222,9 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do
`whenNothingM` throwError FZFCancelled
-- If the user triggered the fuzzy finder, but selected nothing, abort the command rather than continuing execution
-- with no arguments.
when (null results) $ throwError FZFCancelled
pure (Text.unpack <$> results)
if null results
then throwError FZFCancelled
else pure (Left . Text.unpack <$> results)
multiSelectForOptional :: InputPattern.IsOptional -> Bool
multiSelectForOptional = \case

13
unison-cli/src/Unison/CommandLine/InputPattern.hs
View File

@ -4,8 +4,10 @@
module Unison.CommandLine.InputPattern
( InputPattern (..),
Argument,
ArgumentType (..),
ArgumentDescription,
Arguments,
argType,
FZFResolver (..),
IsOptional (..),
@ -25,6 +27,7 @@ import System.Console.Haskeline qualified as Line
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Codebase (Codebase)
import Unison.Codebase.Editor.Input (Input (..))
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
import Unison.Codebase.Path as Path
import Unison.CommandLine.FZFResolvers (FZFResolver (..))
import Unison.Prelude
@ -44,6 +47,14 @@ data IsOptional
data Visibility = Hidden | Visible
deriving (Show, Eq, Ord)
-- | An argument to a command is either a string provided by the user which
-- needs to be parsed or a numbered argument that doesn’t need to be parsed, as
-- we’ve preserved its representation (although the numbered argument could
-- still be of the wrong type, which should result in an error).
type Argument = Either String StructuredArgument
type Arguments = [Argument]
-- | Argument description
-- It should fit grammatically into sentences like "I was expecting an argument for the <argDesc>"
-- e.g. "namespace to merge", "definition to delete", "remote target to push to" etc.
@ -55,7 +66,7 @@ data InputPattern = InputPattern
visibility :: Visibility, -- Allow hiding certain commands when debugging or work-in-progress
args :: [(ArgumentDescription, IsOptional, ArgumentType)],
help :: P.Pretty CT.ColorText,
parse :: [String] -> Either (P.Pretty CT.ColorText) Input
parse :: Arguments -> Either (P.Pretty CT.ColorText) Input
}
data ArgumentType = ArgumentType

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

File diff suppressed because it is too large Load Diff

11
unison-cli/src/Unison/CommandLine/Main.hs
View File

@ -33,7 +33,7 @@ import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.HandleInput qualified as HandleInput
import Unison.Codebase.Editor.Input (Event, Input (..))
import Unison.Codebase.Editor.Output (Output)
import Unison.Codebase.Editor.Output (NumberedArgs, Output)
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Runtime qualified as Runtime
@ -61,7 +61,7 @@ getUserInput ::
Codebase IO Symbol Ann ->
AuthenticatedHttpClient ->
Path.Absolute ->
[String] ->
NumberedArgs ->
IO Input
getUserInput codebase authHTTPClient currentPath numberedArgs =
Line.runInputT
@ -113,10 +113,11 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
-- Ctrl-c or some input cancel, re-run the prompt
go
Right (Just (expandedArgs, i)) -> do
let expandedArgsStr = unwords expandedArgs
when (expandedArgs /= ws) $ do
let expandedArgs' = IP.unifyArgument <$> expandedArgs
expandedArgsStr = unwords expandedArgs'
when (expandedArgs' /= ws) $ do
liftIO . putStrLn $ fullPrompt <> expandedArgsStr
Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ unwords expandedArgs
Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ expandedArgsStr
pure i
settings :: Line.Settings IO
settings =

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

@ -6,9 +6,7 @@
module Unison.CommandLine.OutputMessages where
import Control.Lens hiding (at)
import Control.Monad.State
import Control.Monad.State.Strict qualified as State
import Control.Monad.Writer (Writer, runWriter, tell)
import Data.ByteString.Lazy qualified as LazyByteString
import Data.Foldable qualified as Foldable
import Data.List (stripPrefix)
@ -37,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
@ -64,8 +61,9 @@ import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
import Unison.Codebase.Editor.RemoteRepo (ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..))
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
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
@ -128,7 +124,6 @@ import Unison.Server.Backend qualified as Backend
import Unison.Server.SearchResult' qualified as SR'
import Unison.Share.Sync qualified as Share
import Unison.Share.Sync.Types (CodeserverTransportError (..))
import Unison.ShortHash qualified as ShortHash
import Unison.Sync.Types qualified as Share
import Unison.Syntax.DeclPrinter qualified as DeclPrinter
import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar)
@ -349,7 +344,7 @@ notifyNumbered = \case
]
branchHashes :: [CausalHash]
branchHashes = (fst <$> reversedHistory) <> tailHashes
in (msg, displayBranchHash <$> branchHashes)
in (msg, SA.Namespace <$> branchHashes)
where
toSCH :: CausalHash -> ShortCausalHash
toSCH h = SCH.fromHash schLength h
@ -405,10 +400,9 @@ notifyNumbered = \case
],
numberedArgsForEndangerments ppeDecl endangerments
)
ListEdits patch ppe -> showListEdits patch ppe
ListProjects projects ->
( P.numberedList (map (prettyProjectName . view #name) projects),
map (Text.unpack . into @Text . view #name) projects
map (SA.Project . view #name) projects
)
ListBranches projectName branches ->
( P.columnNHeader
@ -424,7 +418,9 @@ notifyNumbered = \case
]
: map (\branch -> ["", "", prettyRemoteBranchInfo branch]) remoteBranches
),
map (\(branchName, _) -> Text.unpack (into @Text (ProjectAndBranch projectName branchName))) branches
map
(SA.ProjectBranch . ProjectAndBranch (pure projectName) . fst)
branches
)
AmbiguousSwitch project (ProjectAndBranch currentProject branch) ->
( P.wrap
@ -449,8 +445,9 @@ notifyNumbered = \case
<> switch ["2"]
<> " to pick one of these."
),
[ Text.unpack (Text.cons '/' (into @Text branch)),
Text.unpack (into @Text (ProjectAndBranch project (UnsafeProjectBranchName "main")))
[ SA.ProjectBranch $ ProjectAndBranch Nothing branch,
SA.ProjectBranch . ProjectAndBranch (pure project) $
UnsafeProjectBranchName "main"
]
)
where
@ -479,8 +476,8 @@ notifyNumbered = \case
<> reset (resetArgs ["2"])
<> " to pick one of these."
),
[ Text.unpack (Text.cons '/' (into @Text branch)),
Text.unpack (into @Text (show absPath0))
[ SA.ProjectBranch $ ProjectAndBranch Nothing branch,
SA.AbsolutePath absPath0
]
)
where
@ -516,13 +513,13 @@ notifyNumbered = \case
newNextNum = nextNum + length unnumberedNames
in ( newNextNum,
( nameToNum <> (Map.fromList (zip unnumberedNames [nextNum ..])),
args <> fmap Name.toText unnumberedNames
args <> unnumberedNames
)
)
)
(1, (mempty, mempty))
& snd
& over (_2 . mapped) Text.unpack
& over (_2 . mapped) SA.Name
externalDepsTable :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)]
externalDepsTable = ifoldMap $ \ld dependents ->
[(prettyLD ld, prettyDependents dependents)]
@ -551,99 +548,6 @@ undoTip =
<> IP.makeExample' IP.viewReflog
<> "to undo this change."
showListEdits :: Patch -> PPE.PrettyPrintEnv -> (P.Pretty P.ColorText, NumberedArgs)
showListEdits patch ppe =
( P.sepNonEmpty
"\n\n"
[ if null types
then mempty
else
"Edited Types:"
`P.hang` P.column2 typeOutputs,
if null terms
then mempty
else
"Edited Terms:"
`P.hang` P.column2 termOutputs,
if null types && null terms
then "This patch is empty."
else
tip . P.string $
"To remove entries from a patch, use "
<> IP.deleteTermReplacementCommand
<> " or "
<> IP.deleteTypeReplacementCommand
<> ", as appropriate."
],
numberedArgsCol1 <> numberedArgsCol2
)
where
typeOutputs, termOutputs :: [(Pretty, Pretty)]
numberedArgsCol1, numberedArgsCol2 :: NumberedArgs
-- We use the output of the first column's count as the first number in the second
-- column's count. Laziness allows this since they're used independently of one another.
(((typeOutputs, termOutputs), (lastNumberInFirstColumn, _)), (numberedArgsCol1, numberedArgsCol2)) =
runWriter . flip runStateT (1, lastNumberInFirstColumn) $ do
typeOutputs <- traverse prettyTypeEdit types
termOutputs <- traverse prettyTermEdit terms
pure (typeOutputs, termOutputs)
types :: [(Reference, TypeEdit.TypeEdit)]
types = R.toList $ Patch._typeEdits patch
terms :: [(Reference, TermEdit.TermEdit)]
terms = R.toList $ Patch._termEdits patch
showNum :: Int -> Pretty
showNum n = P.hiBlack (P.shown n <> ". ")
prettyTermEdit ::
(Reference.TermReference, TermEdit.TermEdit) ->
StateT (Int, Int) (Writer (NumberedArgs, NumberedArgs)) (Pretty, Pretty)
prettyTermEdit (lhsRef, termEdit) = do
n1 <- gets fst <* modify (first succ)
let lhsTermName = PPE.termName ppe (Referent.Ref lhsRef)
-- We use the shortHash of the lhs rather than its name for numbered args,
-- since its name is likely to be "historical", and won't work if passed to a ucm command.
let lhsHash = Text.unpack . ShortHash.toText . Reference.toShortHash $ lhsRef
case termEdit of
TermEdit.Deprecate -> do
lift $ tell ([lhsHash], [])
pure
( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName),
"-> (deprecated)"
)
TermEdit.Replace rhsRef _typing -> do
n2 <- gets snd <* modify (second succ)
let rhsTermName = PPE.termName ppe (Referent.Ref rhsRef)
lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTermName)])
pure
( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName),
"-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTermName)
)
prettyTypeEdit ::
(Reference, TypeEdit.TypeEdit) ->
StateT (Int, Int) (Writer (NumberedArgs, NumberedArgs)) (Pretty, Pretty)
prettyTypeEdit (lhsRef, typeEdit) = do
n1 <- gets fst <* modify (first succ)
let lhsTypeName = PPE.typeName ppe lhsRef
-- We use the shortHash of the lhs rather than its name for numbered args,
-- since its name is likely to be "historical", and won't work if passed to a ucm command.
let lhsHash = Text.unpack . ShortHash.toText . Reference.toShortHash $ lhsRef
case typeEdit of
TypeEdit.Deprecate -> do
lift $ tell ([lhsHash], [])
pure
( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName),
"-> (deprecated)"
)
TypeEdit.Replace rhsRef -> do
n2 <- gets snd <* modify (second succ)
let rhsTypeName = PPE.typeName ppe rhsRef
lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTypeName)])
pure
( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName),
"-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTypeName)
)
notifyUser :: FilePath -> Output -> IO Pretty
notifyUser dir = \case
SaveTermNameConflict name ->
@ -685,49 +589,6 @@ notifyUser dir = \case
$ "The namespaces "
<> P.commas (prettyBranchId <$> ps)
<> " are empty. Was there a typo?"
WarnIncomingRootBranch current hashes ->
pure $
if null hashes
then
P.wrap $
"Please let someone know I generated an empty IncomingRootBranch"
<> " event, which shouldn't be possible!"
else
P.lines
[ P.wrap $
(if length hashes == 1 then "A" else "Some")
<> "codebase"
<> P.plural hashes "root"
<> "appeared unexpectedly"
<> "with"
<> P.group (P.plural hashes "hash" <> ":"),
"",
(P.indentN 2 . P.oxfordCommas)
(map prettySCH $ toList hashes),
"",
P.wrap $
"and I'm not sure what to do about it."
<> "The last root namespace hash that I knew about was:",
"",
P.indentN 2 $ prettySCH current,
"",
P.wrap $ "Now might be a good time to make a backup of your codebase. 😬",
"",
P.wrap $
"After that, you might try using the"
<> makeExample' IP.forkLocal
<> "command to inspect the namespaces listed above, and decide which"
<> "one you want as your root."
<> "You can also use"
<> makeExample' IP.viewReflog
<> "to see the"
<> "last few root namespace hashes on record.",
"",
P.wrap $
"Once you find one you like, you can use the"
<> makeExample' IP.resetRoot
<> "command to set it."
]
LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath ->
pure $
P.lines
@ -825,13 +686,6 @@ notifyUser dir = \case
<> " by someone else. Trying your command again might fix it."
]
EvaluationFailure err -> pure err
TypeTermMismatch typeName termName ->
pure $
P.warnCallout "I was expecting either two types or two terms but was given a type "
<> P.syntaxToColor (prettyHashQualified typeName)
<> " and a term "
<> P.syntaxToColor (prettyHashQualified termName)
<> "."
SearchTermsNotFound hqs | null hqs -> pure mempty
SearchTermsNotFound hqs ->
pure $
@ -857,8 +711,6 @@ notifyUser dir = \case
P.warnCallout typeOrTermMsg
<> P.newline
<> P.syntaxToColor (P.indent " " (P.lines (prettyHashQualified <$> otherHits)))
PatchNotFound _ ->
pure . P.warnCallout $ "I don't know about that patch."
NameNotFound _ ->
pure . P.warnCallout $ "I don't know about that name."
NamesNotFound hqs ->
@ -876,8 +728,6 @@ notifyUser dir = \case
pure . P.warnCallout $ "A term by that name already exists."
TypeAlreadyExists _ _ ->
pure . P.warnCallout $ "A type by that name already exists."
PatchAlreadyExists _ ->
pure . P.warnCallout $ "A patch by that name already exists."
BranchEmpty b ->
pure . P.warnCallout . P.wrap $
P.group (prettyWhichBranchEmpty b) <> "is an empty namespace."
@ -889,21 +739,21 @@ notifyUser dir = \case
P.lines
[ P.wrap $
"I looked for a function"
<> P.backticked (P.text main)
<> P.backticked (P.text $ HQ.toText main)
<> "in the most recently typechecked file and codebase but couldn't find one. It has to have the type:",
"",
P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts]
P.indentN 2 $ P.lines [P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe t | t <- ts]
]
BadMainFunction what main ty ppe ts ->
pure . P.callout "😶" $
P.lines
[ P.string "I found this function:",
"",
P.indentN 2 $ P.text main <> " : " <> TypePrinter.pretty ppe ty,
P.indentN 2 $ P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe ty,
"",
P.wrap $ P.string "but in order for me to" <> P.backticked (P.text what) <> "it needs to be a subtype of:",
"",
P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts]
P.indentN 2 $ P.lines [P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe t | t <- ts]
]
NoUnisonFile -> do
dir' <- canonicalizePath dir
@ -1240,133 +1090,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
@ -1396,17 +1119,6 @@ notifyUser dir = \case
"You're missing:" `P.hang` P.lines (fmap (P.text . Reference.toText) new),
"I'm missing:" `P.hang` P.lines (fmap (P.text . Reference.toText) old)
]
ListOfPatches patches ->
pure $
if null patches
then P.lit "nothing to show"
else numberedPatches patches
where
numberedPatches :: Set Name -> Pretty
numberedPatches patches =
(P.column2 . fmap format) ([(1 :: Integer) ..] `zip` (toList patches))
where
format (i, p) = (P.hiBlack . fromString $ show i <> ".", prettyName p)
NoConfiguredRemoteMapping pp p -> do
let (localPathExample, sharePathExample) =
if Path.isRoot p
@ -1426,7 +1138,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 $
@ -1540,12 +1252,6 @@ notifyUser dir = \case
"I could't find a type with hash "
<> (prettyShortHash sh)
AboutToPropagatePatch -> pure "Applying changes from patch..."
NothingToPatch _patchPath dest ->
pure $
P.callout "😶" . P.wrap $
"This had no effect. Perhaps the patch has already been applied"
<> "or it doesn't intersect with the definitions in"
<> P.group (prettyPath' dest <> ".")
PatchNeedsToBeConflictFree ->
pure . P.wrap $
"I tried to auto-apply the patch, but couldn't because it contained"
@ -1653,12 +1359,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
@ -1669,32 +1373,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."
@ -1705,7 +1403,8 @@ notifyUser dir = \case
prettyNamespaceKey dest
<> "is already up-to-date with"
<> P.group (prettyNamespaceKey src <> ".")
DumpNumberedArgs args -> pure . P.numberedList $ fmap P.string args
DumpNumberedArgs schLength args ->
pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args
NoConflictsOrEdits ->
pure (P.okCallout "No conflicts or edits in progress.")
HelpMessage pat -> pure $ IP.showPatternHelp pat
@ -1827,7 +1526,7 @@ notifyUser dir = \case
ShareError shareError -> pure (prettyShareError shareError)
ViewOnShare shareRef ->
pure $
"View it on Unison Share: " <> case shareRef of
"View it here: " <> case shareRef of
Left repoPath -> prettyShareLink repoPath
Right branchInfo -> prettyRemoteBranchInfo branchInfo
IntegrityCheck result -> pure $ case result of
@ -1953,12 +1652,17 @@ notifyUser dir = \case
"I just created"
<> prettyProjectName projectName
<> "on"
<> prettyURI host
<> prettyShareURI host
CreatedRemoteProjectBranch host projectAndBranch ->
pure . P.wrap $
"I just created" <> prettyProjectAndBranchName projectAndBranch <> "on" <> prettyURI host
"I just created" <> prettyProjectAndBranchName projectAndBranch <> "on" <> prettyShareURI host
RemoteProjectBranchIsUpToDate host projectAndBranch ->
pure (P.wrap (prettyProjectAndBranchName projectAndBranch <> "on" <> prettyURI host <> "is already up-to-date."))
pure $
P.wrap $
prettyProjectAndBranchName projectAndBranch
<> "on"
<> prettyShareURI host
<> "is already up-to-date."
InvalidProjectName name -> pure (P.wrap (P.text name <> "is not a valid project name."))
InvalidProjectBranchName name -> pure (P.wrap (P.text name <> "is not a valid branch name."))
ProjectNameAlreadyExists name ->
@ -1978,12 +1682,12 @@ notifyUser dir = \case
NotOnProjectBranch -> pure (P.wrap "You are not currently on a branch.")
NoAssociatedRemoteProject host projectAndBranch ->
pure . P.wrap $
prettyProjectAndBranchName projectAndBranch <> "isn't associated with any project on" <> prettyURI host
prettyProjectAndBranchName projectAndBranch <> "isn't associated with any project on" <> prettyShareURI host
NoAssociatedRemoteProjectBranch host (ProjectAndBranch project branch) ->
pure . P.wrap $
prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name))
<> "isn't associated with any branch on"
<> prettyURI host
<> prettyShareURI host
LocalProjectDoesntExist project ->
pure . P.wrap $
prettyProjectName project <> "does not exist."
@ -1999,17 +1703,17 @@ notifyUser dir = \case
<> "exists."
RemoteProjectDoesntExist host project ->
pure . P.wrap $
prettyProjectName project <> "does not exist on" <> prettyURI host
prettyProjectName project <> "does not exist on" <> prettyShareURI host
RemoteProjectBranchDoesntExist host projectAndBranch ->
pure . P.wrap $
prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyURI host
prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyShareURI host
RemoteProjectBranchDoesntExist'Push host projectAndBranch ->
let push = P.group . P.backticked . IP.patternName $ IP.push
in pure . P.wrap $
"The previous push target named"
<> prettyProjectAndBranchName projectAndBranch
<> "has been deleted from"
<> P.group (prettyURI host <> ".")
<> P.group (prettyShareURI host <> ".")
<> "I've deleted the invalid push target."
<> "Run the"
<> push
@ -2018,14 +1722,14 @@ notifyUser dir = \case
pure . P.wrap $
prettyProjectAndBranchName projectAndBranch
<> "on"
<> prettyURI host
<> prettyShareURI host
<> "has some history that I don't know about."
RemoteProjectPublishedReleaseCannotBeChanged host projectAndBranch ->
pure . P.wrap $
"The release"
<> prettyProjectAndBranchName projectAndBranch
<> "on"
<> prettyURI host
<> prettyShareURI host
<> "has already been published and cannot be changed."
<> "Consider making a new release instead."
RemoteProjectReleaseIsDeprecated host projectAndBranch ->
@ -2033,7 +1737,7 @@ notifyUser dir = \case
"The release"
<> prettyProjectAndBranchName projectAndBranch
<> "on"
<> prettyURI host
<> prettyShareURI host
<> "has been deprecated."
Unauthorized message ->
pure . P.wrap $
@ -2794,7 +2498,7 @@ renderNameConflicts ppe conflictedNames = do
P.lines <$> do
for (Map.toList conflictedNames) $ \(name, hashes) -> do
prettyConflicts <- for hashes \hash -> do
n <- addNumberedArg (Text.unpack (HQ.toText hash))
n <- addNumberedArg $ SA.HashQualified hash
pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash)
pure . P.wrap $
( "The "
@ -2826,7 +2530,7 @@ renderEditConflicts ppe Patch {..} = do
<> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits)
numberedHQName :: HQ.HashQualified Name -> Numbered Pretty
numberedHQName hqName = do
n <- addNumberedArg (Text.unpack (HQ.toText hqName))
n <- addNumberedArg $ SA.HashQualified hqName
pure $ formatNum n <> styleHashQualified P.bold hqName
formatTypeEdits ::
(Reference, Set TypeEdit.TypeEdit) ->
@ -2865,9 +2569,9 @@ renderEditConflicts ppe Patch {..} = do
Numbered Pretty
formatConflict = either formatTypeEdits formatTermEdits
type Numbered = State.State (Int, Seq.Seq String)
type Numbered = State.State (Int, Seq.Seq StructuredArgument)
addNumberedArg :: String -> Numbered Int
addNumberedArg :: StructuredArgument -> Numbered Int
addNumberedArg s = do
(n, args) <- State.get
State.put (n + 1, args Seq.|> s)
@ -2939,11 +2643,11 @@ todoOutput ppe todo = runNumbered do
todoEdits :: Numbered Pretty
todoEdits = do
numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do
n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.typeName ppeu ref))
n <- addNumberedArg . SA.HashQualified $ PPE.typeName ppeu ref
pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj)
let filteredTerms = goodTerms (unscore <$> dirtyTerms)
termNumbers <- for filteredTerms \(ref, _, _) -> do
n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.termName ppeu ref))
n <- addNumberedArg . SA.HashQualified $ PPE.termName ppeu ref
pure $ formatNum n
let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms
numberedTerms = zipWith (<>) termNumbers formattedTerms
@ -3243,7 +2947,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
[] -> mempty
x : ys -> " (" <> P.commas (x <> " updates" : ys) <> ")"
pure $ n <> P.bold " patch " <> prettyName name <> message
-- 18. patch q
-- 18. patch q
prettyNamePatch prefix (name, _patchDiff) = do
n <- numPatch prefix name
pure $ n <> P.bold " patch " <> prettyName name
@ -3348,21 +3052,13 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
-- DeclPrinter.prettyDeclHeader : HQ -> Either
numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty
numPatch prefix name =
addNumberedArg' $ prefixBranchId prefix name
addNumberedArg' $ SA.NameWithBranchPrefix prefix name
numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty
numHQ' prefix hq r =
addNumberedArg' . HQ'.toStringWith (prefixBranchId prefix) . HQ'.requalify hq $ r
addNumberedArg' . SA.HashQualifiedWithBranchPrefix prefix $ HQ'.requalify hq r
-- E.g.
-- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef.base.List.map"
-- prefixBranchId ".base" "List.map" -> ".base.List.map"
prefixBranchId :: Input.AbsBranchId -> Name -> String
prefixBranchId branchId name = case branchId of
Left sch -> "#" <> SCH.toString sch <> ":" <> Text.unpack (Name.toText (Name.makeAbsolute name))
Right pathPrefix -> Text.unpack (Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name))
addNumberedArg' :: String -> Numbered Pretty
addNumberedArg' :: StructuredArgument -> Numbered Pretty
addNumberedArg' s = case sn of
ShowNumbers -> do
n <- addNumberedArg s
@ -3617,7 +3313,7 @@ numberedArgsForEndangerments (PPED.unsuffixifiedPPE -> ppe) m =
m
& Map.elems
& concatMap toList
& fmap (Text.unpack . HQ.toText . PPE.labeledRefName ppe)
& fmap (SA.HashQualified . PPE.labeledRefName ppe)
-- | Format and render all dependents which are endangered by references going extinct.
endangeredDependentsTable ::

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
]

8
unison-cli/tests/Unison/Test/Cli/Monad.hs
View File

@ -6,6 +6,8 @@ where
import Control.Lens
import EasyTest
import Unison.Cli.Monad qualified as Cli
import Unison.Codebase.Editor.StructuredArgument qualified as SA
import Unison.Syntax.Name qualified as Name
test :: Test ()
test =
@ -16,13 +18,15 @@ test =
Cli.runCli dummyEnv dummyLoopState do
Cli.label \goto -> do
Cli.label \_ -> do
Cli.setNumberedArgs ["foo"]
Cli.setNumberedArgs [SA.Name $ Name.unsafeParseText "foo"]
goto (1 :: Int)
pure 2
-- test that 'goto' short-circuits, as expected
expectEqual' (Cli.Success 1) r
-- test that calling 'goto' doesn't lose state changes made along the way
expectEqual' ["foo"] (state ^. #numberedArgs)
expectEqual'
[SA.Name $ Name.unsafeParseText "foo"]
(state ^. #numberedArgs)
ok
]

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))

4
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
@ -98,6 +98,7 @@ library
Unison.Codebase.Editor.Slurp
Unison.Codebase.Editor.SlurpComponent
Unison.Codebase.Editor.SlurpResult
Unison.Codebase.Editor.StructuredArgument
Unison.Codebase.Editor.TodoOutput
Unison.Codebase.Editor.UCMVersion
Unison.Codebase.Editor.UriParser
@ -428,7 +429,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]

2
unison-src/transcripts-manual/gen-racket-libs.md
View File

@ -5,7 +5,7 @@ Next, we'll download the jit project and generate a few Racket files from it.
```ucm
.> project.create-empty jit-setup
jit-setup/main> pull @unison/internal/releases/0.0.17 lib.jit
jit-setup/main> lib.install @unison/internal/releases/0.0.17
```
```unison

12
unison-src/transcripts-using-base/fix3939.md Normal file
View File

@ -0,0 +1,12 @@
```unison
{{
A simple doc.
}}
meh = 9
```
```ucm
.> add
.> find meh
.> docs 1
```

40
unison-src/transcripts-using-base/fix3939.output.md Normal file
View File

@ -0,0 +1,40 @@
```unison
{{
A simple doc.
}}
meh = 9
```
```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`:
meh : Nat
meh.doc : Doc2
```
```ucm
.> add
⍟ I've added these definitions:
meh : Nat
meh.doc : Doc2
.> find meh
1. meh : Nat
2. meh.doc : Doc2
.> docs 1
A simple doc.
```

58
unison-src/transcripts/command-replace.md
View File

@ -1,58 +0,0 @@
# Replace with terms and types
Let's set up some definitions to start:
```ucm:hide
.lib> builtins.merge
```
```unison
x = 1
y = 2
structural type X = One Nat
structural type Y = Two Nat Nat
```
```ucm
.> add
```
Test that replace works with terms
```ucm
.> replace x y
.> view x
```
Test that replace works with types
```ucm
.> replace X Y
.> find
.> view.patch patch
.> view X
```
Try with a type/term mismatch
```ucm:error
.> replace X x
```
```ucm:error
.> replace y Y
```
Try with missing references
```ucm:error
.> replace X NOPE
```
```ucm:error
.> replace y nope
```
```ucm:error
.> replace nope X
```
```ucm:error
.> replace nope y
```
```ucm:error
.> replace nope nope
```

146
unison-src/transcripts/command-replace.output.md
View File

@ -1,146 +0,0 @@
# Replace with terms and types
Let's set up some definitions to start:
```unison
x = 1
y = 2
structural type X = One Nat
structural type Y = Two 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 X
structural type Y
x : Nat
y : Nat
```
```ucm
.> add
⍟ I've added these definitions:
structural type X
structural type Y
x : Nat
y : Nat
```
Test that replace works with terms
```ucm
.> replace x y
Done.
.> view x
x : Nat
x = 2
```
Test that replace works with types
```ucm
.> replace X Y
Done.
.> find
1. structural type X
2. x : Nat
3. X.One : Nat -> Nat -> X
4. structural type Y
5. y : Nat
6. Y.Two : Nat -> Nat -> X
.> view.patch patch
Edited Types: 1. #68k40ra7l7 -> 3. X
Edited Terms: 2. #gjmq673r1v -> 4. x
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
.> view X
structural type X = One Nat Nat
```
Try with a type/term mismatch
```ucm
.> replace X x
⚠️
I was expecting either two types or two terms but was given a type X and a term x.
```
```ucm
.> replace y Y
⚠️
I was expecting either two types or two terms but was given a type Y and a term y.
```
Try with missing references
```ucm
.> replace X NOPE
⚠️
The following names were not found in the codebase. Check your spelling.
NOPE
```
```ucm
.> replace y nope
⚠️
The following names were not found in the codebase. Check your spelling.
nope
```
```ucm
.> replace nope X
⚠️
The following names were not found in the codebase. Check your spelling.
nope
```
```ucm
.> replace nope y
⚠️
The following names were not found in the codebase. Check your spelling.
nope
```
```ucm
.> replace nope nope
⚠️
The following names were not found in the codebase. Check your spelling.
nope
nope
```

42
unison-src/transcripts/copy-patch.md
View File

@ -1,42 +0,0 @@
# Test that copying a patch works as expected
```unison:hide
x = 1
```
```ucm
.> add
```
Change the definition of `x` so something goes in our patch:
```unison:hide
x = 2
```
```ucm
.> update.old foo.patch
```
Copy the patch and make sure it's still there.
```ucm
.> copy.patch foo.patch bar.patch
.> ls foo
.> view.patch foo.patch
.> ls bar
.> view.patch bar.patch
```
Now move the patch.
```ucm
.> move.patch foo.patch qux.patch
```
The moved patch should be gone.
```ucm:error
.> view.patch foo.patch
.> ls foo
```

80
unison-src/transcripts/copy-patch.output.md
View File

@ -1,80 +0,0 @@
# Test that copying a patch works as expected
```unison
x = 1
```
```ucm
.> add
⍟ I've added these definitions:
x : ##Nat
```
Change the definition of `x` so something goes in our patch:
```unison
x = 2
```
```ucm
.> update.old foo.patch
⍟ I've updated these names to your new definition:
x : ##Nat
```
Copy the patch and make sure it's still there.
```ucm
.> copy.patch foo.patch bar.patch
Done.
.> ls foo
1. patch (patch)
.> view.patch foo.patch
Edited Terms: 1. #gjmq673r1v -> 2. x
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
.> ls bar
1. patch (patch)
.> view.patch bar.patch
Edited Terms: 1. #gjmq673r1v -> 2. x
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```
Now move the patch.
```ucm
.> move.patch foo.patch qux.patch
Done.
```
The moved patch should be gone.
```ucm
.> view.patch foo.patch
This patch is empty.
.> ls foo
nothing to show
```

23
unison-src/transcripts/delete-namespace-dependents-check.md Normal file
View File

@ -0,0 +1,23 @@
<!-- https://github.com/unisonweb/unison/issues/4997 -->
# Delete namespace dependents check
This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name _anywhere_ in your codebase, it should only check the current project branch.
```ucm:hide
.> project.create-empty myproject
myproject/main> builtins.merge
```
```unison
sub.dependency = 123
dependent = dependency + 99
```
```ucm:error
myproject/main> add
myproject/main> branch /new
myproject/new> delete.namespace sub
myproject/new> view dependent
```

62
unison-src/transcripts/delete-namespace-dependents-check.output.md Normal file
View File

@ -0,0 +1,62 @@
<!-- https://github.com/unisonweb/unison/issues/4997 -->
# Delete namespace dependents check
This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name _anywhere_ in your codebase, it should only check the current project branch.
```unison
sub.dependency = 123
dependent = dependency + 99
```
```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`:
dependent : Nat
sub.dependency : Nat
```
```ucm
myproject/main> add
⍟ I've added these definitions:
dependent : Nat
sub.dependency : Nat
myproject/main> branch /new
Done. I've created the new branch based off of main.
Tip: To merge your work back into the main branch, first
`switch /main` then `merge /new`.
myproject/new> delete.namespace sub
⚠️
I didn't delete the namespace because the following
definitions are still in use.
Dependency Referenced In
dependency 1. dependent
If you want to proceed anyways and leave those definitions
without names, use delete.namespace.force
myproject/new> view dependent
dependent : Nat
dependent =
use Nat +
dependency + 99
```

94
unison-src/transcripts/deleteReplacements.md
View File

@ -1,94 +0,0 @@
# Deleting term and type replacements from patches
```unison
x = 1
```
```ucm
.> add
```
```unison
x = 2
```
```ucm
.> update.old
.> view.patch
```
```ucm
.> delete.term-replacement 1
.> view.patch
```
```unison
unique[a] type Foo = Foo
```
```ucm
.> add
```
```unison
unique[b] type Foo = Foo | Bar
```
```ucm
.> update.old
.> view.patch
```
```ucm
.> delete.type-replacement 1
.> view.patch
```
```unison
bar = 3
unique[aa] type bar = Foo
```
```ucm
.> add
```
```unison
unique[bb] type bar = Foo | Bar
```
```ucm
.> update.old
.> view.patch
.> delete.type-replacement 1
.> view.patch
```
we get an error when attempting to delete something that is neither a type nor a term
```ucm:error
.> view.patch
.> delete.type-replacement notHere
.> view.patch
```
When attempting to delete a type/term that doesn't exist, but a term/type exists
with that name, alert the user.
```unison
baz = 0
```
```ucm:error
.> add baz
.> delete.type-replacement baz
.> view.patch
```
```unison
unique type qux = Qux
```
```ucm:error
.> add qux
.> delete.term-replacement qux
.> view.patch
```

302
unison-src/transcripts/deleteReplacements.output.md
View File

@ -1,302 +0,0 @@
# Deleting term and type replacements from patches
```unison
x = 1
```
```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`:
x : ##Nat
```
```ucm
.> add
⍟ I've added these definitions:
x : ##Nat
```
```unison
x = 2
```
```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 names already exist. You can `update` them to your
new definition:
x : ##Nat
```
```ucm
.> update.old
⍟ I've updated these names to your new definition:
x : ##Nat
.> view.patch
Edited Terms: 1. #gjmq673r1v -> 2. x
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```
```ucm
.> delete.term-replacement 1
Done.
.> view.patch
This patch is empty.
```
```unison
unique[a] type Foo = Foo
```
```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`:
type Foo
```
```ucm
.> add
⍟ I've added these definitions:
type Foo
```
```unison
unique[b] type Foo = Foo | Bar
```
```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 names already exist. You can `update` them to your
new definition:
type Foo
```
```ucm
.> update.old
⍟ I've updated these names to your new definition:
type Foo
.> view.patch
Edited Types: 1. #ool30cf4ma -> 2. Foo
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```
```ucm
.> delete.type-replacement 1
Done.
.> view.patch
This patch is empty.
```
```unison
bar = 3
unique[aa] type bar = Foo
```
```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`:
type bar
bar : ##Nat
```
```ucm
.> add
⍟ I've added these definitions:
type bar
bar : ##Nat
```
```unison
unique[bb] type bar = Foo | Bar
```
```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 names already exist. You can `update` them to your
new definition:
type bar
```
```ucm
.> update.old
⍟ I've updated these names to your new definition:
type bar
.> view.patch
Edited Types: 1. #evhqg163jj -> 2. bar
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
.> delete.type-replacement 1
Done.
.> view.patch
This patch is empty.
```
we get an error when attempting to delete something that is neither a type nor a term
```ucm
.> view.patch
This patch is empty.
.> delete.type-replacement notHere
⚠️
The following names were not found in the codebase. Check your spelling.
notHere
.> view.patch
This patch is empty.
```
When attempting to delete a type/term that doesn't exist, but a term/type exists
with that name, alert the user.
```unison
baz = 0
```
```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`:
baz : ##Nat
```
```ucm
.> add baz
⍟ I've added these definitions:
baz : ##Nat
.> delete.type-replacement baz
⚠️
I was expecting the following names to be types, though I found terms instead.
baz
.> view.patch
This patch is empty.
```
```unison
unique type qux = Qux
```
```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`:
type qux
```
```ucm
.> add qux
⍟ I've added these definitions:
type qux
.> delete.term-replacement qux
⚠️
I was expecting the following names to be terms, though I found types instead.
qux
.> view.patch
This patch is empty.
```

43
unison-src/transcripts/diff-namespace-to-patch.md
View File

@ -1,43 +0,0 @@
We can create a patch from the diff between two namespaces.
```ucm:hide
.> builtins.merge
```
```unison:hide
one.a = 1
one.b = 2
oneconflicts.b = 20
one.c = 3
one.d = 4
one.e = 4
two.a = 100
two.b = 200
two.c = 300
twoconflicts.c = 30
two.d = 5
two.e = 6
```
```ucm:hide
.> add
.> merge.old oneconflicts one
.> merge.old twoconflicts two
.> delete.namespace oneconflicts
.> delete.namespace twoconflicts
```
```ucm
.> find one.
.> find two.
.> diff.namespace.to-patch one two thepatch
```
A summary of the diff:
* `one.a` -> `two.a` is a normal update.
* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`.
* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch.
* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch.
* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g` are not common to both namespaces.

57
unison-src/transcripts/diff-namespace-to-patch.output.md
View File

@ -1,57 +0,0 @@
We can create a patch from the diff between two namespaces.
```unison
one.a = 1
one.b = 2
oneconflicts.b = 20
one.c = 3
one.d = 4
one.e = 4
two.a = 100
two.b = 200
two.c = 300
twoconflicts.c = 30
two.d = 5
two.e = 6
```
```ucm
.> find one.
1. one.a : Nat
2. one.b#cp6 : Nat
3. one.b#dcg : Nat
4. one.c : Nat
5. one.d : Nat
.> find two.
1. two.a : Nat
2. two.b : Nat
3. two.c#k86 : Nat
4. two.c#qpo : Nat
5. two.d : Nat
6. two.e : Nat
.> diff.namespace.to-patch one two thepatch
Edited Terms:
1. one.b#cp6ri8mtg0 -> 4. two.b
2. one.b#dcgdua2lj6 -> 5. two.b
3. one.a -> 6. two.a
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```
A summary of the diff:
* `one.a` -> `two.a` is a normal update.
* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`.
* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch.
* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch.
* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g are not common to both namespaces.

1
unison-src/transcripts/diff-namespace.md
View File

@ -87,7 +87,6 @@ unique type Y a b = Y a b
.> diff.namespace ns1 ns2
.> alias.type ns1.X ns1.X2
.> alias.type ns2.A' ns2.A''
.> view.patch ns2.patch
.> fork ns2 ns3
.> alias.term ns2.fromJust' ns2.yoohoo
.> delete.term.verbose ns2.fromJust'

10
unison-src/transcripts/diff-namespace.output.md
View File

@ -297,16 +297,6 @@ unique type Y a b = Y a b
Done.
.> view.patch ns2.patch
Edited Terms:
1. ns1.b -> 3. ns2.b
2. ns1.fromJust' -> 4. ns2.fromJust
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
.> fork ns2 ns3
Done.

2
unison-src/transcripts/empty-namespaces.md
View File

@ -45,7 +45,7 @@ stuff.thing = 2
```ucm:hide
.> add
.> delete.namespace .deleted
.> delete.namespace deleted
```
## fork

27
unison-src/transcripts/find-patch.md
View File

@ -1,27 +0,0 @@
# find.patch Test
```ucm:hide
.> builtins.merge
```
```unison test.u
hey = "yello"
```
```ucm
.> add
```
Update
```unison test.u
hey = "hello"
```
Update
```ucm
.> update.old
.> find.patch
.> view.patch 1
```

77
unison-src/transcripts/find-patch.output.md
View File

@ -1,77 +0,0 @@
# find.patch Test
```unison
---
title: test.u
---
hey = "yello"
```
```ucm
Loading changes detected in test.u.
I found and typechecked these definitions in test.u. If you do
an `add` or `update`, here's how your codebase would change:
⍟ These new definitions are ok to `add`:
hey : Text
```
```ucm
.> add
⍟ I've added these definitions:
hey : Text
```
Update
```unison
---
title: test.u
---
hey = "hello"
```
```ucm
Loading changes detected in test.u.
I found and typechecked these definitions in test.u. If you do
an `add` or `update`, here's how your codebase would change:
⍟ These names already exist. You can `update` them to your
new definition:
hey : Text
```
Update
```ucm
.> update.old
⍟ I've updated these names to your new definition:
hey : Text
.> find.patch
1. patch
.> view.patch 1
Edited Terms: 1. #m0kuh98ou7 -> 2. hey
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```

30
unison-src/transcripts/fix1334.md
View File

@ -1,8 +1,6 @@
Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` _only_ worked on hashes, and they had to be _full_ hashes.
With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual, and the arguments to `replace.term` and `replace.type` can be a short hash, a name, or a hash-qualified name.
Note: `replace.term` and `replace.type` have since been replaced with just `replace`.
With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual.
Let's make some hash-only aliases, now that we can. :mad-with-power-emoji:
@ -10,29 +8,3 @@ Let's make some hash-only aliases, now that we can. :mad-with-power-emoji:
.> alias.type ##Nat Cat
.> alias.term ##Nat.+ please_fix_763.+
```
And some functions that use them:
```unison
f = 3
g = 4
h = f + 1
> h
```
```ucm
.> add
```
We used to have to know the full hash for a definition to be able to use the `replace` commands, but now we don't:
```ucm
.> names g
.> replace f g
.> names g
.> view.patch
```
The value of `h` should have been updated too:
```unison
> h
```

97
unison-src/transcripts/fix1334.output.md
View File

@ -1,8 +1,6 @@
Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` _only_ worked on hashes, and they had to be _full_ hashes.
With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual, and the arguments to `replace.term` and `replace.type` can be a short hash, a name, or a hash-qualified name.
Note: `replace.term` and `replace.type` have since been replaced with just `replace`.
With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual.
Let's make some hash-only aliases, now that we can. :mad-with-power-emoji:
@ -16,96 +14,3 @@ Let's make some hash-only aliases, now that we can. :mad-with-power-emoji:
Done.
```
And some functions that use them:
```unison
f = 3
g = 4
h = f + 1
> h
```
```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`:
f : Cat
g : Cat
h : Cat
Now evaluating any watch expressions (lines starting with
`>`)... Ctrl+C cancels.
5 | > h
⧩
4
```
```ucm
.> add
⍟ I've added these definitions:
f : Cat
g : Cat
h : Cat
```
We used to have to know the full hash for a definition to be able to use the `replace` commands, but now we don't:
```ucm
.> names g
Term
Hash: #vcfbbslncd
Names: g
Tip: Use `names.global` to see more results.
.> replace f g
Done.
.> names g
Term
Hash: #vcfbbslncd
Names: f g
Tip: Use `names.global` to see more results.
.> view.patch
Edited Terms: 1. #f3lgjvjqoo -> 2. f
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```
The value of `h` should have been updated too:
```unison
> h
```
```ucm
Loading changes detected in scratch.u.
✅
scratch.u changed.
Now evaluating any watch expressions (lines starting with
`>`)... Ctrl+C cancels.
1 | > h
⧩
5
```

17
unison-src/transcripts/fix4898.md Normal file
View File

@ -0,0 +1,17 @@
```ucm
.> builtins.merge
```
```unison
double : Int -> Int
double x = x + x
redouble : Int -> Int
redouble x = double x + double x
```
```ucm
.> add
.> dependents double
.> delete.term 1
```

52
unison-src/transcripts/fix4898.output.md Normal file
View File

@ -0,0 +1,52 @@
```ucm
.> builtins.merge
Done.
```
```unison
double : Int -> Int
double x = x + x
redouble : Int -> Int
redouble x = double x + double x
```
```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`:
double : Int -> Int
redouble : Int -> Int
```
```ucm
.> add
⍟ I've added these definitions:
double : Int -> Int
redouble : Int -> Int
.> dependents double
Dependents of: double
Terms:
1. redouble
Tip: Try `view 1` to see the source of any numbered item in
the above list.
.> delete.term 1
Done.
```

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.
```

2
unison-src/transcripts/merges.md
View File

@ -52,7 +52,7 @@ We can also delete the fork if we're done with it. (Don't worry, even though the
it's still in the `history` of the parent namespace and can be resurrected at any time.)
```ucm
.> delete.namespace .feature1
.> delete.namespace feature1
.> history .feature1
.> history
```

2
unison-src/transcripts/merges.output.md
View File

@ -106,7 +106,7 @@ We can also delete the fork if we're done with it. (Don't worry, even though the
it's still in the `history` of the parent namespace and can be resurrected at any time.)
```ucm
.> delete.namespace .feature1
.> delete.namespace feature1
Done.

116
unison-src/transcripts/resolve.md
View File

@ -1,116 +0,0 @@
# Resolving edit conflicts in `ucm`
```ucm:hide
.> builtins.merge
```
The `ucm` tool tracks edits to hashes in an object called a _patch_. When patches get merged, sometimes those patches will have conflicting edits. The `replace` command helps resolve such conflicts.
First, let's make a new namespace, `example.resolve` and add the builtins:
```ucm:hide
.example.resolve> builtins.merge
```
Now let's add a term named `a.foo`:
```unison
a.foo = 42
```
```ucm
.example.resolve> add
```
We'll fork the namespace `a` into a new namespace `b`, so we can edit the two concurrently.
```ucm
.example.resolve> fork a b
```
We'll also make a second fork `c` which we'll use as the target for our patch later.
```ucm
.example.resolve> fork a c
```
Now let's make a change to `foo` in the `a` namespace:
```ucm
.example.resolve> deprecated.cd a
```
```unison
foo = 43
```
```ucm
.example.resolve.a> update.old
```
And make a different change in the `b` namespace:
```ucm
.example.resolve> deprecated.cd .example.resolve.b
```
```unison
foo = 44
```
```ucm
.example.resolve.b> update.old
```
The `a` and `b` namespaces now each contain a patch named `patch`. We can view these:
```ucm
.example.resolve.b> deprecated.cd .example.resolve
.example.resolve> view.patch a.patch
.example.resolve> view.patch b.patch
```
Let's now merge these namespaces into `c`:
```ucm
.example.resolve> merge.old a c
```
```ucm:error
.example.resolve> merge.old b c
```
The namespace `c` now has an edit conflict, since the term `foo` was edited in two different ways.
```ucm:error
.example.resolve> deprecated.cd c
.example.resolve.c> todo
```
We see that the original hash of `a.foo` got replaced with _two different_ hashes.
We can resolve this conflict by picking one of the terms as the "winner":
```ucm
.example.resolve.c> replace 1 2
```
This changes the merged `c.patch` so that only a single edit remains and resolves the conflict.
```ucm
.example.resolve.c> view.patch
```
We still have a remaining _name conflict_ since it just so happened that both of the definitions in the edits were named `foo`.
```ucm:error
.example.resolve.c> todo
```
We can resolve the name conflict by deleting one of the names.
```ucm
.example.resolve.c> delete.term.verbose 2
.example.resolve.c> todo
```
And that's how you resolve edit conflicts with UCM.

265
unison-src/transcripts/resolve.output.md
View File

@ -1,265 +0,0 @@
# Resolving edit conflicts in `ucm`
The `ucm` tool tracks edits to hashes in an object called a _patch_. When patches get merged, sometimes those patches will have conflicting edits. The `replace` command helps resolve such conflicts.
First, let's make a new namespace, `example.resolve` and add the builtins:
Now let's add a term named `a.foo`:
```unison
a.foo = 42
```
```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`:
a.foo : Nat
```
```ucm
.example.resolve> add
⍟ I've added these definitions:
a.foo : Nat
```
We'll fork the namespace `a` into a new namespace `b`, so we can edit the two concurrently.
```ucm
.example.resolve> fork a b
Done.
```
We'll also make a second fork `c` which we'll use as the target for our patch later.
```ucm
.example.resolve> fork a c
Done.
```
Now let's make a change to `foo` in the `a` namespace:
```ucm
.example.resolve> deprecated.cd a
```
```unison
foo = 43
```
```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 names already exist. You can `update` them to your
new definition:
foo : ##Nat
```
```ucm
.example.resolve.a> update.old
⍟ I've updated these names to your new definition:
foo : ##Nat
```
And make a different change in the `b` namespace:
```ucm
.example.resolve> deprecated.cd .example.resolve.b
```
```unison
foo = 44
```
```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 names already exist. You can `update` them to your
new definition:
foo : ##Nat
```
```ucm
.example.resolve.b> update.old
⍟ I've updated these names to your new definition:
foo : ##Nat
```
The `a` and `b` namespaces now each contain a patch named `patch`. We can view these:
```ucm
.example.resolve.b> deprecated.cd .example.resolve
.example.resolve> view.patch a.patch
Edited Terms: 1. c.foo -> 2. a.foo
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
.example.resolve> view.patch b.patch
Edited Terms: 1. c.foo -> 2. b.foo
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```
Let's now merge these namespaces into `c`:
```ucm
.example.resolve> merge.old a c
Here's what's changed in c after the merge:
Updates:
1. foo : Nat
↓
2. foo : Nat
Added definitions:
3. patch patch (added 1 updates)
Tip: You can use `todo` to see if this generated any work to
do in this namespace and `test` to run the tests. Or you
can use `undo` or `reflog` to undo the results of this
merge.
Applying changes from patch...
```
```ucm
.example.resolve> merge.old b c
Here's what's changed in c after the merge:
New name conflicts:
1. foo#emomp74i93 : Nat
↓
2. ┌ foo#a84tg4er4k : Nat
3. └ foo#emomp74i93 : Nat
Updates:
4. patch patch (added 1 updates)
Tip: You can use `todo` to see if this generated any work to
do in this namespace and `test` to run the tests. Or you
can use `undo` or `reflog` to undo the results of this
merge.
Applying changes from patch...
I tried to auto-apply the patch, but couldn't because it
contained contradictory entries.
```
The namespace `c` now has an edit conflict, since the term `foo` was edited in two different ways.
```ucm
.example.resolve> deprecated.cd c
.example.resolve.c> todo
❓
These definitions were edited differently in namespaces that
have been merged into this one. You'll have to tell me what to
use as the new definition:
The term 1. #qkhkl0n238 was replaced with
2. foo#a84tg4er4k
3. foo#emomp74i93
```
We see that the original hash of `a.foo` got replaced with _two different_ hashes.
We can resolve this conflict by picking one of the terms as the "winner":
```ucm
.example.resolve.c> replace 1 2
Done.
```
This changes the merged `c.patch` so that only a single edit remains and resolves the conflict.
```ucm
.example.resolve.c> view.patch
Edited Terms: 1. #qkhkl0n238 -> 2. foo#a84tg4er4k
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```
We still have a remaining _name conflict_ since it just so happened that both of the definitions in the edits were named `foo`.
```ucm
.example.resolve.c> todo
❓
The term foo has conflicting definitions:
1. foo#a84tg4er4k
2. foo#emomp74i93
Tip: This occurs when merging branches that both independently
introduce the same name. Use `move.term` or `delete.term`
to resolve the conflicts.
```
We can resolve the name conflict by deleting one of the names.
```ucm
.example.resolve.c> delete.term.verbose 2
Resolved name conflicts:
1. ┌ foo#a84tg4er4k : ##Nat
2. └ foo#emomp74i93 : ##Nat
↓
3. foo#a84tg4er4k : ##Nat
Tip: You can use `undo` or `reflog` to undo this change.
.example.resolve.c> todo
✅
No conflicts or edits in progress.
```
And that's how you resolve edit conflicts with UCM.

4
unison-src/transcripts/tab-completion.output.md
View File

@ -9,20 +9,16 @@ Test that tab completion works as expected.
view
view.global
view.patch
.> debug.tab-complete delete.
delete.branch
delete.namespace
delete.namespace.force
delete.patch
delete.project
delete.term
delete.term-replacement
delete.term.verbose
delete.type
delete.type-replacement
delete.type.verbose
delete.verbose

1
unison-src/transcripts/todo.md
View File

@ -103,7 +103,6 @@ oldfoo = 801
```ucm
.lhs> add
.lhs> view.patch patch
.lhs> todo
```

8
unison-src/transcripts/todo.output.md
View File

@ -205,14 +205,6 @@ oldfoo = 801
oldfoo : Nat
.lhs> view.patch patch
Edited Terms: 1. oldfoo -> 2. foo
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
.lhs> todo
✅

3
unison-src/transcripts/update-on-conflict.md
View File

@ -17,7 +17,7 @@ Cause a conflict:
.merged> merge.old .b
```
Updating conflicted definitions works fine, and the associated patch contains two entries.
Updating conflicted definitions works fine.
```unison
x = 3
@ -25,5 +25,4 @@ x = 3
```ucm
.merged> update
.merged> view.patch
```

6
unison-src/transcripts/update-on-conflict.output.md
View File

@ -64,7 +64,7 @@ Cause a conflict:
Applying changes from patch...
```
Updating conflicted definitions works fine, and the associated patch contains two entries.
Updating conflicted definitions works fine.
```unison
x = 3
@ -92,8 +92,4 @@ x = 3
Done.
.merged> view.patch
This patch is empty.
```