Merge remote-tracking branch 'upstream/trunk' into restrict-NameSegment

This commit is contained in:
Greg Pfeil 2024-05-31 14:44:19 -06:00
commit 5a7e001d7c
No known key found for this signature in database
GPG Key ID: 1193ACD196ED61F2
132 changed files with 4655 additions and 6544 deletions

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

View File

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

View File

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

4
.gitignore vendored
View File

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

View File

@ -11,9 +11,12 @@ pull_request_rules:
- check-success=run interpreter tests (macOS-12) - check-success=run interpreter tests (macOS-12)
# - check-success=run interpreter tests (windows-2019) # - check-success=run interpreter tests (windows-2019)
- check-success=generate jit source - check-success=generate jit source
- check-success=build jit binary (ubuntu-20.04) - check-success=build jit binary / build jit binary (ubuntu-20.04)
- check-success=build jit binary (macOS-12) - check-success=build jit binary / build jit binary (macOS-12)
- check-success=build jit binary (windows-2019) - check-success=build jit binary / build jit binary (windows-2019)
- check-success=test jit / test jit (ubuntu-20.04)
- check-success=test jit / test jit (macOS-12)
# - check-success=test jit / test jit (windows-2019)
- label=ready-to-merge - label=ready-to-merge
- "#approved-reviews-by>=1" - "#approved-reviews-by>=1"
actions: actions:

View File

@ -1,7 +1,8 @@
The Unison language 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) * [Overview](#overview)
* [Building using Stack](#building-using-stack) * [Building using Stack](#building-using-stack)

View File

@ -21,8 +21,33 @@ library:
other-modules: Paths_unison_codebase other-modules: Paths_unison_codebase
default-extensions: default-extensions:
- BangPatterns
- BlockArguments - BlockArguments
- DeriveAnyClass
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies - DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- DuplicateRecordFields
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- ImportQualifiedPost
- LambdaCase - LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedLabels
- OverloadedRecordDot
- OverloadedStrings
- PatternSynonyms
- RankNTypes
- ScopedTypeVariables
- StandaloneDeriving
- TupleSections
- TypeApplications
- TypeFamilies
- ViewPatterns
language: GHC2021 language: GHC2021

View File

@ -1,6 +1,6 @@
cabal-version: 1.12 cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.35.2. -- This file has been generated from package.yaml by hpack version 0.36.0.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
@ -31,9 +31,34 @@ library
hs-source-dirs: hs-source-dirs:
./ ./
default-extensions: default-extensions:
BangPatterns
BlockArguments BlockArguments
DeriveAnyClass
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
ImportQualifiedPost
LambdaCase LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedLabels
OverloadedRecordDot
OverloadedStrings
PatternSynonyms
RankNTypes
ScopedTypeVariables
StandaloneDeriving
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
build-depends: build-depends:
base base
, containers , containers

View File

@ -126,9 +126,9 @@ This is specified with the normal
Some examples: Some examples:
``` ```
nix build '.#haskell-nix.unison-cli:lib:unison-cli' nix build '.#component-unison-cli:lib:unison-cli'
nix build '.#haskell-nix.unison-syntax:test:syntax-tests' nix build '.#component-unison-syntax:test:syntax-tests'
nix build '.#haskell-nix.unison-cli:exe:transcripts' nix build '.#component-unison-cli:exe:transcripts'
``` ```
### Development environments ### Development environments
@ -154,7 +154,7 @@ all non-local haskell dependencies (including profiling dependencies)
are provided in the nix shell. 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 #### 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). (including profiling dependencies).
``` ```
nix develop '.#haskell-nix.<package-name>' nix develop '.#cabal-<package-name>'
``` ```
for example: for example:
``` ```
nix develop '.#haskell-nix.unison-cli' nix develop '.#cabal-unison-cli'
``` ```
or 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 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. profiling.
``` ```
nix develop '.#unison-parser-typechecker' nix develop '.#cabal-unison-parser-typechecker'
cd unison-cli cd unison-cli
cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p
``` ```

View File

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

View File

@ -12,6 +12,7 @@ dependencies:
- base - base
- bytestring - bytestring
- containers - containers
- directory
- generic-lens - generic-lens
- either - either
- extra - extra

View File

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

View File

@ -82,6 +82,7 @@ import GHC.Generics as X (Generic, Generic1)
import GHC.IO.Handle qualified as Handle import GHC.IO.Handle qualified as Handle
import GHC.Stack as X (HasCallStack) import GHC.Stack as X (HasCallStack)
import Safe as X (atMay, headMay, lastMay, readMay) import Safe as X (atMay, headMay, lastMay, readMay)
import System.Directory qualified as Directory
import System.FilePath qualified as FilePath import System.FilePath qualified as FilePath
import System.IO qualified as IO import System.IO qualified as IO
import Text.Read as X (readMaybe) import Text.Read as X (readMaybe)
@ -236,23 +237,28 @@ writeUtf8 fileName txt = do
Handle.hSetEncoding handle IO.utf8 Handle.hSetEncoding handle IO.utf8
Text.hPutStr handle txt Text.hPutStr handle txt
-- | Atomically prepend some text to a file -- | Atomically prepend some text to a file, creating the file if it doesn't already exist
prependUtf8 :: FilePath -> Text -> IO () prependUtf8 :: FilePath -> Text -> IO ()
prependUtf8 path txt = do prependUtf8 path txt = do
let withTempFile tmpFilePath tmpHandle = do Directory.doesFileExist path >>= \case
Text.hPutStrLn tmpHandle txt False -> writeUtf8 path txt
IO.withFile path IO.ReadMode \currentScratchFile -> do True -> do
let copyLoop = do let withTempFile tmpFilePath tmpHandle = do
chunk <- Text.hGetChunk currentScratchFile Handle.hSetEncoding tmpHandle IO.utf8
case Text.length chunk == 0 of Text.hPutStrLn tmpHandle txt
True -> pure () IO.withFile path IO.ReadMode \currentScratchFile -> do
False -> do Handle.hSetEncoding currentScratchFile IO.utf8
Text.hPutStr tmpHandle chunk let copyLoop = do
copyLoop chunk <- Text.hGetChunk currentScratchFile
copyLoop case Text.length chunk == 0 of
IO.hClose tmpHandle True -> pure ()
UnliftIO.renameFile tmpFilePath path False -> do
UnliftIO.withTempFile (FilePath.takeDirectory path) ".unison-scratch" withTempFile Text.hPutStr tmpHandle chunk
copyLoop
copyLoop
IO.hClose tmpHandle
UnliftIO.renameFile tmpFilePath path
UnliftIO.withTempFile (FilePath.takeDirectory path) ".unison-scratch" withTempFile
reportBug :: String -> String -> String reportBug :: String -> String -> String
reportBug bugId msg = reportBug bugId msg =

View File

@ -5,6 +5,7 @@ module Unison.Util.Map
bitraverse, bitraverse,
bitraversed, bitraversed,
deleteLookup, deleteLookup,
deleteLookupJust,
elemsSet, elemsSet,
foldM, foldM,
foldMapM, foldMapM,
@ -21,6 +22,7 @@ module Unison.Util.Map
upsertF, upsertF,
upsertLookup, upsertLookup,
valuesVector, valuesVector,
asList_,
) )
where where
@ -56,6 +58,15 @@ bitraversed :: (Ord a', Ord k') => Traversal k k' a a' -> Traversal v v' a a' ->
bitraversed keyT valT f m = bitraversed keyT valT f m =
bitraverse (keyT f) (valT f) m bitraverse (keyT f) (valT f) m
-- | Traverse a map as a list of key-value pairs.
-- Note: This can have unexpected results if the result contains duplicate keys.
asList_ :: Ord k' => Traversal (Map k v) (Map k' v') [(k, v)] [(k', v')]
asList_ f s =
s
& Map.toList
& f
<&> Map.fromList
-- | 'swap' throws away data if the input contains duplicate values -- | 'swap' throws away data if the input contains duplicate values
swap :: (Ord b) => Map a b -> Map b a swap :: (Ord b) => Map a b -> Map b a
swap = swap =
@ -96,6 +107,11 @@ deleteLookup :: (Ord k) => k -> Map k v -> (Maybe v, Map k v)
deleteLookup = deleteLookup =
Map.alterF (,Nothing) 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. -- | Like 'Map.elems', but return the values as a set.
elemsSet :: Ord v => Map k v -> Set v elemsSet :: Ord v => Map k v -> Set v
elemsSet = elemsSet =

View File

@ -65,6 +65,7 @@ library
base base
, bytestring , bytestring
, containers , containers
, directory
, either , either
, extra , extra
, filepath , filepath

View File

@ -5,6 +5,6 @@
name = "ucm"; name = "ucm";
tag = "latest"; tag = "latest";
contents = with pkgs; [ cacert fzf ]; 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" ];
}; };
} }

View File

@ -86,10 +86,6 @@ module Unison.Codebase
syncFromDirectory, syncFromDirectory,
syncToDirectory, syncToDirectory,
-- ** Remote sync
viewRemoteBranch,
pushGitBranch,
-- * Codebase path -- * Codebase path
getCodebaseDir, getCodebaseDir,
CodebasePath, CodebasePath,
@ -124,13 +120,11 @@ import Unison.Codebase.Branch (Branch)
import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation))
import Unison.Codebase.CodeLookup qualified as CL 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
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations 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.CodebasePath (CodebasePath, getCodebaseDir)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import Unison.DataDeclaration (Decl) import Unison.DataDeclaration (Decl)
@ -466,20 +460,6 @@ isType c r = case r of
Reference.Builtin {} -> pure $ Builtin.isBuiltinType r Reference.Builtin {} -> pure $ Builtin.isBuiltinType r
Reference.DerivedId r -> isJust <$> getTypeDeclaration c 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 :: (HasCallStack) => Hash -> Sqlite.Transaction Reference.CycleSize
unsafeGetComponentLength h = unsafeGetComponentLength h =
Operations.getCycleLen h >>= \case Operations.getCycleLen h >>= \case

View File

@ -476,13 +476,18 @@ cons :: (Applicative m) => Branch0 m -> Branch m -> Branch m
cons = step . const cons = step . const
-- | Construct a two-parent merge node. -- | Construct a two-parent merge node.
mergeNode :: forall m. Applicative m => Branch0 m -> Branch m -> Branch m -> Branch m mergeNode ::
forall m.
Applicative m =>
Branch0 m ->
(CausalHash, m (Branch m)) ->
(CausalHash, m (Branch m)) ->
Branch m
mergeNode child parent1 parent2 = mergeNode child parent1 parent2 =
Branch (Causal.mergeNode child (Map.fromList [f parent1, f parent2])) Branch (Causal.mergeNode child (Map.fromList [f parent1, f parent2]))
where where
f :: Branch m -> (CausalHash, m (Causal m (Branch0 m))) f (hash, getBranch) =
f parent = (hash, _history <$> getBranch)
(headHash parent, pure (_history parent))
isOne :: Branch m -> Bool isOne :: Branch m -> Bool
isOne (Branch Causal.One {}) = True isOne (Branch Causal.One {}) = True
@ -606,20 +611,17 @@ modifyAt path f = runIdentity . modifyAtM path (pure . f)
-- Because it's a `Branch`, it overwrites the history at `path`. -- Because it's a `Branch`, it overwrites the history at `path`.
modifyAtM :: modifyAtM ::
forall n m. forall n m.
(Functor n) => (Functor n, Applicative m) =>
(Applicative m) => -- because `Causal.cons` uses `pure`
Path -> Path ->
(Branch m -> n (Branch m)) -> (Branch m -> n (Branch m)) ->
Branch m -> Branch m ->
n (Branch m) n (Branch m)
modifyAtM path f b = case Path.uncons path of modifyAtM path f b = case Path.uncons path of
Nothing -> f b Nothing -> f b
Just (seg, path) -> do Just (seg, path) ->
-- Functor
let child = getChildBranch seg (head b) let child = getChildBranch seg (head b)
child' <- modifyAtM path f child in -- step the branch by updating its children according to fixup
-- step the branch by updating its children according to fixup (\child' -> step (setChildBranch seg child') b) <$> modifyAtM path f child
pure $ step (setChildBranch seg child') b
-- | Perform updates over many locations within a branch by batching up operations on -- | Perform updates over many locations within a branch by batching up operations on
-- sub-branches as much as possible without affecting semantics. -- sub-branches as much as possible without affecting semantics.

View File

@ -15,8 +15,6 @@ module Unison.Codebase.BranchUtil
makeAddTermName, makeAddTermName,
makeDeleteTermName, makeDeleteTermName,
makeAnnihilateTermName, makeAnnihilateTermName,
makeDeletePatch,
makeReplacePatch,
) )
where where
@ -24,7 +22,6 @@ import Data.Map qualified as Map
import Data.Set qualified as Set import Data.Set qualified as Set
import Unison.Codebase.Branch (Branch, Branch0) import Unison.Codebase.Branch (Branch, Branch0)
import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path) import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.HashQualified' (HashQualified (HashQualified, NameOnly)) 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 :: Path.Split -> (Path, Branch0 m -> Branch0 m)
makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name) 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 :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m)
makeAddTypeName (p, name) r = (p, Branch.addTypeName r name) makeAddTypeName (p, name) r = (p, Branch.addTypeName r name)

View File

@ -4,8 +4,19 @@ module Unison.Codebase.Editor.DisplayObject where
import Data.Bifoldable import Data.Bifoldable
import Data.Bitraversable import Data.Bitraversable
import Data.Set qualified as Set
import U.Codebase.Reference (TermReference, TypeReference)
import Unison.DataDeclaration qualified as DD
import Unison.DataDeclaration.Dependencies qualified as DD
import Unison.LabeledDependency qualified as LD
import Unison.Parser.Ann (Ann)
import Unison.Prelude import Unison.Prelude
import Unison.ShortHash (ShortHash) import Unison.ShortHash (ShortHash)
import Unison.Symbol (Symbol)
import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Type (Type)
import Unison.Type qualified as Type
data DisplayObject b a = BuiltinObject b | MissingObject ShortHash | UserObject a data DisplayObject b a = BuiltinObject b | MissingObject ShortHash | UserObject a
deriving (Eq, Ord, Show, Functor, Generic, Foldable, Traversable) deriving (Eq, Ord, Show, Functor, Generic, Foldable, Traversable)
@ -27,3 +38,14 @@ toMaybe :: DisplayObject b a -> Maybe a
toMaybe = \case toMaybe = \case
UserObject a -> Just a UserObject a -> Just a
_ -> Nothing _ -> Nothing
termDisplayObjectLabeledDependencies :: TermReference -> DisplayObject (Type Symbol Ann) (Term Symbol Ann) -> (Set LD.LabeledDependency)
termDisplayObjectLabeledDependencies termRef displayObject = do
displayObject
& bifoldMap (Type.labeledDependencies) (Term.labeledDependencies)
& Set.insert (LD.TermReference termRef)
typeDisplayObjectLabeledDependencies :: TypeReference -> DisplayObject () (DD.Decl Symbol Ann) -> Set LD.LabeledDependency
typeDisplayObjectLabeledDependencies typeRef displayObject = do
displayObject
& foldMap (DD.labeledDeclDependenciesIncludingSelfAndFieldAccessors typeRef)

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

View File

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

View File

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

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)

View File

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

View File

@ -2,6 +2,7 @@ module Unison.Codebase.ShortCausalHash
( toString, ( toString,
toHash, toHash,
fromHash, fromHash,
fromFullHash,
fromText, fromText,
ShortCausalHash (..), ShortCausalHash (..),
) )
@ -27,6 +28,14 @@ fromHash :: (Coercible h Hash.Hash) => Int -> h -> ShortCausalHash
fromHash len = fromHash len =
ShortCausalHash . Text.take len . Hash.toBase32HexText . coerce 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 arent
-- 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
-- #abc -> SCH abc -- #abc -> SCH abc
fromText :: Text -> Maybe ShortCausalHash fromText :: Text -> Maybe ShortCausalHash

View File

@ -14,17 +14,13 @@ where
import Control.Monad.Except qualified as Except import Control.Monad.Except qualified as Except
import Control.Monad.Extra qualified as Monad import Control.Monad.Extra qualified as Monad
import Data.Char qualified as Char
import Data.Either.Extra () import Data.Either.Extra ()
import Data.IORef import Data.IORef
import Data.Map qualified as Map import Data.Map qualified as Map
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Time (getCurrentTime) import Data.Time (getCurrentTime)
import System.Console.ANSI qualified as ANSI import System.Console.ANSI qualified as ANSI
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock) 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.HashTags (CausalHash, PatchHash (..))
import U.Codebase.Reflog qualified as Reflog import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.Operations qualified as Ops 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 qualified as Codebase1
import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch (Branch (..))
import Unison.Codebase.Branch qualified as 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 (BackupStrategy (..), CodebaseLockOption (..), MigrationStrategy (..), VacuumStrategy (..))
import Unison.Codebase.Init qualified as Codebase import Unison.Codebase.Init qualified as Codebase
import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1 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.Cache (newBranchCache)
import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv 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.Migrations qualified as Migrations
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
import Unison.Codebase.SqliteCodebase.Paths import Unison.Codebase.SqliteCodebase.Paths
import Unison.Codebase.SqliteCodebase.SyncEphemeral qualified as SyncEphemeral 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.Codebase.Type qualified as C
import Unison.DataDeclaration (Decl) import Unison.DataDeclaration (Decl)
import Unison.Hash (Hash) import Unison.Hash (Hash)
@ -75,9 +61,8 @@ import Unison.Term (Term)
import Unison.Type (Type) import Unison.Type (Type)
import Unison.Util.Timing (time) import Unison.Util.Timing (time)
import Unison.WatchKind qualified as UF import Unison.WatchKind qualified as UF
import UnliftIO (UnliftIO (..), finally, throwIO, try) import UnliftIO (UnliftIO (..), finally)
import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import UnliftIO.Exception (catch)
import UnliftIO.STM import UnliftIO.STM
debug, debugProcessBranches :: Bool debug, debugProcessBranches :: Bool
@ -103,30 +88,6 @@ initWithSetup onCreate =
codebasePath = makeCodebaseDirPath 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. -- | Create a codebase at the given location.
createCodebaseOrError :: createCodebaseOrError ::
(MonadUnliftIO m) => (MonadUnliftIO m) =>
@ -379,8 +340,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
putBranch, putBranch,
syncFromDirectory, syncFromDirectory,
syncToDirectory, syncToDirectory,
viewRemoteBranch',
pushGitBranch = \repo opts action -> withConn \conn -> pushGitBranch conn repo opts action,
getWatch, getWatch,
termsOfTypeImpl, termsOfTypeImpl,
termsMentioningTypeImpl, termsMentioningTypeImpl,
@ -571,214 +530,6 @@ syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (l
where where
v = const () 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 -- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase
-- at the source to the destination. -- at the source to the destination.
-- Note: this does not copy the .unisonConfig file. -- Note: this does not copy the .unisonConfig file.

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)

View File

@ -6,6 +6,7 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchem
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.State import Control.Monad.State
import U.Codebase.Branch.Type (NamespaceStats)
import U.Codebase.Sqlite.DbId qualified as DB import U.Codebase.Sqlite.DbId qualified as DB
import U.Codebase.Sqlite.DbId qualified as Db import U.Codebase.Sqlite.DbId qualified as Db
import U.Codebase.Sqlite.Operations qualified as Ops import U.Codebase.Sqlite.Operations qualified as Ops
@ -50,7 +51,7 @@ addStatsForBranch :: DB.BranchObjectId -> Sqlite.Transaction (Sync.TrySyncResult
addStatsForBranch boId = do addStatsForBranch boId = do
bhId <- Db.BranchHashId <$> Q.expectPrimaryHashIdForObject (Db.unBranchObjectId boId) bhId <- Db.BranchHashId <$> Q.expectPrimaryHashIdForObject (Db.unBranchObjectId boId)
-- "expectNamespaceStatsByHashId" computes stats if they are missing. -- "expectNamespaceStatsByHashId" computes stats if they are missing.
Ops.expectNamespaceStatsByHashId bhId _ :: NamespaceStats <- Ops.expectNamespaceStatsByHashId bhId
pure Sync.Done pure Sync.Done
debugLog :: String -> Sqlite.Transaction () debugLog :: String -> Sqlite.Transaction ()

View File

@ -4,21 +4,13 @@
module Unison.Codebase.Type module Unison.Codebase.Type
( Codebase (..), ( Codebase (..),
CodebasePath, CodebasePath,
GitPushBehavior (..),
GitError (..),
LocalOrRemote (..), LocalOrRemote (..),
gitErrorFromOpenCodebaseError,
) )
where where
import U.Codebase.HashTags (CausalHash) import U.Codebase.HashTags (CausalHash)
import U.Codebase.Reference qualified as V2 import U.Codebase.Reference qualified as V2
import Unison.Codebase.Branch (Branch) 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.CodebasePath (CodebasePath)
import Unison.ConstructorType qualified as CT import Unison.ConstructorType qualified as CT
import Unison.DataDeclaration (Decl) import Unison.DataDeclaration (Decl)
@ -80,9 +72,6 @@ data Codebase m v a = Codebase
syncFromDirectory :: CodebasePath -> Branch m -> m (), syncFromDirectory :: CodebasePath -> Branch m -> m (),
-- | Copy a branch and all of its dependencies from this codebase into the given codebase. -- | Copy a branch and all of its dependencies from this codebase into the given codebase.
syncToDirectory :: CodebasePath -> Branch m -> m (), syncToDirectory :: CodebasePath -> Branch m -> m (),
viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r),
-- | Push the given branch to the given repo, and optionally set it as the root branch.
pushGitBranch :: forall e. WriteGitRepo -> 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 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)), 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. -- | Get the set of user-defined terms-or-constructors that have the given type.
@ -106,28 +95,3 @@ data LocalOrRemote
= Local = Local
| Remote | Remote
deriving (Show, Eq, Ord) 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

View File

@ -929,7 +929,7 @@ nativeCompileCodes executable codes base path = do
BS.hPut pin . runPutS . putWord32be . fromIntegral $ BS.length bytes BS.hPut pin . runPutS . putWord32be . fromIntegral $ BS.length bytes
BS.hPut pin bytes BS.hPut pin bytes
UnliftIO.hClose pin UnliftIO.hClose pin
waitForProcess ph _ <- waitForProcess ph
pure () pure ()
callout _ _ _ _ = fail "withCreateProcess didn't provide handles" callout _ _ _ _ = fail "withCreateProcess didn't provide handles"
ucrError (e :: IOException) = ucrError (e :: IOException) =

View File

@ -142,11 +142,11 @@ link :: (Monad m, Var v) => TermP v m
link = termLink <|> typeLink link = termLink <|> typeLink
where where
typeLink = do typeLink = do
P.try (reserved "typeLink") -- type opens a block, gotta use something else _ <- P.try (reserved "typeLink") -- type opens a block, gotta use something else
tok <- typeLink' tok <- typeLink'
pure $ Term.typeLink (ann tok) (L.payload tok) pure $ Term.typeLink (ann tok) (L.payload tok)
termLink = do termLink = do
P.try (reserved "termLink") _ <- P.try (reserved "termLink")
tok <- termLink' tok <- termLink'
pure $ Term.termLink (ann tok) (L.payload tok) pure $ Term.termLink (ann tok) (L.payload tok)
@ -201,7 +201,7 @@ matchCase = do
unit ann = Pattern.Constructor ann (ConstructorReference DD.unitRef 0) [] unit ann = Pattern.Constructor ann (ConstructorReference DD.unitRef 0) []
pair p1 p2 = Pattern.Constructor (ann p1 <> ann p2) (ConstructorReference DD.pairRef 0) [p1, p2] pair p1 p2 = Pattern.Constructor (ann p1 <> ann p2) (ConstructorReference DD.pairRef 0) [p1, p2]
let guardedBlocks = label "pattern guard" . some $ do let guardedBlocks = label "pattern guard" . some $ do
reserved "|" _ <- reserved "|"
guard <- guard <-
asum asum
[ Nothing <$ P.try (quasikeyword "otherwise"), [ Nothing <$ P.try (quasikeyword "otherwise"),
@ -290,7 +290,7 @@ parsePattern = label "pattern" root
| Set.null s -> die tok s | Set.null s -> die tok s
| Set.size s > 1 -> die tok s | Set.size s > 1 -> die tok s
| otherwise -> -- matched ctor name, consume the token | otherwise -> -- matched ctor name, consume the token
do anyToken; pure (Set.findMin s <$ tok) do _ <- anyToken; pure (Set.findMin s <$ tok)
where where
isLower = Text.all Char.isLower . Text.take 1 . Name.toText isLower = Text.all Char.isLower . Text.take 1 . Name.toText
die hq s = case L.payload hq of die hq s = case L.payload hq of
@ -1058,7 +1058,7 @@ destructuringBind = do
(p, boundVars) <- P.try do (p, boundVars) <- P.try do
(p, boundVars) <- parsePattern (p, boundVars) <- parsePattern
let boundVars' = snd <$> boundVars let boundVars' = snd <$> boundVars
P.lookAhead (openBlockWith "=") _ <- P.lookAhead (openBlockWith "=")
pure (p, boundVars') pure (p, boundVars')
(_spanAnn, scrute) <- block "=" -- Dwight K. Scrute ("The People's Scrutinee") (_spanAnn, scrute) <- block "=" -- Dwight K. Scrute ("The People's Scrutinee")
let guard = Nothing let guard = Nothing

View File

@ -2197,7 +2197,7 @@ coalesceWanted' keep ((loc, n) : new) old
if keep u if keep u
then pure (new, (loc, n) : old) then pure (new, (loc, n) : old)
else do else do
defaultAbility n _ <- defaultAbility n
pure (new, old) pure (new, old)
coalesceWanted new old coalesceWanted new old
| otherwise = coalesceWanted' keep new ((loc, n) : old) | otherwise = coalesceWanted' keep new ((loc, n) : old)

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

View File

@ -1,143 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- | A utility type for saving memory in the presence of many duplicate ByteStrings, etc. If you have data that may be
-- a redundant duplicate, try pinning it to a pin board, and use the result of that operation instead.
--
-- Without a pin board:
--
-- x ───── "38dce848c8c829c62"
-- y ───── "38dce848c8c829c62"
-- z ───── "d2518f260535b927b"
--
-- With a pin board:
--
-- x ───── "38dce848c8c829c62" ┄┄┄┄┄┐
-- y ────────┘ board
-- z ───── "d2518f260535b927b" ┄┄┄┄┄┘
--
-- ... and after x is garbage collected:
--
-- "38dce848c8c829c62" ┄┄┄┄┄┐
-- y ────────┘ board
-- z ───── "d2518f260535b927b" ┄┄┄┄┄┘
--
-- ... and after y is garbage collected:
--
-- board
-- z ───── "d2518f260535b927b" ┄┄┄┄┄┘
module Unison.Util.PinBoard
( PinBoard,
new,
pin,
-- * For debugging
debugDump,
debugSize,
)
where
import Control.Concurrent.MVar
import Data.Foldable (find, foldlM)
import Data.Functor.Compose
import Data.Hashable (Hashable, hash)
import Data.IntMap qualified as IntMap
import Data.IntMap.Strict (IntMap)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Tuple (swap)
import System.Mem.Weak (Weak, deRefWeak, mkWeakPtr)
import Unison.Prelude
-- | A "pin board" is a place to pin values; semantically, it's a set, but differs in a few ways:
--
-- * Pinned values aren't kept alive by the pin board, they might be garbage collected at any time.
-- * If you try to pin a value that's already pinned (per its Eq instance), the pinned one will be returned
-- instead.
-- * It has a small API: just 'new' and 'pin'.
newtype PinBoard a
= PinBoard (MVar (IntMap (Bucket a)))
new :: (MonadIO m) => m (PinBoard a)
new =
liftIO (PinBoard <$> newMVar IntMap.empty)
pin :: forall a m. (Eq a, Hashable a, MonadIO m) => PinBoard a -> a -> m a
pin (PinBoard boardVar) x = liftIO do
modifyMVar boardVar \board ->
swap <$> getCompose (IntMap.alterF alter n board)
where
-- Pin to pin board at a hash key: either there's nothing there (ifMiss), or there's a nonempty bucket (ifHit).
alter :: Maybe (Bucket a) -> Compose IO ((,) a) (Maybe (Bucket a))
alter =
Compose . maybe ifMiss ifHit
-- Pin a new value: create a new singleton bucket.
ifMiss :: IO (a, Maybe (Bucket a))
ifMiss =
(x,) . Just <$> newBucket x finalizer
-- Possibly pin a new value: if it already exists in the bucket, return that one instead. Otherwise, insert it.
ifHit :: Bucket a -> IO (a, Maybe (Bucket a))
ifHit bucket =
bucketFind bucket x >>= \case
-- Hash collision: the bucket has things in it, but none are the given value. Insert.
Nothing -> (x,) . Just <$> bucketAdd bucket x finalizer
-- The thing being inserted already exists; return it.
Just y -> pure (y, Just bucket)
-- When each thing pinned here is garbage collected, compact its bucket.
finalizer :: IO ()
finalizer =
modifyMVar_ boardVar (IntMap.alterF (maybe (pure Nothing) bucketCompact) n)
n :: Int
n =
hash x
debugDump :: (MonadIO m) => (a -> Text) -> PinBoard a -> m ()
debugDump f (PinBoard boardVar) = liftIO do
board <- readMVar boardVar
contents <- (traverse . traverse) bucketToList (IntMap.toList board)
Text.putStrLn (Text.unlines ("PinBoard" : map row contents))
where
row (n, xs) =
Text.pack (show n) <> " => " <> Text.pack (show (map f xs))
debugSize :: PinBoard a -> IO Int
debugSize (PinBoard boardVar) = do
board <- readMVar boardVar
foldlM step 0 board
where
step :: Int -> Bucket a -> IO Int
step acc =
bucketToList >=> \xs -> pure (acc + length xs)
-- | A bucket of weak pointers to different values that all share a hash.
newtype Bucket a
= Bucket [Weak a] -- Invariant: non-empty list
-- | A singleton bucket.
newBucket :: a -> IO () -> IO (Bucket a)
newBucket =
bucketAdd (Bucket [])
-- | Add a value to a bucket.
bucketAdd :: Bucket a -> a -> IO () -> IO (Bucket a)
bucketAdd (Bucket weaks) x finalizer = do
weak <- mkWeakPtr x (Just finalizer)
pure (Bucket (weak : weaks))
-- | Drop all garbage-collected values from a bucket. If none remain, returns Nothing.
bucketCompact :: Bucket a -> IO (Maybe (Bucket a))
bucketCompact (Bucket weaks) =
bucketFromList <$> mapMaybeM (\w -> (w <$) <$> deRefWeak w) weaks
-- | Look up a value in a bucket per its Eq instance.
bucketFind :: (Eq a) => Bucket a -> a -> IO (Maybe a)
bucketFind bucket x =
find (== x) <$> bucketToList bucket
bucketFromList :: [Weak a] -> Maybe (Bucket a)
bucketFromList = \case
[] -> Nothing
weaks -> Just (Bucket weaks)
bucketToList :: Bucket a -> IO [a]
bucketToList (Bucket weaks) =
mapMaybeM deRefWeak weaks

View File

@ -26,7 +26,6 @@ import Unison.Test.Typechecker qualified as Typechecker
import Unison.Test.Typechecker.Context qualified as Context import Unison.Test.Typechecker.Context qualified as Context
import Unison.Test.Typechecker.TypeError qualified as TypeError import Unison.Test.Typechecker.TypeError qualified as TypeError
import Unison.Test.UnisonSources qualified as UnisonSources import Unison.Test.UnisonSources qualified as UnisonSources
import Unison.Test.Util.PinBoard qualified as PinBoard
import Unison.Test.Util.Relation qualified as Relation import Unison.Test.Util.Relation qualified as Relation
import Unison.Test.Util.Text qualified as Text import Unison.Test.Util.Text qualified as Text
import Unison.Test.Var qualified as Var import Unison.Test.Var qualified as Var
@ -54,7 +53,6 @@ test =
Typechecker.test, Typechecker.test,
Context.test, Context.test,
Name.test, Name.test,
PinBoard.test,
CodebaseInit.test, CodebaseInit.test,
Branch.test Branch.test
] ]

View File

@ -44,7 +44,7 @@ testEval0 :: [(Reference, SuperGroup Symbol)] -> SuperGroup Symbol -> Test ()
testEval0 env main = testEval0 env main =
ok << io do ok << io do
cc <- baseCCache False cc <- baseCCache False
cacheAdd ((mainRef, main) : env) cc _ <- cacheAdd ((mainRef, main) : env) cc
rtm <- readTVarIO (refTm cc) rtm <- readTVarIO (refTm cc)
apply0 Nothing cc Nothing (rtm Map.! mainRef) apply0 Nothing cc Nothing (rtm Map.! mainRef)
where where

View File

@ -1,52 +0,0 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
module Unison.Test.Util.PinBoard
( test,
)
where
import Data.ByteString qualified as ByteString
import EasyTest
import GHC.Exts (isTrue#, reallyUnsafePtrEquality#, touch#)
import GHC.IO (IO (IO))
import System.Mem (performGC)
import Unison.Util.PinBoard qualified as PinBoard
test :: Test ()
test =
scope "util.pinboard" . tests $
[ scope "pinning equal values stores only one" $ do
let b0 = ByteString.singleton 0
let b1 = ByteString.copy b0
board <- PinBoard.new
-- pinning a thing for the first time returns it
b0' <- PinBoard.pin board b0
expectSamePointer b0 b0'
-- pinning an equal thing returns the first
b1' <- PinBoard.pin board b1
expectSamePointer b0 b1'
-- the board should only have one value in it
expect' . (== 1) <$> io (PinBoard.debugSize board)
-- keep b0 alive until here
touch b0
-- observe that the board doesn't keep its value alive
io performGC
expect' . (== 0) <$> io (PinBoard.debugSize board)
ok
]
expectSamePointer :: a -> a -> Test ()
expectSamePointer x y =
expect' (isTrue# (reallyUnsafePtrEquality# x y))
touch :: a -> Test ()
touch x =
io (IO \s -> (# touch# x s, () #))

View File

@ -1,6 +1,6 @@
cabal-version: 1.12 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 -- see: https://github.com/sol/hpack
@ -47,11 +47,9 @@ library
Unison.Codebase.CodeLookup Unison.Codebase.CodeLookup
Unison.Codebase.CodeLookup.Util Unison.Codebase.CodeLookup.Util
Unison.Codebase.Editor.DisplayObject Unison.Codebase.Editor.DisplayObject
Unison.Codebase.Editor.Git
Unison.Codebase.Editor.RemoteRepo Unison.Codebase.Editor.RemoteRepo
Unison.Codebase.Execute Unison.Codebase.Execute
Unison.Codebase.FileCodebase Unison.Codebase.FileCodebase
Unison.Codebase.GitError
Unison.Codebase.Init Unison.Codebase.Init
Unison.Codebase.Init.CreateCodebaseError Unison.Codebase.Init.CreateCodebaseError
Unison.Codebase.Init.OpenCodebaseError Unison.Codebase.Init.OpenCodebaseError
@ -71,7 +69,6 @@ library
Unison.Codebase.SqliteCodebase.Branch.Cache Unison.Codebase.SqliteCodebase.Branch.Cache
Unison.Codebase.SqliteCodebase.Branch.Dependencies Unison.Codebase.SqliteCodebase.Branch.Dependencies
Unison.Codebase.SqliteCodebase.Conversions Unison.Codebase.SqliteCodebase.Conversions
Unison.Codebase.SqliteCodebase.GitError
Unison.Codebase.SqliteCodebase.Migrations Unison.Codebase.SqliteCodebase.Migrations
Unison.Codebase.SqliteCodebase.Migrations.Helpers Unison.Codebase.SqliteCodebase.Migrations.Helpers
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12
@ -178,14 +175,12 @@ library
Unison.UnisonFile.Names Unison.UnisonFile.Names
Unison.UnisonFile.Summary Unison.UnisonFile.Summary
Unison.UnisonFile.Type Unison.UnisonFile.Type
Unison.Util.Convert
Unison.Util.CycleTable Unison.Util.CycleTable
Unison.Util.CyclicEq Unison.Util.CyclicEq
Unison.Util.CyclicOrd Unison.Util.CyclicOrd
Unison.Util.EnumContainers Unison.Util.EnumContainers
Unison.Util.Exception Unison.Util.Exception
Unison.Util.Logger Unison.Util.Logger
Unison.Util.PinBoard
Unison.Util.Pretty.MegaParsec Unison.Util.Pretty.MegaParsec
Unison.Util.RefPromise Unison.Util.RefPromise
Unison.Util.Star2 Unison.Util.Star2
@ -385,7 +380,6 @@ test-suite parser-typechecker-tests
Unison.Test.Typechecker.Context Unison.Test.Typechecker.Context
Unison.Test.Typechecker.TypeError Unison.Test.Typechecker.TypeError
Unison.Test.UnisonSources Unison.Test.UnisonSources
Unison.Test.Util.PinBoard
Unison.Test.Util.Pretty Unison.Test.Util.Pretty
Unison.Test.Util.Relation Unison.Test.Util.Relation
Unison.Test.Util.Text Unison.Test.Util.Text

View File

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

View File

@ -4,8 +4,6 @@
module Unison.Cli.DownloadUtils module Unison.Cli.DownloadUtils
( downloadProjectBranchFromShare, ( downloadProjectBranchFromShare,
downloadLooseCodeFromShare, downloadLooseCodeFromShare,
GitNamespaceHistoryTreatment (..),
downloadLooseCodeFromGitRepo,
) )
where where
@ -18,27 +16,19 @@ import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli) import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli import Unison.Cli.Monad qualified as Cli
import Unison.Cli.Share.Projects qualified as Share 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.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver)
import Unison.Codebase.Editor.Output qualified as Output 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.Editor.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Path qualified as Path 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.Core.Project (ProjectAndBranch (..))
import Unison.NameSegment.Internal qualified as NameSegment import Unison.NameSegment.Internal qualified as NameSegment
import Unison.Parser.Ann (Ann)
import Unison.Prelude import Unison.Prelude
import Unison.Share.API.Hash qualified as Share import Unison.Share.API.Hash qualified as Share
import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Codeserver qualified as Codeserver
import Unison.Share.Sync qualified as Share import Unison.Share.Sync qualified as Share
import Unison.Share.Sync.Types qualified as Share import Unison.Share.Sync.Types qualified as Share
import Unison.Share.Types (codeserverBaseURL) import Unison.Share.Types (codeserverBaseURL)
import Unison.Symbol (Symbol)
import Unison.Sync.Common qualified as Sync.Common import Unison.Sync.Common qualified as Sync.Common
import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Share
@ -113,26 +103,3 @@ withEntitiesDownloadedProgressCallback action = do
<> tShow entitiesDownloaded <> tShow entitiesDownloaded
<> " entities...\n\n" <> " entities...\n\n"
action ((\n -> atomically (modifyTVar' entitiesDownloadedVar (+ n))), readTVarIO entitiesDownloadedVar) 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)

View File

@ -0,0 +1,31 @@
-- | Common types related to merge, pulled down far enough to be imported by all interested parties.
module Unison.Cli.MergeTypes
( MergeSource (..),
MergeTarget,
MergeSourceAndTarget (..),
MergeSourceOrTarget (..),
)
where
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode)
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
-- | What are we merging in?
data MergeSource
= MergeSource'LocalProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName)
| MergeSource'RemoteProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName)
| MergeSource'RemoteLooseCode !ReadShareLooseCode
type MergeTarget =
ProjectAndBranch ProjectName ProjectBranchName
-- | "Alice and Bob"
data MergeSourceAndTarget = MergeSourceAndTarget
{ alice :: !MergeTarget,
bob :: !MergeSource
}
-- | "Either Alice Bob"
data MergeSourceOrTarget
= MergeSourceOrTarget'Source !MergeSource
| MergeSourceOrTarget'Target !MergeTarget

View File

@ -67,9 +67,6 @@ module Unison.Cli.MonadUtils
-- ** Getting patches -- ** Getting patches
getPatchAt, getPatchAt,
getMaybePatchAt,
expectPatchAt,
assertNoPatchAt,
-- * Latest touched Unison file -- * Latest touched Unison file
getLatestFile, getLatestFile,
@ -514,16 +511,6 @@ getMaybePatchAt path0 = do
branch <- getBranch0At path branch <- getBranch0At path
liftIO (Branch.getMaybePatch name branch) 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 -- Latest (typechecked) unison file utils

View File

@ -19,13 +19,14 @@ module Unison.Cli.Pretty
prettyLabeledDependencies, prettyLabeledDependencies,
prettyPath, prettyPath,
prettyPath', prettyPath',
prettyMergeSource,
prettyMergeSourceOrTarget,
prettyProjectAndBranchName, prettyProjectAndBranchName,
prettyBranchName, prettyBranchName,
prettyProjectBranchName, prettyProjectBranchName,
prettyProjectName, prettyProjectName,
prettyProjectNameSlash, prettyProjectNameSlash,
prettyNamespaceKey, prettyNamespaceKey,
prettyReadGitRepo,
prettyReadRemoteNamespace, prettyReadRemoteNamespace,
prettyReadRemoteNamespaceWith, prettyReadRemoteNamespaceWith,
prettyRelative, prettyRelative,
@ -35,6 +36,7 @@ module Unison.Cli.Pretty
prettySemver, prettySemver,
prettyShareLink, prettyShareLink,
prettySharePath, prettySharePath,
prettyShareURI,
prettySlashProjectBranchName, prettySlashProjectBranchName,
prettyTermName, prettyTermName,
prettyTypeName, prettyTypeName,
@ -43,7 +45,6 @@ module Unison.Cli.Pretty
prettyURI, prettyURI,
prettyUnisonFile, prettyUnisonFile,
prettyWhichBranchEmpty, prettyWhichBranchEmpty,
prettyWriteGitRepo,
prettyWriteRemoteNamespace, prettyWriteRemoteNamespace,
shareOrigin, shareOrigin,
unsafePrettyTermResultSigFull', unsafePrettyTermResultSigFull',
@ -69,16 +70,15 @@ import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Util.Base32Hex (Base32Hex) import U.Util.Base32Hex (Base32Hex)
import U.Util.Base32Hex qualified as Base32Hex import U.Util.Base32Hex qualified as Base32Hex
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..))
import Unison.Cli.ProjectUtils (projectBranchPathPrism) import Unison.Cli.ProjectUtils (projectBranchPathPrism)
import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Cli.Share.Projects.Types qualified as Share
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject)) import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.RemoteRepo
( ReadGitRepo, ( ReadRemoteNamespace (..),
ReadRemoteNamespace,
ShareUserHandle (..), ShareUserHandle (..),
WriteGitRepo,
WriteRemoteNamespace (..), WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..), WriteShareRemoteNamespace (..),
shareUserHandleToText, shareUserHandleToText,
@ -137,6 +137,11 @@ type Pretty = P.Pretty P.ColorText
prettyURI :: URI -> Pretty prettyURI :: URI -> Pretty
prettyURI = P.bold . P.blue . P.shown 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 :: ReadRemoteNamespace Share.RemoteProjectBranch -> Pretty
prettyReadRemoteNamespace = prettyReadRemoteNamespace =
prettyReadRemoteNamespaceWith \remoteProjectBranch -> prettyReadRemoteNamespaceWith \remoteProjectBranch ->
@ -225,6 +230,17 @@ prettyHash = prettyBase32Hex# . Hash.toBase32Hex
prettyHash32 :: (IsString s) => Hash32 -> P.Pretty s prettyHash32 :: (IsString s) => Hash32 -> P.Pretty s
prettyHash32 = prettyBase32Hex# . Hash32.toBase32Hex prettyHash32 = prettyBase32Hex# . Hash32.toBase32Hex
prettyMergeSource :: MergeSource -> Pretty
prettyMergeSource = \case
MergeSource'LocalProjectBranch branch -> prettyProjectAndBranchName branch
MergeSource'RemoteProjectBranch branch -> "remote " <> prettyProjectAndBranchName branch
MergeSource'RemoteLooseCode info -> prettyReadRemoteNamespace (ReadShare'LooseCode info)
prettyMergeSourceOrTarget :: MergeSourceOrTarget -> Pretty
prettyMergeSourceOrTarget = \case
MergeSourceOrTarget'Target alice -> prettyProjectAndBranchName alice
MergeSourceOrTarget'Source bob -> prettyMergeSource bob
prettyProjectName :: ProjectName -> Pretty prettyProjectName :: ProjectName -> Pretty
prettyProjectName = prettyProjectName =
P.green . P.text . into @Text P.green . P.text . into @Text
@ -327,18 +343,6 @@ prettyTypeName ppe r =
P.syntaxToColor $ P.syntaxToColor $
prettyHashQualified (PPE.typeName ppe r) 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'. -- | Pretty-print a 'WhichBranchEmpty'.
prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty
prettyWhichBranchEmpty = \case prettyWhichBranchEmpty = \case
@ -346,8 +350,8 @@ prettyWhichBranchEmpty = \case
WhichBranchEmptyPath path -> prettyPath' path WhichBranchEmptyPath path -> prettyPath' path
-- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef -- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef
displayBranchHash :: CausalHash -> String displayBranchHash :: CausalHash -> Text
displayBranchHash = ("#" <>) . Text.unpack . Hash.toBase32HexText . unCausalHash displayBranchHash = ("#" <>) . Hash.toBase32HexText . unCausalHash
prettyHumanReadableTime :: UTCTime -> UTCTime -> Pretty prettyHumanReadableTime :: UTCTime -> UTCTime -> Pretty
prettyHumanReadableTime now time = prettyHumanReadableTime now time =
@ -379,15 +383,15 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) =
-- Special-case Unison Share since we know its project branch URLs -- Special-case Unison Share since we know its project branch URLs
if URI.uriToString id host "" == "https://api.unison-lang.org" if URI.uriToString id host "" == "https://api.unison-lang.org"
then then
P.hiBlack . P.text $ P.group $
"https://share.unison-lang.org/" "https://share.unison-lang.org/"
<> into @Text remoteProject <> prettyProjectName remoteProject
<> "/code/" <> "/code/"
<> into @Text remoteBranch <> prettyProjectBranchName remoteBranch
else else
prettyProjectAndBranchName (ProjectAndBranch remoteProject remoteBranch) prettyProjectAndBranchName (ProjectAndBranch remoteProject remoteBranch)
<> " on " <> " on "
<> P.hiBlack (P.shown host) <> P.shown host
stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path
stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism

View File

@ -25,6 +25,7 @@ module Unison.Cli.ProjectUtils
getProjectAndBranchByTheseNames, getProjectAndBranchByTheseNames,
expectProjectAndBranchByTheseNames, expectProjectAndBranchByTheseNames,
expectLooseCodeOrProjectBranch, expectLooseCodeOrProjectBranch,
getProjectBranchCausalHash,
-- * Loading remote project info -- * Loading remote project info
expectRemoteProjectById, expectRemoteProjectById,
@ -36,9 +37,17 @@ module Unison.Cli.ProjectUtils
expectRemoteProjectBranchByNames, expectRemoteProjectBranchByNames,
expectRemoteProjectBranchByTheseNames, expectRemoteProjectBranchByTheseNames,
-- * Projecting out common things
justTheIds,
justTheIds',
justTheNames,
-- * Other helpers -- * Other helpers
findTemporaryBranchName, findTemporaryBranchName,
expectLatestReleaseBranchName, expectLatestReleaseBranchName,
-- * Upgrade branch utils
getUpgradeBranchParent,
) )
where where
@ -46,7 +55,10 @@ import Control.Lens
import Data.List qualified as List import Data.List qualified as List
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.These (These (..)) import Data.These (These (..))
import U.Codebase.Causal qualified
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
@ -56,6 +68,7 @@ import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.Share.Projects (IncludeSquashedHead) import Unison.Cli.Share.Projects (IncludeSquashedHead)
import Unison.Cli.Share.Projects qualified as Share import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Input (LooseCodeOrProject) import Unison.Codebase.Editor.Input (LooseCodeOrProject)
import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist)) import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist))
import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Output qualified as Output
@ -104,6 +117,18 @@ resolveBranchRelativePath = \case
Left branchName -> That branchName Left branchName -> That branchName
Right (projectName, branchName) -> These projectName branchName Right (projectName, branchName) -> These projectName branchName
justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId
justTheIds x =
ProjectAndBranch x.project.projectId x.branch.branchId
justTheIds' :: Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId
justTheIds' x =
ProjectAndBranch x.projectId x.branchId
justTheNames :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectName ProjectBranchName
justTheNames x =
ProjectAndBranch x.project.name x.branch.name
-- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name -- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name
-- like @preferred@. -- like @preferred@.
findTemporaryBranchName :: ProjectId -> ProjectBranchName -> Transaction ProjectBranchName findTemporaryBranchName :: ProjectId -> ProjectBranchName -> Transaction ProjectBranchName
@ -264,6 +289,13 @@ expectLooseCodeOrProjectBranch =
That (ProjectAndBranch (Just project) branch) -> Right (These project branch) That (ProjectAndBranch (Just project) branch) -> Right (These project branch)
These path _ -> Left path -- (3) above These path _ -> Left path -- (3) above
-- | Get the causal hash of a project branch.
getProjectBranchCausalHash :: ProjectAndBranch ProjectId ProjectBranchId -> Transaction CausalHash
getProjectBranchCausalHash branch = do
let path = projectBranchPath branch
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)
pure causal.causalHash
------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------
-- Remote project utils -- Remote project utils
@ -374,3 +406,14 @@ expectLatestReleaseBranchName remoteProject =
case remoteProject.latestRelease of case remoteProject.latestRelease of
Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases remoteProject.projectName) Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases remoteProject.projectName)
Just semver -> pure (UnsafeProjectBranchName ("releases/" <> into @Text semver)) Just semver -> pure (UnsafeProjectBranchName ("releases/" <> into @Text semver))
-- | @getUpgradeBranchParent branch@ returns the parent branch of an "upgrade" branch.
--
-- When an upgrade fails, we put you on a branch called `upgrade-<old>-to-<new>`. That's an "upgrade" branch. It's not
-- currently distinguished in the database, so we first just switch on whether its name begins with "upgrade-". If it
-- does, then we get the branch's parent, which should exist, but perhaps wouldn't if the user had manually made a
-- parentless branch called "upgrade-whatever" for whatever reason.
getUpgradeBranchParent :: Sqlite.ProjectBranch -> Maybe ProjectBranchId
getUpgradeBranchParent branch = do
guard ("upgrade-" `Text.isPrefixOf` into @Text branch.name)
branch.parentBranchId

View File

@ -1,7 +1,6 @@
-- | @.unisonConfig@ file utilities -- | @.unisonConfig@ file utilities
module Unison.Cli.UnisonConfigUtils module Unison.Cli.UnisonConfigUtils
( gitUrlKey, ( remoteMappingKey,
remoteMappingKey,
resolveConfiguredUrl, resolveConfiguredUrl,
) )
where where
@ -33,9 +32,6 @@ configKey k p =
NameSegment.toEscapedText NameSegment.toEscapedText
(Path.toSeq $ Path.unabsolute p) (Path.toSeq $ Path.unabsolute p)
gitUrlKey :: Path.Absolute -> Text
gitUrlKey = configKey "GitUrl"
remoteMappingKey :: Path.Absolute -> Text remoteMappingKey :: Path.Absolute -> Text
remoteMappingKey = configKey "RemoteMapping" remoteMappingKey = configKey "RemoteMapping"
@ -46,13 +42,7 @@ resolveConfiguredUrl :: PushPull -> Path' -> Cli (WriteRemoteNamespace Void)
resolveConfiguredUrl pushPull destPath' = do resolveConfiguredUrl pushPull destPath' = do
destPath <- Cli.resolvePath' destPath' destPath <- Cli.resolvePath' destPath'
whenNothingM (remoteMappingForPath pushPull destPath) do whenNothingM (remoteMappingForPath pushPull destPath) do
let gitUrlConfigKey = gitUrlKey destPath Cli.returnEarly (NoConfiguredRemoteMapping pushPull 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)
-- | Tries to look up a remote mapping for a given path. -- | 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 -- Will also resolve paths relative to any mapping which is configured for a parent of that

View File

@ -5,6 +5,7 @@ module Unison.Codebase.Editor.HandleInput (loop) where
-- TODO: Don't import backend -- TODO: Don't import backend
import Control.Arrow ((&&&))
import Control.Error.Util qualified as ErrorUtil import Control.Error.Util qualified as ErrorUtil
import Control.Lens hiding (from) import Control.Lens hiding (from)
import Control.Monad.Reader (ask) 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.Branch.Diff qualified as V2Branch.Diff
import U.Codebase.Causal qualified as V2Causal import U.Codebase.Causal qualified as V2Causal
import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Reference qualified as V2 (Reference)
import U.Codebase.Reflog qualified as Reflog import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
@ -57,6 +57,7 @@ import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin)
import Unison.Codebase.Editor.HandleInput.Branch (handleBranch) import Unison.Codebase.Editor.HandleInput.Branch (handleBranch)
import Unison.Codebase.Editor.HandleInput.BranchRename (handleBranchRename) import Unison.Codebase.Editor.HandleInput.BranchRename (handleBranchRename)
import Unison.Codebase.Editor.HandleInput.Branches (handleBranches) import Unison.Codebase.Editor.HandleInput.Branches (handleBranches)
import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade)
import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition
import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges
import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch) import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch)
@ -78,8 +79,8 @@ import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename) import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename)
import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch) import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
import Unison.Codebase.Editor.HandleInput.Projects (handleProjects) import Unison.Codebase.Editor.HandleInput.Projects (handleProjects)
import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch, propagatePatch) import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch)
import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch) import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch)
import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft) import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft)
import Unison.Codebase.Editor.HandleInput.Run (handleRun) import Unison.Codebase.Editor.HandleInput.Run (handleRun)
import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils
@ -98,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.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Editor.Slurp qualified as Slurp import Unison.Codebase.Editor.Slurp qualified as Slurp
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult 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.Editor.TodoOutput qualified as TO
import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase) import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase)
import Unison.Codebase.Metadata qualified as Metadata import Unison.Codebase.Metadata qualified as Metadata
@ -106,15 +108,8 @@ import Unison.Codebase.Patch qualified as Patch
import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path (Path, Path' (..))
import Unison.Codebase.Path qualified as HQSplit' import Unison.Codebase.Path qualified as HQSplit'
import Unison.Codebase.Path qualified as Path 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.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash qualified as SCH 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.BranchRelativePath (BranchRelativePath)
import Unison.CommandLine.Completion qualified as Completion import Unison.CommandLine.Completion qualified as Completion
import Unison.CommandLine.DisplayValues qualified as DisplayValues import Unison.CommandLine.DisplayValues qualified as DisplayValues
@ -132,7 +127,6 @@ import Unison.LabeledDependency qualified as LD
import Unison.LabeledDependency qualified as LabeledDependency import Unison.LabeledDependency qualified as LabeledDependency
import Unison.Name (Name) import Unison.Name (Name)
import Unison.Name qualified as Name import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment import Unison.NameSegment qualified as NameSegment
import Unison.Names (Names (Names)) import Unison.Names (Names (Names))
import Unison.Names qualified as Names import Unison.Names qualified as Names
@ -148,18 +142,16 @@ import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED
import Unison.Project (ProjectAndBranch (..)) import Unison.Project (ProjectAndBranch (..))
import Unison.Project.Util (projectContextFromPath) import Unison.Project.Util (projectContextFromPath)
import Unison.Reference (Reference, TermReference) import Unison.Reference (Reference)
import Unison.Reference qualified as Reference import Unison.Reference qualified as Reference
import Unison.Referent (Referent) import Unison.Referent (Referent)
import Unison.Referent qualified as Referent import Unison.Referent qualified as Referent
import Unison.Runtime.IOSource qualified as IOSource import Unison.Runtime.IOSource qualified as IOSource
import Unison.Server.Backend (ShallowListEntry (..))
import Unison.Server.Backend qualified as Backend import Unison.Server.Backend qualified as Backend
import Unison.Server.CodebaseServer qualified as Server import Unison.Server.CodebaseServer qualified as Server
import Unison.Server.Doc.Markdown.Render qualified as Md import Unison.Server.Doc.Markdown.Render qualified as Md
import Unison.Server.Doc.Markdown.Types qualified as Md import Unison.Server.Doc.Markdown.Types qualified as Md
import Unison.Server.NameSearch.FromNames qualified as NameSearch import Unison.Server.NameSearch.FromNames qualified as NameSearch
import Unison.Server.QueryResult
import Unison.Server.SearchResult (SearchResult) import Unison.Server.SearchResult (SearchResult)
import Unison.Server.SearchResult qualified as SR import Unison.Server.SearchResult qualified as SR
import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Codeserver qualified as Codeserver
@ -201,73 +193,13 @@ import UnliftIO.Directory qualified as Directory
loop :: Either Event Input -> Cli () loop :: Either Event Input -> Cli ()
loop e = do loop e = do
case e of 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 Left (UnisonFileChanged sourceName text) -> Cli.time "UnisonFileChanged" do
-- We skip this update if it was programmatically generated -- We skip this update if it was programmatically generated
Cli.getLatestFile >>= \case Cli.getLatestFile >>= \case
Just (_, True) -> (#latestFile . _Just . _2) .= False Just (_, True) -> (#latestFile . _Just . _2) .= False
_ -> loadUnisonFile sourceName text _ -> loadUnisonFile sourceName text
Right input -> Right input ->
let typeReferences :: [SearchResult] -> [Reference] let previewResponse sourceName sr uf = do
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
names <- Cli.currentNames names <- Cli.currentNames
let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf names let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf names
filePPED <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile filePPED <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile
@ -290,19 +222,22 @@ loop e = do
Cli.respond $ PrintMessage pretty Cli.respond $ PrintMessage pretty
ShowReflogI -> do ShowReflogI -> do
let numEntriesToShow = 500 let numEntriesToShow = 500
entries <- (schLength, entries) <-
Cli.runTransaction do Cli.runTransaction $
schLength <- Codebase.branchHashLength (,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow
Codebase.getReflog numEntriesToShow <&> fmap (first $ SCH.fromHash schLength)
let moreEntriesToLoad = length entries == numEntriesToShow let moreEntriesToLoad = length entries == numEntriesToShow
let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad) 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.setNumberedArgs numberedEntries
Cli.respond $ ShowReflog expandedEntries Cli.respond $ ShowReflog shortEntries
where where
expandEntries :: expandEntries ::
([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool) -> ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool) ->
Maybe ((Maybe UTCTime, SCH.ShortCausalHash, Text), ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool)) Maybe ((Maybe UTCTime, CausalHash, Text), ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool))
expandEntries ([], Just expectedHash, moreEntriesToLoad) = expandEntries ([], Just expectedHash, moreEntriesToLoad) =
if moreEntriesToLoad if moreEntriesToLoad
then Nothing then Nothing
@ -435,8 +370,11 @@ loop e = do
let destp = looseCodeOrProjectToPath dest0 let destp = looseCodeOrProjectToPath dest0
srcb <- Cli.expectBranchAtPath' srcp srcb <- Cli.expectBranchAtPath' srcp
dest <- Cli.resolvePath' destp dest <- Cli.resolvePath' destp
-- todo: fixme: use project and branch names let err =
let err = Just $ MergeAlreadyUpToDate src0 dest0 Just $
MergeAlreadyUpToDate
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> src0)
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> dest0)
mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest
PreviewMergeLocalBranchI src0 dest0 -> do PreviewMergeLocalBranchI src0 dest0 -> do
Cli.Env {codebase} <- ask Cli.Env {codebase} <- ask
@ -467,27 +405,6 @@ loop e = do
hasConfirmed <- confirmedCommand input hasConfirmed <- confirmedCommand input
description <- inputDescription input description <- inputDescription input
doMoveBranch description hasConfirmed src' dest' 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 SwitchBranchI path' -> do
path <- Cli.resolvePath' path' path <- Cli.resolvePath' path'
branchExists <- Cli.branchExistsAtPath' path' branchExists <- Cli.branchExistsAtPath' path'
@ -539,11 +456,12 @@ loop e = do
DocToMarkdownI docName -> do DocToMarkdownI docName -> do
names <- Cli.currentNames names <- Cli.currentNames
pped <- Cli.prettyPrintEnvDeclFromNames names pped <- Cli.prettyPrintEnvDeclFromNames names
hqLength <- Cli.runTransaction Codebase.hashLength
let nameSearch = NameSearch.makeNameSearch hqLength names
Cli.Env {codebase, runtime} <- ask Cli.Env {codebase, runtime} <- ask
docRefs <- Cli.runTransaction do
hqLength <- Codebase.hashLength
let nameSearch = NameSearch.makeNameSearch hqLength names
Backend.docsForDefinitionName codebase nameSearch Names.IncludeSuffixes docName
mdText <- liftIO $ do mdText <- liftIO $ do
docRefs <- Backend.docsForDefinitionName codebase nameSearch Names.IncludeSuffixes docName
for docRefs \docRef -> do for docRefs \docRef -> do
Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef) Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef)
pure . Md.toText $ Md.toMarkdown doc pure . Md.toText $ Md.toMarkdown doc
@ -730,14 +648,6 @@ loop e = do
DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs 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'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'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 DeleteTarget'Namespace insistence Nothing -> do
hasConfirmed <- confirmedCommand input hasConfirmed <- confirmedCommand input
if hasConfirmed || insistence == Force if hasConfirmed || insistence == Force
@ -747,16 +657,15 @@ loop e = do
Cli.respond DeletedEverything Cli.respond DeletedEverything
else Cli.respond DeleteEverythingConfirmation else Cli.respond DeleteEverythingConfirmation
DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
branch <- Cli.expectBranchAtPath' (Path.unsplit' p) branch <- Cli.expectBranchAtPath (Path.unsplit p)
description <- inputDescription input description <- inputDescription input
absPath <- Cli.resolveSplit' p
let toDelete = let toDelete =
Names.prefix0 Names.prefix0
(Path.unsafeToName (Path.unsplit (Path.convert absPath))) (Path.unsafeToName (Path.unsplit (p)))
(Branch.toNames (Branch.head branch)) (Branch.toNames (Branch.head branch))
afterDelete <- do afterDelete <- do
rootNames <- Branch.toNames <$> Cli.getRootBranch0 names <- Cli.currentNames
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty rootNames) endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
case (null endangerments, insistence) of case (null endangerments, insistence) of
(True, _) -> pure (Cli.respond Success) (True, _) -> pure (Cli.respond Success)
(False, Force) -> do (False, Force) -> do
@ -768,7 +677,7 @@ loop e = do
ppeDecl <- Cli.currentPrettyPrintEnvDecl ppeDecl <- Cli.currentPrettyPrintEnvDecl
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
Cli.returnEarlyWithoutOutput 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 -- We have to modify the parent in order to also wipe out the history at the
-- child. -- child.
Cli.updateAt description parentPathAbs \parentBranch -> Cli.updateAt description parentPathAbs \parentBranch ->
@ -781,21 +690,12 @@ loop e = do
traverse_ (displayI outputLoc) namesToDisplay traverse_ (displayI outputLoc) namesToDisplay
ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query
EditNamespaceI paths -> handleEditNamespace LatestFileLocation paths 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 FindShallowI pathArg -> do
Cli.Env {codebase} <- ask Cli.Env {codebase} <- ask
pathArgAbs <- Cli.resolvePath' pathArg pathArgAbs <- Cli.resolvePath' pathArg
entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs) entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
Cli.setNumberedArgs $ fmap entryToHQString entries Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
pped <- Cli.currentPrettyPrintEnvDecl pped <- Cli.currentPrettyPrintEnvDecl
let suffixifiedPPE = PPED.suffixifiedPPE pped let suffixifiedPPE = PPED.suffixifiedPPE pped
-- This used to be a delayed action which only forced the loading of the root -- This used to be a delayed action which only forced the loading of the root
@ -805,115 +705,9 @@ loop e = do
-- in an improvement, so perhaps it's not worth the effort. -- in an improvement, so perhaps it's not worth the effort.
let buildPPE = pure suffixifiedPPE let buildPPE = pure suffixifiedPPE
Cli.respond $ ListShallow buildPPE entries 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 FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input
StructuredFindI _fscope ws -> handleStructuredFindI ws StructuredFindI _fscope ws -> handleStructuredFindI ws
StructuredFindReplaceI ws -> handleStructuredFindReplaceI 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 LoadI maybePath -> handleLoad maybePath
ClearI -> Cli.respond ClearScreen ClearI -> Cli.respond ClearScreen
AddI requestedNames -> do AddI requestedNames -> do
@ -953,12 +747,6 @@ loop e = do
branchPath <- Cli.resolvePath' branchPath' branchPath <- Cli.resolvePath' branchPath'
doShowTodoOutput patch branchPath doShowTodoOutput patch branchPath
TestI testInput -> Tests.handleTest testInput 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 ExecuteI main args -> handleRun False main args
MakeStandaloneI output main -> doCompile False output main MakeStandaloneI output main -> doCompile False output main
CompileSchemeI output main -> CompileSchemeI output main ->
@ -1019,19 +807,15 @@ loop e = do
_ <- Cli.updateAtM description destPath \destb -> _ <- Cli.updateAtM description destPath \destb ->
liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
Cli.respond Success Cli.respond Success
ListEditsI maybePath -> do PullI sourceTarget pullMode -> handlePull sourceTarget pullMode
patch <- Cli.getPatchAt (fromMaybe Cli.defaultPatchPath maybePath)
pped <- Cli.currentPrettyPrintEnvDecl
let suffixifiedPPE = PPED.suffixifiedPPE pped
Cli.respondNumbered $ ListEdits patch suffixifiedPPE
PullRemoteBranchI sourceTarget pMode verbosity -> handlePull sourceTarget pMode verbosity
PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput
ListDependentsI hq -> handleDependents hq ListDependentsI hq -> handleDependents hq
ListDependenciesI hq -> handleDependencies hq ListDependenciesI hq -> handleDependencies hq
NamespaceDependenciesI path -> handleNamespaceDependencies path NamespaceDependenciesI path -> handleNamespaceDependencies path
DebugNumberedArgsI -> do DebugNumberedArgsI -> do
schLength <- Cli.runTransaction Codebase.branchHashLength
numArgs <- use #numberedArgs numArgs <- use #numberedArgs
Cli.respond (DumpNumberedArgs numArgs) Cli.respond (DumpNumberedArgs schLength numArgs)
DebugTypecheckedUnisonFileI -> do DebugTypecheckedUnisonFileI -> do
hqLength <- Cli.runTransaction Codebase.hashLength hqLength <- Cli.runTransaction Codebase.hashLength
uf <- Cli.expectLatestTypecheckedFile uf <- Cli.expectLatestTypecheckedFile
@ -1164,21 +948,12 @@ loop e = do
nameChanges <- V2Branch.Diff.allNameChanges Nothing treeDiff nameChanges <- V2Branch.Diff.allNameChanges Nothing treeDiff
pure (DisplayDebugNameDiff nameChanges) pure (DisplayDebugNameDiff nameChanges)
Cli.respond output 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
ShowDefinitionByPrefixI {} -> Cli.respond NotImplemented
UpdateBuiltinsI -> Cli.respond NotImplemented UpdateBuiltinsI -> Cli.respond NotImplemented
QuitI -> Cli.haltRepl QuitI -> Cli.haltRepl
GistI input -> handleGist input
AuthLoginI -> void $ authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver) AuthLoginI -> void $ authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver)
VersionI -> do VersionI -> do
Cli.Env {ucmVersion} <- ask Cli.Env {ucmVersion} <- ask
Cli.respond $ PrintVersion ucmVersion Cli.respond $ PrintVersion ucmVersion
DiffNamespaceToPatchI diffNamespaceToPatchInput -> do
description <- inputDescription input
handleDiffNamespaceToPatch description diffNamespaceToPatchInput
ProjectRenameI name -> handleProjectRename name ProjectRenameI name -> handleProjectRename name
ProjectSwitchI name -> projectSwitch name ProjectSwitchI name -> projectSwitch name
ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name
@ -1189,6 +964,7 @@ loop e = do
CloneI remoteNames localNames -> handleClone remoteNames localNames CloneI remoteNames localNames -> handleClone remoteNames localNames
ReleaseDraftI semver -> handleReleaseDraft semver ReleaseDraftI semver -> handleReleaseDraft semver
UpgradeI old new -> handleUpgrade old new UpgradeI old new -> handleUpgrade old new
UpgradeCommitI -> handleCommitUpgrade
LibInstallI libdep -> handleInstallLib libdep LibInstallI libdep -> handleInstallLib libdep
inputDescription :: Input -> Cli Text inputDescription :: Input -> Cli Text
@ -1249,14 +1025,6 @@ inputDescription input =
src <- p' src0 src <- p' src0
dest <- p' dest0 dest <- p' dest0
pure ("move " <> src <> " " <> dest) 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 DeleteI dtarget -> do
case dtarget of case dtarget of
DeleteTarget'TermOrType DeleteOutput'NoDiff things0 -> do DeleteTarget'TermOrType DeleteOutput'NoDiff things0 -> do
@ -1278,25 +1046,13 @@ inputDescription input =
thing <- traverse hqs' thing0 thing <- traverse hqs' thing0
pure ("delete.type.verbose " <> Text.intercalate " " thing) pure ("delete.type.verbose " <> Text.intercalate " " thing)
DeleteTarget'Namespace Try opath0 -> do DeleteTarget'Namespace Try opath0 -> do
opath <- ops' opath0 opath <- ops opath0
pure ("delete.namespace " <> opath) pure ("delete.namespace " <> opath)
DeleteTarget'Namespace Force opath0 -> do DeleteTarget'Namespace Force opath0 -> do
opath <- ops' opath0 opath <- ops opath0
pure ("delete.namespace.force " <> opath) pure ("delete.namespace.force " <> opath)
DeleteTarget'Patch path0 -> do
path <- ps' path0
pure ("delete.patch " <> path)
DeleteTarget'ProjectBranch _ -> wat DeleteTarget'ProjectBranch _ -> wat
DeleteTarget'Project _ -> 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" AddI _selection -> pure "add"
UpdateI p0 _selection -> do UpdateI p0 _selection -> do
p <- p <-
@ -1306,12 +1062,8 @@ inputDescription input =
UsePatch p0 -> (" " <>) <$> ps' p0 UsePatch p0 -> (" " <>) <$> ps' p0
pure ("update.old" <> p) pure ("update.old" <> p)
Update2I -> pure ("update") Update2I -> pure ("update")
PropagatePatchI p0 scope0 -> do
p <- ps' p0
scope <- p' scope0
pure ("patch " <> p <> " " <> scope)
UndoI {} -> pure "undo" 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) IOTestI hq -> pure ("io.test " <> HQ.toText hq)
IOTestAllI -> pure "io.test.all" IOTestAllI -> pure "io.test.all"
UpdateBuiltinsI -> pure "builtins.update" UpdateBuiltinsI -> pure "builtins.update"
@ -1321,20 +1073,9 @@ inputDescription input =
MergeIOBuiltinsI (Just path) -> ("builtins.mergeio " <>) <$> p path MergeIOBuiltinsI (Just path) -> ("builtins.mergeio " <>) <$> p path
MakeStandaloneI out nm -> pure ("compile " <> Text.pack out <> " " <> HQ.toText nm) MakeStandaloneI out nm -> pure ("compile " <> Text.pack out <> " " <> HQ.toText nm)
ExecuteSchemeI nm args -> 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) CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi)
CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name) 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" ClearI {} -> pure "clear"
DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name) DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name)
-- --
@ -1361,23 +1102,18 @@ inputDescription input =
DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input) DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input)
DebugFormatI -> pure "debug.format" DebugFormatI -> pure "debug.format"
DebugTypecheckedUnisonFileI {} -> wat DebugTypecheckedUnisonFileI {} -> wat
DeprecateTermI {} -> wat
DeprecateTypeI {} -> wat
DiffNamespaceI {} -> wat DiffNamespaceI {} -> wat
DisplayI {} -> wat DisplayI {} -> wat
DocsI {} -> wat DocsI {} -> wat
DocsToHtmlI {} -> wat DocsToHtmlI {} -> wat
FindI {} -> wat FindI {} -> wat
FindPatchI {} -> wat
FindShallowI {} -> wat FindShallowI {} -> wat
StructuredFindI {} -> wat StructuredFindI {} -> wat
StructuredFindReplaceI {} -> wat StructuredFindReplaceI {} -> wat
GistI {} -> wat
HistoryI {} -> wat HistoryI {} -> wat
LibInstallI {} -> wat LibInstallI {} -> wat
ListDependenciesI {} -> wat ListDependenciesI {} -> wat
ListDependentsI {} -> wat ListDependentsI {} -> wat
ListEditsI {} -> wat
LoadI {} -> wat LoadI {} -> wat
MergeI {} -> wat MergeI {} -> wat
NamesI {} -> wat NamesI {} -> wat
@ -1390,11 +1126,10 @@ inputDescription input =
ProjectRenameI {} -> wat ProjectRenameI {} -> wat
ProjectSwitchI {} -> wat ProjectSwitchI {} -> wat
ProjectsI -> wat ProjectsI -> wat
PullRemoteBranchI {} -> wat PullI {} -> wat
PushRemoteBranchI {} -> wat PushRemoteBranchI {} -> wat
QuitI {} -> wat QuitI {} -> wat
ReleaseDraftI {} -> wat ReleaseDraftI {} -> wat
ShowDefinitionByPrefixI {} -> wat
ShowDefinitionI {} -> wat ShowDefinitionI {} -> wat
EditNamespaceI paths -> EditNamespaceI paths ->
pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths)) pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths))
@ -1405,6 +1140,7 @@ inputDescription input =
UiI {} -> wat UiI {} -> wat
UpI {} -> wat UpI {} -> wat
UpgradeI {} -> wat UpgradeI {} -> wat
UpgradeCommitI {} -> wat
VersionI -> wat VersionI -> wat
where where
hp' :: Either SCH.ShortCausalHash Path' -> Cli Text hp' :: Either SCH.ShortCausalHash Path' -> Cli Text
@ -1415,10 +1151,8 @@ inputDescription input =
p' = fmap tShow . Cli.resolvePath' p' = fmap tShow . Cli.resolvePath'
brp :: BranchRelativePath -> Cli Text brp :: BranchRelativePath -> Cli Text
brp = fmap from . ProjectUtils.resolveBranchRelativePath brp = fmap from . ProjectUtils.resolveBranchRelativePath
ops' :: Maybe Path.Split' -> Cli Text ops :: Maybe Path.Split -> Cli Text
ops' = maybe (pure ".") ps' ops = maybe (pure ".") ps
opatch :: Maybe Path.Split' -> Cli Text
opatch = ps' . fromMaybe Cli.defaultPatchPath
wat = error $ show input ++ " is not expected to alter the branch" wat = error $ show input ++ " is not expected to alter the branch"
hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text
hhqs' = \case hhqs' = \case
@ -1430,6 +1164,7 @@ inputDescription input =
pure (p <> "." <> HQ'.toTextWith NameSegment.toEscapedText hq) pure (p <> "." <> HQ'.toTextWith NameSegment.toEscapedText hq)
hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq) hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq)
ps' = p' . Path.unsplit' ps' = p' . Path.unsplit'
ps = p . Path.unsplit
looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text
looseCodeOrProjectToText = \case looseCodeOrProjectToText = \case
This path -> p' path This path -> p' path
@ -1501,7 +1236,7 @@ handleFindI isVerbose fscope ws input = do
(mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs) (mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs)
pure $ uniqueBy SR.toReferent srs pure $ uniqueBy SR.toReferent srs
let respondResults results = do let respondResults results = do
Cli.setNumberedArgs $ fmap (searchResultToHQString searchRoot) results Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results
results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) results' <- Cli.runTransaction (Backend.loadSearchResults codebase results)
Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results' Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results'
results <- getResults names results <- getResults names
@ -1553,12 +1288,10 @@ handleDependencies hq = do
let types = [(PPE.typeName suffixifiedPPE r, r) | LabeledDependency.TypeReference r <- toList dependencies] let types = [(PPE.typeName suffixifiedPPE r, r) | LabeledDependency.TypeReference r <- toList dependencies]
let terms = [(PPE.termName suffixifiedPPE r, r) | LabeledDependency.TermReferent r <- toList dependencies] let terms = [(PPE.termName suffixifiedPPE r, r) | LabeledDependency.TermReferent r <- toList dependencies]
pure (types, terms) pure (types, terms)
let types = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ fst <$> results) let types = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) . join $ fst <$> results
let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results) let terms = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) . join $ snd <$> results
Cli.setNumberedArgs $ Cli.setNumberedArgs . map SA.HashQualified $ types <> terms
map (Text.unpack . Reference.toText . snd) types Cli.respond $ ListDependencies suffixifiedPPE lds types terms
<> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms
Cli.respond $ ListDependencies suffixifiedPPE lds (fst <$> types) (fst <$> terms)
handleDependents :: HQ.HashQualified Name -> Cli () handleDependents :: HQ.HashQualified Name -> Cli ()
handleDependents hq = do handleDependents hq = do
@ -1575,7 +1308,7 @@ handleDependents hq = do
results <- for (toList lds) \ld -> 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. -- The full set of dependent references, any number of which may not have names in the current namespace.
dependents <- dependents <-
let tp r = Codebase.dependents Queries.ExcludeOwnComponent r let tp = Codebase.dependents Queries.ExcludeOwnComponent
tm = \case tm = \case
Referent.Ref r -> Codebase.dependents Queries.ExcludeOwnComponent r Referent.Ref r -> Codebase.dependents Queries.ExcludeOwnComponent r
Referent.Con (ConstructorReference r _cid) _ct -> Referent.Con (ConstructorReference r _cid) _ct ->
@ -1591,78 +1324,11 @@ handleDependents hq = do
Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r
pure (isTerm, HQ'.toHQ shortName, r) pure (isTerm, HQ'.toHQ shortName, r)
pure results 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 types = sort [(n, r) | (False, n, r) <- join results]
let terms = sort [(n, r) | (True, 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.setNumberedArgs . map SA.HashQualified $ types <> terms
Cli.respond (ListDependents ppe lds (fst <$> types) (fst <$> terms)) Cli.respond (ListDependents ppe lds types 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))
-- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`.
handleShowDefinition :: OutputLocation -> ShowDefinitionScope -> NonEmpty (HQ.HashQualified Name) -> Cli () handleShowDefinition :: OutputLocation -> ShowDefinitionScope -> NonEmpty (HQ.HashQualified Name) -> Cli ()
@ -1774,10 +1440,9 @@ doShowTodoOutput patch scopePath = do
if TO.noConflicts todo && TO.noEdits todo if TO.noConflicts todo && TO.noEdits todo
then Cli.respond NoConflictsOrEdits then Cli.respond NoConflictsOrEdits
else do else do
Cli.setNumberedArgs Cli.setNumberedArgs $
( Text.unpack . Reference.toText . view _2 SA.HashQualified . HQ.HashOnly . Reference.toShortHash . view _2
<$> fst (TO.todoFrontierDependents todo) <$> fst (TO.todoFrontierDependents todo)
)
pped <- Cli.currentPrettyPrintEnvDecl pped <- Cli.currentPrettyPrintEnvDecl
Cli.respondNumbered $ TodoOutput pped todo Cli.respondNumbered $ TodoOutput pped todo
@ -1823,16 +1488,6 @@ confirmedCommand i = do
loopState <- State.get loopState <- State.get
pure $ Just i == (loopState ^. #lastInput) 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>...` -- return `name` and `name.<everything>...`
_searchBranchPrefix :: Branch m -> Name -> [SearchResult] _searchBranchPrefix :: Branch m -> Name -> [SearchResult]
_searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of _searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of
@ -2105,7 +1760,7 @@ displayI outputLoc hq = do
let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names
doDisplay outputLoc ns tm doDisplay outputLoc ns tm
docsI :: Path.HQSplit' -> Cli () docsI :: Name -> Cli ()
docsI src = do docsI src = do
findInScratchfileByName findInScratchfileByName
where where
@ -2113,14 +1768,8 @@ docsI src = do
(fileByName) First check the file for `foo.doc`, and if found do `display foo.doc` (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` (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.HashQualified Name
dotDoc = hq <&> \n -> Name.joinDot n (Name.fromSegment NameSegment.docSegment) dotDoc = Name.convert . Name.joinDot src $ Name.fromSegment NameSegment.docSegment
findInScratchfileByName :: Cli () findInScratchfileByName :: Cli ()
findInScratchfileByName = do findInScratchfileByName = do
@ -2210,15 +1859,6 @@ addWatch watchName (Just uf) = do
) )
_ -> addWatch watchName Nothing _ -> 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 :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path'
looseCodeOrProjectToPath = \case looseCodeOrProjectToPath = \case
Left pth -> pth Left pth -> pth

View File

@ -120,11 +120,10 @@ doCreateBranch createFrom project newBranchName description = do
Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId)) Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId))
CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath
CreateFrom'Nothingness -> pure Branch.empty CreateFrom'Nothingness -> pure Branch.empty
let projectId = project ^. #projectId
let parentBranchId = let parentBranchId =
case createFrom of case createFrom of
CreateFrom'Branch (ProjectAndBranch _ sourceBranch) CreateFrom'Branch (ProjectAndBranch _ sourceBranch)
| (sourceBranch ^. #projectId) == projectId -> Just (sourceBranch ^. #branchId) | sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId
_ -> Nothing _ -> Nothing
doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description

View File

@ -0,0 +1,50 @@
-- | @upgrade.commit@ handler.
module Unison.Codebase.Editor.HandleInput.CommitUpgrade
( handleCommitUpgrade,
)
where
import U.Codebase.Sqlite.Project qualified
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
import Unison.Codebase.Editor.HandleInput.ProjectSwitch qualified as ProjectSwitch
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Merge.TwoWay (TwoWay (..))
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..))
handleCommitUpgrade :: Cli ()
handleCommitUpgrade = do
(upgradeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
-- Assert that this is an "upgrade" branch and get its parent, which is the branch we were on when we ran `upgrade`.
parentBranchId <-
ProjectUtils.getUpgradeBranchParent upgradeProjectAndBranch.branch
& onNothing (Cli.returnEarly Output.NoUpgradeInProgress)
parentBranch <-
Cli.runTransaction do
Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId
let parentProjectAndBranch =
ProjectAndBranch upgradeProjectAndBranch.project parentBranch
-- Switch to the parent
ProjectSwitch.switchToProjectBranch (ProjectUtils.justTheIds parentProjectAndBranch)
-- Merge the upgrade branch into the parent
Merge.doMergeLocalBranch
TwoWay
{ alice = parentProjectAndBranch,
bob = upgradeProjectAndBranch
}
-- Delete the upgrade branch
DeleteBranch.doDeleteProjectBranch upgradeProjectAndBranch

View File

@ -1,19 +1,21 @@
-- | @delete.branch@ input handler -- | @delete.branch@ input handler
module Unison.Codebase.Editor.HandleInput.DeleteBranch module Unison.Codebase.Editor.HandleInput.DeleteBranch
( handleDeleteBranch, ( handleDeleteBranch,
doDeleteProjectBranch,
) )
where where
import Control.Lens (over, (^.)) import Control.Lens (over)
import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
import Data.These (These (..)) import Data.These (These (..))
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Codebase.Sqlite.Queries qualified as Queries import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli) import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Prelude import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
@ -25,47 +27,45 @@ import Witch (unsafeFrom)
-- Its children branches, if any, are reparented to their grandparent, if any. You may delete the only branch in a -- Its children branches, if any, are reparented to their grandparent, if any. You may delete the only branch in a
-- project. -- project.
handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleDeleteBranch projectAndBranchNames0 = do handleDeleteBranch projectAndBranchNamesToDelete = do
projectAndBranchNames <- projectAndBranchToDelete <-
ProjectUtils.hydrateNames ProjectUtils.expectProjectAndBranchByTheseNames
case projectAndBranchNames0 of case projectAndBranchNamesToDelete of
ProjectAndBranch Nothing branch -> That branch ProjectAndBranch Nothing branch -> That branch
ProjectAndBranch (Just project) branch -> These project branch ProjectAndBranch (Just project) branch -> These project branch
maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
deletedBranch <- doDeleteProjectBranch projectAndBranchToDelete
Cli.runTransactionWithRollback \rollback -> do
branch <-
Queries.loadProjectBranchByNames (projectAndBranchNames ^. #project) (projectAndBranchNames ^. #branch)
& onNothingM (rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames))
Queries.deleteProjectBranch (branch ^. #projectId) (branch ^. #branchId)
pure branch
let projectId = deletedBranch ^. #projectId
Cli.stepAt
("delete.branch " <> into @Text projectAndBranchNames)
( Path.unabsolute (ProjectUtils.projectBranchesPath projectId),
\branchObject ->
branchObject
& over
Branch.children
(Map.delete (ProjectUtils.projectBranchSegment (deletedBranch ^. #branchId)))
)
-- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order: -- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order:
-- --
-- 1. cd to parent branch, if it exists -- 1. cd to parent branch, if it exists
-- 2. cd to "main", if it exists -- 2. cd to "main", if it exists
-- 3. cd to loose code path `.` -- 3. cd to loose code path `.`
whenJust maybeCurrentBranch \(ProjectAndBranch _currentProject currentBranch, _restPath) -> whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) ->
when (deletedBranch == currentBranch) do when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do
newPath <- newPath <-
case deletedBranch ^. #parentBranchId of case projectAndBranchToDelete.branch.parentBranchId of
Nothing -> Nothing ->
Cli.runTransaction (Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main")) <&> \case let loadMain =
Nothing -> Path.Absolute Path.empty Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main")
Just mainBranch -> ProjectUtils.projectBranchPath (ProjectAndBranch projectId (mainBranch ^. #branchId)) in Cli.runTransaction loadMain <&> \case
Just parentBranchId -> pure (ProjectUtils.projectBranchPath (ProjectAndBranch projectId parentBranchId)) Nothing -> Path.Absolute Path.empty
Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch)
Just parentBranchId ->
pure $
ProjectUtils.projectBranchPath
(ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId)
Cli.cd newPath Cli.cd newPath
-- | Delete a project branch and record an entry in the reflog.
doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli ()
doDeleteProjectBranch projectAndBranch = do
Cli.runTransaction do
Queries.deleteProjectBranch projectAndBranch.project.projectId projectAndBranch.branch.branchId
Cli.stepAt
("delete.branch " <> into @Text (ProjectUtils.justTheNames projectAndBranch))
( Path.unabsolute (ProjectUtils.projectBranchesPath projectAndBranch.project.projectId),
over Branch.children (Map.delete (ProjectUtils.projectBranchSegment projectAndBranch.branch.branchId))
)

View File

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

View File

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

View File

@ -1,5 +1,13 @@
module Unison.Codebase.Editor.HandleInput.Merge2 module Unison.Codebase.Editor.HandleInput.Merge2
( handleMerge, ( handleMerge,
-- * API exported for @pull@
MergeInfo (..),
AliceMergeInfo (..),
BobMergeInfo (..),
LcaMergeInfo (..),
doMerge,
doMergeLocalBranch,
) )
where where
@ -12,9 +20,12 @@ import Data.Bitraversable (bitraverse)
import Data.Foldable qualified as Foldable import Data.Foldable qualified as Foldable
import Data.List qualified as List import Data.List qualified as List
import Data.List.NonEmpty (pattern (:|)) import Data.List.NonEmpty (pattern (:|))
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
import Data.Semialign (align, unzip) import Data.Semialign (align, unzip)
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as Set.NonEmpty
import Data.Text qualified as Text import Data.Text qualified as Text
import Data.Text.IO qualified as Text import Data.Text.IO qualified as Text
import Data.These (These (..)) import Data.These (These (..))
@ -24,17 +35,20 @@ import Text.Builder qualified as Text (Builder)
import U.Codebase.Branch qualified as V2 (Branch (..), CausalBranch) import U.Codebase.Branch qualified as V2 (Branch (..), CausalBranch)
import U.Codebase.Branch qualified as V2.Branch import U.Codebase.Branch qualified as V2.Branch
import U.Codebase.Causal qualified as V2.Causal import U.Codebase.Causal qualified as V2.Causal
import U.Codebase.HashTags (unCausalHash) import U.Codebase.HashTags (CausalHash, unCausalHash)
import U.Codebase.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId) import U.Codebase.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId)
import U.Codebase.Referent qualified as V2 (Referent) import U.Codebase.Referent qualified as V2 (Referent)
import U.Codebase.Sqlite.DbId (ProjectId)
import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Builtin.Decls qualified as Builtin.Decls import Unison.Builtin.Decls qualified as Builtin.Decls
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..))
import Unison.Cli.Monad (Cli) import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase (Codebase) import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch (Branch0)
@ -47,8 +61,9 @@ import Unison.Codebase.Editor.HandleInput.Update2
prettyParseTypecheck2, prettyParseTypecheck2,
typecheckedUnisonFileToBranchAdds, typecheckedUnisonFileToBranchAdds,
) )
import Unison.Codebase.Editor.Output (Output)
import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..))
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
@ -62,7 +77,7 @@ import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ' import Unison.HashQualified' qualified as HQ'
import Unison.Merge.CombineDiffs (CombinedDiffOp (..), combineDiffs) import Unison.Merge.CombineDiffs (CombinedDiffOp (..), combineDiffs)
import Unison.Merge.Database (MergeDatabase (..), makeMergeDatabase, referent2to1) 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.DeclNameLookup (DeclNameLookup (..), expectConstructorNames)
import Unison.Merge.Diff qualified as Merge import Unison.Merge.Diff qualified as Merge
import Unison.Merge.DiffOp (DiffOp (..)) import Unison.Merge.DiffOp (DiffOp (..))
@ -71,7 +86,6 @@ import Unison.Merge.EitherWayI (EitherWayI (..))
import Unison.Merge.EitherWayI qualified as EitherWayI import Unison.Merge.EitherWayI qualified as EitherWayI
import Unison.Merge.Libdeps qualified as Merge import Unison.Merge.Libdeps qualified as Merge
import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs) import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
import Unison.Merge.PreconditionViolation qualified as Merge
import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.Synhashed (Synhashed (..))
import Unison.Merge.Synhashed qualified as Synhashed import Unison.Merge.Synhashed qualified as Synhashed
import Unison.Merge.ThreeWay (ThreeWay (..)) import Unison.Merge.ThreeWay (ThreeWay (..))
@ -112,12 +126,12 @@ import Unison.Typechecker qualified as Typechecker
import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, defnsAreEmpty, zipDefnsWith, zipDefnsWith3) import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, defnsAreEmpty, zipDefnsWith, zipDefnsWith3)
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Nametree (Nametree (..), flattenNametree, traverseNametreeWithName, unflattenNametree) import Unison.Util.Nametree (Nametree (..), flattenNametree, traverseNametreeWithName, unflattenNametree)
import Unison.Util.Pretty (ColorText, Pretty) import Unison.Util.Pretty (ColorText, Pretty)
import Unison.Util.Pretty qualified as Pretty import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Relation (Relation) import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation import Unison.Util.Relation qualified as Relation
import Unison.Util.Set qualified as Set
import Unison.Util.Star2 (Star2) import Unison.Util.Star2 (Star2)
import Unison.Util.Star2 qualified as Star2 import Unison.Util.Star2 qualified as Star2
import Unison.Util.SyntaxText (SyntaxText') import Unison.Util.SyntaxText (SyntaxText')
@ -126,246 +140,329 @@ import Witch (unsafeFrom)
import Prelude hiding (unzip, zip, zipWith) import Prelude hiding (unzip, zip, zipWith)
handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleMerge bobSpecifier = do handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do
-- Assert that Alice (us) is on a project branch, and grab the causal hash.
(aliceProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
-- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch
-- name, and causal hash.
bobProject <-
case maybeBobProjectName of
Nothing -> pure aliceProjectAndBranch.project
Just bobProjectName
| bobProjectName == aliceProjectAndBranch.project.name -> pure aliceProjectAndBranch.project
| otherwise -> do
Cli.runTransaction (Queries.loadProjectByName bobProjectName)
& onNothingM (Cli.returnEarly (Output.LocalProjectDoesntExist bobProjectName))
bobProjectBranch <- ProjectUtils.expectProjectBranchByName bobProject bobBranchName
let bobProjectAndBranch = ProjectAndBranch bobProject bobProjectBranch
doMergeLocalBranch
TwoWay
{ alice = aliceProjectAndBranch,
bob = bobProjectAndBranch
}
data MergeInfo = MergeInfo
{ alice :: !AliceMergeInfo,
bob :: !BobMergeInfo,
lca :: !LcaMergeInfo,
-- | How should we describe this merge in the reflog?
description :: !Text
}
data AliceMergeInfo = AliceMergeInfo
{ causalHash :: !CausalHash,
projectAndBranch :: !(ProjectAndBranch Project ProjectBranch)
}
data BobMergeInfo = BobMergeInfo
{ causalHash :: !CausalHash,
source :: !MergeSource
}
newtype LcaMergeInfo = LcaMergeInfo
{ causalHash :: Maybe CausalHash
}
doMerge :: MergeInfo -> Cli ()
doMerge info = do
let debugFunctions = let debugFunctions =
if Debug.shouldDebug Debug.Merge if Debug.shouldDebug Debug.Merge
then realDebugFunctions then realDebugFunctions
else fakeDebugFunctions else fakeDebugFunctions
let alicePath = ProjectUtils.projectBranchPath (ProjectUtils.justTheIds info.alice.projectAndBranch)
let aliceBranchNames = ProjectUtils.justTheNames info.alice.projectAndBranch
let mergeSource = MergeSourceOrTarget'Source info.bob.source
let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames
let mergeSourceAndTarget = MergeSourceAndTarget {alice = aliceBranchNames, bob = info.bob.source}
Cli.Env {codebase} <- ask Cli.Env {codebase} <- ask
-- Create a bunch of cached database lookup functions Cli.label \done -> do
db <- makeMergeDatabase codebase -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done.
when (info.alice.causalHash == info.bob.causalHash || info.lca.causalHash == Just info.bob.causalHash) do
Cli.respond (Output.MergeAlreadyUpToDate2 mergeSourceAndTarget)
done ()
-- Load the current project branch ("Alice"), and the branch from the same project to merge in ("Bob") -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done.
info <- loadMergeInfo bobSpecifier when (info.lca.causalHash == Just info.alice.causalHash) do
let projectAndBranchNames = (\x -> ProjectAndBranch x.project.name x.branch.name) <$> info.branches bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash)
_ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch)
Cli.respond (Output.MergeSuccessFastForward mergeSourceAndTarget)
done ()
-- Load Alice/Bob/LCA causals -- Create a bunch of cached database lookup functions
causals <- db <- makeMergeDatabase codebase
-- Load Alice/Bob/LCA causals
causals <- Cli.runTransaction do
traverse
Operations.expectCausalBranchByCausalHash
TwoOrThreeWay
{ alice = info.alice.causalHash,
bob = info.bob.causalHash,
lca = info.lca.causalHash
}
liftIO (debugFunctions.debugCausals causals)
-- Load Alice/Bob/LCA branches
branches <-
Cli.runTransaction do
alice <- causals.alice.value
bob <- causals.bob.value
lca <- for causals.lca \causal -> causal.value
pure TwoOrThreeWay {lca, alice, bob}
-- Assert that neither Alice nor Bob have defns in lib
for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do
libdeps <-
case Map.lookup NameSegment.libSegment branch.children of
Nothing -> pure V2.Branch.empty
Just libdeps -> Cli.runTransaction libdeps.value
when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do
Cli.returnEarly (Output.MergeDefnsInLib who)
-- Load Alice/Bob/LCA definitions and decl name lookups
(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 (emptyNametree, DeclNameLookup Map.empty Map.empty)
Just (who, branch) -> do
defns <- loadDefns branch
declNameLookup <-
Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err ->
Cli.returnEarly case err of
IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 ->
Output.MergeConstructorAlias who typeName conName1 conName2
IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name
IncoherentDeclReason'NestedDeclAlias shorterName longerName ->
Output.MergeNestedDeclAlias who shorterName longerName
IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name
pure (defns, declNameLookup)
(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 declNameLookups = TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup}
pure (defns3, declNameLookups, lcaDeclToConstructors)
let defns = ThreeWay.forgetLca defns3
liftIO (debugFunctions.debugDefns defns3 declNameLookups lcaDeclToConstructors)
-- Diff LCA->Alice and LCA->Bob
diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns3)
liftIO (debugFunctions.debugDiffs diffs)
-- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias
for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) ->
whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) ->
Cli.returnEarly (Output.MergeConflictedAliases who name1 name2)
-- Combine the LCA->Alice and LCA->Bob diffs together
let diff = combineDiffs diffs
liftIO (debugFunctions.debugCombinedDiff diff)
-- Partition the combined diff into the conflicted things and the unconflicted things
(conflicts, unconflicts) <-
partitionCombinedDiffs defns declNameLookups diff & onLeft \name ->
Cli.returnEarly (Output.MergeConflictInvolvingBuiltin name)
liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts)
-- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there
-- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are)
dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts)
liftIO (debugFunctions.debugDependents dependents)
let stageOne :: DefnsF (Map Name) Referent TypeReference
stageOne =
makeStageOne
declNameLookups
conflicts
unconflicts
dependents
(bimap BiMultimap.range BiMultimap.range defns3.lca)
liftIO (debugFunctions.debugStageOne stageOne)
-- Load and merge Alice's and Bob's libdeps
mergedLibdeps <-
Cli.runTransaction do
libdeps <- loadLibdeps branches
libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps)
-- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names
let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl
mkPpes defnsNames libdepsNames =
defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier
where
suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames)
let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps)
hydratedThings <- do
Cli.runTransaction do
for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) ->
let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent
in (,) <$> hydrate conflicts1 <*> hydrate dependents1
let (renderedConflicts, renderedDependents) =
let honk declNameLookup ppe defns =
let (types, accessorNames) =
Writer.runWriter $
defns.types & Map.traverseWithKey \name (ref, typ) ->
renderTypeBinding
-- Sort of a hack; since the decl printer looks in the PPE for names of constructors,
-- we just delete all term names out and add back the constructors...
-- probably no need to wipe out the suffixified side but we do it anyway
(setPpedToConstructorNames declNameLookup name ref ppe)
name
ref
typ
terms =
defns.terms & Map.mapMaybeWithKey \name (term, typ) ->
if Set.member name accessorNames
then Nothing
else Just (renderTermBinding ppe.suffixifiedPPE name term typ)
in Defns {terms, types}
in unzip $
( \declNameLookup (conflicts, dependents) ppe ->
let honk1 = honk declNameLookup ppe
in (honk1 conflicts, honk1 dependents)
)
<$> declNameLookups
<*> hydratedThings
<*> ppes
let prettyUnisonFile =
makePrettyUnisonFile
TwoWay
{ alice = into @Text aliceBranchNames,
bob =
case info.bob.source of
MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames
MergeSource'RemoteProjectBranch bobBranchNames
| aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames
| otherwise -> into @Text bobBranchNames
MergeSource'RemoteLooseCode info ->
case Path.toName info.path of
Nothing -> "<root>"
Just name -> Name.toText name
}
renderedConflicts
renderedDependents
let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps
maybeTypecheckedUnisonFile <-
let thisMergeHasConflicts =
-- Eh, they'd either both be null, or neither, but just check both maps anyway
not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob)
in if thisMergeHasConflicts
then pure Nothing
else do
currentPath <- Cli.getCurrentPath
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
let parents =
(\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals
case maybeTypecheckedUnisonFile of
Nothing -> do
Cli.Env {writeSource} <- ask
_temporaryBranchId <-
HandleInput.Branch.doCreateBranch'
(Branch.mergeNode stageOneBranch parents.alice parents.bob)
Nothing
info.alice.projectAndBranch.project
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
info.description
scratchFilePath <-
Cli.getLatestFile <&> \case
Nothing -> "scratch.u"
Just (file, _) -> file
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
Cli.respond (Output.MergeFailure scratchFilePath mergeSourceAndTarget)
Just tuf -> do
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
_ <-
Cli.updateAt
info.description
alicePath
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
Cli.respond (Output.MergeSuccess mergeSourceAndTarget)
doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
doMergeLocalBranch branches = do
(aliceCausalHash, bobCausalHash, lcaCausalHash) <-
Cli.runTransaction do Cli.runTransaction do
alice <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute info.paths.alice) aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice)
bob <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute info.paths.bob) bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob)
lca <- -- Using Alice and Bob's causal hashes, find the LCA (if it exists)
Operations.lca alice.causalHash bob.causalHash >>= \case lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash
Nothing -> pure Nothing pure (aliceCausalHash, bobCausalHash, lcaCausalHash)
Just lcaCausalHash -> Just <$> db.loadCausal lcaCausalHash
pure TwoOrThreeWay {lca, alice, bob}
-- If alice == bob, then we are done. -- Do the merge!
when (causals.alice == causals.bob) do doMerge
Cli.returnEarly (Output.MergeAlreadyUpToDate (Right info.branches.bob) (Right info.branches.alice)) MergeInfo
{ alice =
-- Otherwise, if LCA == bob, then we are ahead of bob, so we are done. AliceMergeInfo
when (causals.lca == Just causals.bob) do { causalHash = aliceCausalHash,
Cli.returnEarly (Output.MergeAlreadyUpToDate (Right info.branches.bob) (Right info.branches.alice)) projectAndBranch = branches.alice
},
-- Otherwise, if LCA == alice, then we can fast forward to bob, and we're done. bob =
when (causals.lca == Just causals.alice) do BobMergeInfo
bobBranch <- Cli.getBranchAt info.paths.bob { causalHash = bobCausalHash,
_ <- Cli.updateAt (textualDescriptionOfMerge info) info.paths.alice (\_aliceBranch -> bobBranch) source = MergeSource'LocalProjectBranch (ProjectUtils.justTheNames branches.bob)
Cli.returnEarly (Output.MergeSuccessFastForward projectAndBranchNames.alice projectAndBranchNames.bob) },
lca =
liftIO (debugFunctions.debugCausals causals) LcaMergeInfo
{ causalHash = lcaCausalHash
-- Load Alice/Bob/LCA branches },
branches <- description = "merge " <> into @Text (ProjectUtils.justTheNames branches.bob)
Cli.runTransaction do }
alice <- causals.alice.value
bob <- causals.bob.value
lca <- for causals.lca \causal -> causal.value
pure TwoOrThreeWay {lca, alice, bob}
-- Load Alice/Bob/LCA definitions and decl name lookups
(defns3, declNameLookups3) <-
Cli.runTransactionWithRollback \abort -> do
loadDefns abort db (view #branch <$> info.branches) branches
let defns = ThreeWay.forgetLca defns3
let declNameLookups = ThreeWay.forgetLca declNameLookups3
liftIO (debugFunctions.debugDefns defns3 declNameLookups3)
-- Diff LCA->Alice and LCA->Bob
diffs <-
Cli.runTransaction do
Merge.nameBasedNamespaceDiff db declNameLookups3 defns3
liftIO (debugFunctions.debugDiffs diffs)
-- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias
whenJust (findOneConflictedAlias (view #branch <$> info.branches) defns3.lca diffs) \violation ->
Cli.returnEarly (mergePreconditionViolationToOutput violation)
-- Combine the LCA->Alice and LCA->Bob diffs together
let diff = combineDiffs diffs
liftIO (debugFunctions.debugCombinedDiff diff)
-- Partition the combined diff into the conflicted things and the unconflicted things
(conflicts, unconflicts) <-
partitionCombinedDiffs defns declNameLookups diff & onLeft \name ->
Cli.returnEarly (mergePreconditionViolationToOutput (Merge.ConflictInvolvingBuiltin name))
liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts)
-- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there
-- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are)
dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts)
liftIO (debugFunctions.debugDependents dependents)
let stageOne :: DefnsF (Map Name) Referent TypeReference
stageOne =
makeStageOne
declNameLookups
conflicts
unconflicts
dependents
(bimap BiMultimap.range BiMultimap.range defns3.lca)
liftIO (debugFunctions.debugStageOne stageOne)
-- Load and merge Alice's and Bob's libdeps
mergedLibdeps <-
Cli.runTransaction do
libdeps <- loadLibdeps branches
libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps)
-- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names
let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl
mkPpes defnsNames libdepsNames =
defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier
where
suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames)
let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps)
hydratedThings <- do
Cli.runTransaction do
for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) ->
let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent
in (,) <$> hydrate conflicts1 <*> hydrate dependents1
let (renderedConflicts, renderedDependents) =
let honk declNameLookup ppe defns =
let (types, accessorNames) =
Writer.runWriter $
defns.types & Map.traverseWithKey \name (ref, typ) ->
renderTypeBinding
-- Sort of a hack; since the decl printer looks in the PPE for names of constructors,
-- we just delete all term names out and add back the constructors...
-- probably no need to wipe out the suffixified side but we do it anyway
(setPpedToConstructorNames declNameLookup name ref ppe)
name
ref
typ
terms =
defns.terms & Map.mapMaybeWithKey \name (term, typ) ->
if Set.member name accessorNames
then Nothing
else Just (renderTermBinding ppe.suffixifiedPPE name term typ)
in Defns {terms, types}
in unzip $
( \declNameLookup (conflicts, dependents) ppe ->
let honk1 = honk declNameLookup ppe
in (honk1 conflicts, honk1 dependents)
)
<$> declNameLookups
<*> hydratedThings
<*> ppes
let prettyUnisonFile = makePrettyUnisonFile (into @Text <$> projectAndBranchNames) renderedConflicts renderedDependents
let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps
maybeTypecheckedUnisonFile <-
let thisMergeHasConflicts =
-- Eh, they'd either both be null, or neither, but just check both maps anyway
not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob)
in if thisMergeHasConflicts
then pure Nothing
else do
currentPath <- Cli.getCurrentPath
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
case maybeTypecheckedUnisonFile of
Nothing -> do
Cli.Env {writeSource} <- ask
aliceBranch <- Cli.getBranchAt info.paths.alice
bobBranch <- Cli.getBranchAt info.paths.bob
_temporaryBranchId <-
HandleInput.Branch.doCreateBranch'
(Branch.mergeNode stageOneBranch aliceBranch bobBranch)
Nothing
info.branches.alice.project
(findTemporaryBranchName info)
(textualDescriptionOfMerge info)
scratchFilePath <-
Cli.getLatestFile <&> \case
Nothing -> "scratch.u"
Just (file, _) -> file
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
Cli.respond $
Output.MergeFailure
scratchFilePath
projectAndBranchNames.alice
projectAndBranchNames.bob
Just tuf -> do
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
bobBranch <- Cli.getBranchAt info.paths.bob
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
_ <-
Cli.updateAt
(textualDescriptionOfMerge info)
info.paths.alice
(\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch)
Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob)
------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------
-- Loading basic info out of the database -- Loading basic info out of the database
loadMergeInfo :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli MergeInfo
loadMergeInfo (ProjectAndBranch maybeBobProjectName bobBranchName) = do
(aliceProjectBranch, _path) <- Cli.expectCurrentProjectBranch
bobProjectBranch <-
Cli.expectProjectAndBranchByTheseNames case maybeBobProjectName of
Nothing -> That bobBranchName
Just bobProjectName -> These bobProjectName bobBranchName
let alicePath = Cli.projectBranchPath (ProjectAndBranch aliceProjectBranch.project.projectId aliceProjectBranch.branch.branchId)
let bobPath = Cli.projectBranchPath (ProjectAndBranch bobProjectBranch.project.projectId bobProjectBranch.branch.branchId)
pure
MergeInfo
{ paths = TwoWay alicePath bobPath,
branches = TwoWay aliceProjectBranch bobProjectBranch
}
loadDefns ::
(forall a. Output -> Transaction a) ->
MergeDatabase ->
TwoWay ProjectBranch ->
TwoOrThreeWay (V2.Branch Transaction) ->
Transaction
( ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)),
ThreeWay DeclNameLookup
)
loadDefns abort0 db projectBranches branches = do
lcaDefns0 <-
case branches.lca of
Nothing -> pure Nametree {value = Defns Map.empty Map.empty, children = Map.empty}
Just lcaBranch -> loadNamespaceInfo abort db lcaBranch
aliceDefns0 <- loadNamespaceInfo abort db branches.alice
bobDefns0 <- loadNamespaceInfo abort db branches.bob
lca <- assertNamespaceSatisfiesPreconditions db abort Nothing (fromMaybe V2.Branch.empty branches.lca) lcaDefns0
alice <- assertNamespaceSatisfiesPreconditions db abort (Just projectBranches.alice.name) branches.alice aliceDefns0
bob <- assertNamespaceSatisfiesPreconditions db abort (Just projectBranches.bob.name) branches.bob bobDefns0
pure (unzip ThreeWay {lca, alice, bob})
where
abort :: Merge.PreconditionViolation -> Transaction void
abort =
abort0 . mergePreconditionViolationToOutput
loadLibdeps :: loadLibdeps ::
TwoOrThreeWay (V2.Branch Transaction) -> TwoOrThreeWay (V2.Branch Transaction) ->
Transaction (ThreeWay (Map NameSegment (V2.CausalBranch Transaction))) Transaction (ThreeWay (Map NameSegment (V2.CausalBranch Transaction)))
@ -502,13 +599,16 @@ makePrettyUnisonFile authors conflicts dependents =
bob = prettyBinding (Just (Pretty.text authors.bob)) bob = prettyBinding (Just (Pretty.text authors.bob))
in bifoldMap f f in bifoldMap f f
), ),
if TwoWay.or (not . defnsAreEmpty <$> dependents) -- Show message that delineates where conflicts end and dependents begin only when there are both conflicts and
then -- dependents
fold let thereAre defns = TwoWay.or (not . defnsAreEmpty <$> defns)
[ "-- The definitions below are not conflicted, but they each depend on one or more\n", in if thereAre conflicts && thereAre dependents
"-- conflicted definitions above.\n\n" then
] fold
else mempty, [ "-- The definitions below are not conflicted, but they each depend on one or more\n",
"-- conflicted definitions above.\n\n"
]
else mempty,
dependents dependents
-- Merge dependents together into one map (they are disjoint) -- Merge dependents together into one map (they are disjoint)
& TwoWay.twoWay (zipDefnsWith Map.union Map.union) & TwoWay.twoWay (zipDefnsWith Map.union Map.union)
@ -622,17 +722,6 @@ nametreeToBranch0 nametree =
rel2star rel = rel2star rel =
Star2.Star2 {fact = Relation.dom rel, d1 = rel, d2 = Relation.empty} Star2.Star2 {fact = Relation.dom rel, d1 = rel, d2 = Relation.empty}
data MergeInfo = MergeInfo
{ paths :: !(TwoWay Path.Absolute),
branches :: !(TwoWay (ProjectAndBranch Project ProjectBranch))
}
deriving stock (Generic)
textualDescriptionOfMerge :: MergeInfo -> Text
textualDescriptionOfMerge info =
let bobBranchText = into @Text (ProjectAndBranch info.branches.bob.project.name info.branches.bob.branch.name)
in "merge " <> bobBranchText
-- FIXME: let's come up with a better term for "dependencies" in the implementation of this function -- FIXME: let's come up with a better term for "dependencies" in the implementation of this function
identifyDependents :: identifyDependents ::
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
@ -750,30 +839,39 @@ defnsToNames defns =
types = Relation.fromMap (BiMultimap.range defns.types) types = Relation.fromMap (BiMultimap.range defns.types)
} }
findTemporaryBranchName :: MergeInfo -> Transaction ProjectBranchName findTemporaryBranchName :: ProjectId -> MergeSourceAndTarget -> Transaction ProjectBranchName
findTemporaryBranchName info = do findTemporaryBranchName projectId mergeSourceAndTarget = do
Cli.findTemporaryBranchName info.branches.alice.project.projectId preferred ProjectUtils.findTemporaryBranchName projectId preferred
where where
preferred :: ProjectBranchName preferred :: ProjectBranchName
preferred = preferred =
unsafeFrom @Text $ unsafeFrom @Text $
"merge-" Text.Builder.run $
<> mangle info.branches.bob.branch.name "merge-"
<> "-into-" <> mangleMergeSource mergeSourceAndTarget.bob
<> mangle info.branches.alice.branch.name <> "-into-"
<> mangleBranchName mergeSourceAndTarget.alice.branch
mangle :: ProjectBranchName -> Text mangleMergeSource :: MergeSource -> Text.Builder
mangle = mangleMergeSource = \case
Text.Builder.run . mangleB MergeSource'LocalProjectBranch (ProjectAndBranch _project branch) -> mangleBranchName branch
MergeSource'RemoteProjectBranch (ProjectAndBranch _project branch) -> "remote-" <> mangleBranchName branch
mangleB :: ProjectBranchName -> Text.Builder MergeSource'RemoteLooseCode info -> manglePath info.path
mangleB name = mangleBranchName :: ProjectBranchName -> Text.Builder
mangleBranchName name =
case classifyProjectBranchName name of case classifyProjectBranchName name of
ProjectBranchNameKind'Contributor user name1 -> Text.Builder.text user <> Text.Builder.char '-' <> mangleB name1 ProjectBranchNameKind'Contributor user name1 ->
Text.Builder.text user
<> Text.Builder.char '-'
<> mangleBranchName name1
ProjectBranchNameKind'DraftRelease semver -> "releases-drafts-" <> mangleSemver semver ProjectBranchNameKind'DraftRelease semver -> "releases-drafts-" <> mangleSemver semver
ProjectBranchNameKind'Release semver -> "releases-" <> mangleSemver semver ProjectBranchNameKind'Release semver -> "releases-" <> mangleSemver semver
ProjectBranchNameKind'NothingSpecial -> Text.Builder.text (into @Text name) ProjectBranchNameKind'NothingSpecial -> Text.Builder.text (into @Text name)
manglePath :: Path -> Text.Builder
manglePath =
Monoid.intercalateMap "-" (Text.Builder.text . NameSegment.toUnescapedText) . Path.toList
mangleSemver :: Semver -> Text.Builder mangleSemver :: Semver -> Text.Builder
mangleSemver (Semver x y z) = mangleSemver (Semver x y z) =
Text.Builder.decimal x Text.Builder.decimal x
@ -782,141 +880,54 @@ findTemporaryBranchName info = do
<> Text.Builder.char '.' <> Text.Builder.char '.'
<> Text.Builder.decimal z <> Text.Builder.decimal z
-- Load namespace info into memory. -- Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined
--
-- Fails if:
-- * One name is associated with more than one reference.
loadNamespaceInfo ::
(forall void. Merge.PreconditionViolation -> Transaction void) ->
MergeDatabase ->
V2.Branch Transaction ->
Transaction (Nametree (DefnsF (Map NameSegment) Referent TypeReference))
loadNamespaceInfo abort db branch = do
defns <- loadNamespaceInfo0 (referent2to1 db) branch
assertNamespaceHasNoConflictedNames defns & onLeft abort
-- | Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined
-- in the "lib" namespace. -- in the "lib" namespace.
loadNamespaceInfo0 :: --
(Monad m) => -- Fails if there is a conflicted name.
loadNamespaceDefinitions ::
forall m.
Monad m =>
(V2.Referent -> m Referent) -> (V2.Referent -> m Referent) ->
V2.Branch m -> V2.Branch m ->
m (Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference)) m (Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference)))
loadNamespaceInfo0 referent2to1 branch = do loadNamespaceDefinitions referent2to1 =
terms <- fmap assertNamespaceHasNoConflictedNames . go (Map.delete NameSegment.libSegment)
branch.terms where
& Map.map Map.keysSet go ::
& traverse (Set.traverse referent2to1) (forall x. Map NameSegment x -> Map NameSegment x) ->
let types = Map.map Map.keysSet branch.types V2.Branch m ->
children <- m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference))
for (Map.delete NameSegment.libSegment branch.children) \childCausal -> do go f branch = do
childBranch <- childCausal.value terms <- for branch.terms (fmap (Set.NonEmpty.fromList . List.NonEmpty.fromList) . traverse referent2to1 . Map.keys)
loadNamespaceInfo0_ referent2to1 childBranch let types = Map.map (Set.NonEmpty.unsafeFromSet . Map.keysSet) branch.types
pure Nametree {value = Defns {terms, types}, children} children <-
for (f branch.children) \childCausal -> do
child <- childCausal.value
go id child
pure Nametree {value = Defns {terms, types}, children}
loadNamespaceInfo0_ :: data ConflictedName
(Monad m) => = ConflictedName'Term !Name !(NESet Referent)
(V2.Referent -> m Referent) -> | ConflictedName'Type !Name !(NESet TypeReference)
V2.Branch m ->
m (Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference))
loadNamespaceInfo0_ referent2to1 branch = do
terms <-
branch.terms
& Map.map Map.keysSet
& traverse (Set.traverse referent2to1)
let types = Map.map Map.keysSet branch.types
children <-
for branch.children \childCausal -> do
childBranch <- childCausal.value
loadNamespaceInfo0_ referent2to1 childBranch
pure Nametree {value = Defns {terms, types}, children}
-- | Assert that there are no unconflicted names in a namespace. -- | Assert that there are no unconflicted names in a namespace.
assertNamespaceHasNoConflictedNames :: assertNamespaceHasNoConflictedNames ::
Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference) -> Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) ->
Either Merge.PreconditionViolation (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference))
assertNamespaceHasNoConflictedNames = assertNamespaceHasNoConflictedNames =
traverseNametreeWithName \names defns -> do traverseNametreeWithName \names defns -> do
terms <- terms <-
defns.terms & Map.traverseWithKey \name -> defns.terms & Map.traverseWithKey \name ->
assertUnconflicted (Merge.ConflictedTermName (Name.fromReverseSegments (name :| names))) assertUnconflicted (ConflictedName'Term (Name.fromReverseSegments (name :| names)))
types <- types <-
defns.types & Map.traverseWithKey \name -> defns.types & Map.traverseWithKey \name ->
assertUnconflicted (Merge.ConflictedTypeName (Name.fromReverseSegments (name :| names))) assertUnconflicted (ConflictedName'Type (Name.fromReverseSegments (name :| names)))
pure Defns {terms, types} pure Defns {terms, types}
where where
assertUnconflicted :: (Set ref -> Merge.PreconditionViolation) -> Set ref -> Either Merge.PreconditionViolation ref assertUnconflicted :: (NESet ref -> ConflictedName) -> NESet ref -> Either ConflictedName ref
assertUnconflicted conflicted refs = assertUnconflicted conflicted refs
case Set.asSingleton refs of | Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs)
Nothing -> Left (conflicted refs) | otherwise = Left (conflicted refs)
Just ref -> Right ref
-- Convert a merge precondition violation to an output message.
mergePreconditionViolationToOutput :: Merge.PreconditionViolation -> Output.Output
mergePreconditionViolationToOutput = \case
Merge.ConflictedAliases branch name1 name2 -> Output.MergeConflictedAliases branch name1 name2
Merge.ConflictedTermName name refs -> Output.MergeConflictedTermName name refs
Merge.ConflictedTypeName name refs -> Output.MergeConflictedTypeName name refs
Merge.ConflictInvolvingBuiltin name -> Output.MergeConflictInvolvingBuiltin name
Merge.ConstructorAlias maybeBranch name1 name2 -> Output.MergeConstructorAlias maybeBranch name1 name2
Merge.DefnsInLib -> Output.MergeDefnsInLib
Merge.MissingConstructorName name -> Output.MergeMissingConstructorName name
Merge.NestedDeclAlias shorterName longerName -> Output.MergeNestedDeclAlias shorterName longerName
Merge.StrayConstructor name -> Output.MergeStrayConstructor name
-- Assert that a namespace satisfies a few preconditions.
--
-- Fails if:
-- * The "lib" namespace contains any top-level terms or decls. (Only child namespaces are expected here).
-- * Any type declarations are "incoherent" (see `checkDeclCoherency`)
assertNamespaceSatisfiesPreconditions ::
MergeDatabase ->
(forall void. Merge.PreconditionViolation -> Transaction void) ->
Maybe ProjectBranchName ->
V2.Branch Transaction ->
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
Transaction (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name), DeclNameLookup)
assertNamespaceSatisfiesPreconditions db abort maybeBranchName branch defns = do
whenJust (Map.lookup NameSegment.libSegment branch.children) \libdepsCausal -> do
libdepsBranch <- libdepsCausal.value
when (not (Map.null libdepsBranch.terms) || not (Map.null libdepsBranch.types)) do
abort Merge.DefnsInLib
declNameLookup <-
checkDeclCoherency db.loadDeclNumConstructors defns
& onLeftM (abort . incoherentDeclReasonToMergePreconditionViolation)
pure
( Defns
{ terms = flattenNametree (view #terms) defns,
types = flattenNametree (view #types) defns
},
declNameLookup
)
where
incoherentDeclReasonToMergePreconditionViolation :: IncoherentDeclReason -> Merge.PreconditionViolation
incoherentDeclReasonToMergePreconditionViolation = \case
IncoherentDeclReason'ConstructorAlias firstName secondName ->
Merge.ConstructorAlias maybeBranchName firstName secondName
IncoherentDeclReason'MissingConstructorName name -> Merge.MissingConstructorName name
IncoherentDeclReason'NestedDeclAlias shorterName longerName -> Merge.NestedDeclAlias shorterName longerName
IncoherentDeclReason'StrayConstructor name -> Merge.StrayConstructor name
findOneConflictedAlias ::
TwoWay ProjectBranch ->
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) ->
Maybe Merge.PreconditionViolation
findOneConflictedAlias projectBranchNames lcaDefns diffs =
aliceConflictedAliases <|> bobConflictedAliases
where
aliceConflictedAliases =
findConflictedAlias lcaDefns diffs.alice <&> \(name1, name2) ->
Merge.ConflictedAliases projectBranchNames.alice.name name1 name2
bobConflictedAliases =
findConflictedAlias lcaDefns diffs.bob <&> \(name1, name2) ->
Merge.ConflictedAliases projectBranchNames.bob.name name1 name2
-- @findConflictedAlias namespace diff@, given an old namespace and a diff to a new namespace, will return the first -- @findConflictedAlias namespace diff@, given an old namespace and a diff to a new namespace, will return the first
-- "conflicted alias" encountered (if any), where a "conflicted alias" is a pair of names that referred to the same -- "conflicted alias" encountered (if any), where a "conflicted alias" is a pair of names that referred to the same
@ -936,8 +947,9 @@ findOneConflictedAlias projectBranchNames lcaDefns diffs =
-- --
-- This function currently doesn't return whether the conflicted alias is a decl or a term, but it certainly could. -- This function currently doesn't return whether the conflicted alias is a decl or a term, but it certainly could.
findConflictedAlias :: findConflictedAlias ::
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> (Ord term, Ord typ) =>
DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference -> Defns (BiMultimap term Name) (BiMultimap typ Name) ->
DefnsF3 (Map Name) DiffOp Synhashed term typ ->
Maybe (Name, Name) Maybe (Name, Name)
findConflictedAlias defns diff = findConflictedAlias defns diff =
asum [go defns.terms diff.terms, go defns.types diff.types] asum [go defns.terms diff.terms, go defns.types diff.types]
@ -1022,7 +1034,8 @@ data DebugFunctions = DebugFunctions
{ debugCausals :: TwoOrThreeWay (V2.CausalBranch Transaction) -> IO (), { debugCausals :: TwoOrThreeWay (V2.CausalBranch Transaction) -> IO (),
debugDefns :: debugDefns ::
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
ThreeWay DeclNameLookup -> TwoWay DeclNameLookup ->
Map Name [Maybe Name] ->
IO (), IO (),
debugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO (), debugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO (),
debugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO (), debugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO (),
@ -1063,9 +1076,10 @@ realDebugCausals causals = do
realDebugDefns :: realDebugDefns ::
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
ThreeWay DeclNameLookup -> TwoWay DeclNameLookup ->
Map Name [Maybe Name] ->
IO () IO ()
realDebugDefns defns declNameLookups = do realDebugDefns defns declNameLookups _lcaDeclNameLookup = do
Text.putStrLn (Text.bold "\n=== Alice definitions ===") Text.putStrLn (Text.bold "\n=== Alice definitions ===")
debugDefns1 (bimap BiMultimap.range BiMultimap.range defns.alice) debugDefns1 (bimap BiMultimap.range BiMultimap.range defns.alice)

View File

@ -1,11 +1,13 @@
-- | @switch@ input handler -- | @switch@ input handler
module Unison.Codebase.Editor.HandleInput.ProjectSwitch module Unison.Codebase.Editor.HandleInput.ProjectSwitch
( projectSwitch, ( projectSwitch,
switchToProjectBranch,
) )
where where
import Control.Lens ((^.))
import Data.These (These (..)) import Data.These (These (..))
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
import U.Codebase.Sqlite.Project qualified
import U.Codebase.Sqlite.Queries qualified as Queries import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli) import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli import Unison.Cli.Monad qualified as Cli
@ -31,52 +33,47 @@ projectSwitch projectNames = do
ProjectUtils.getCurrentProjectBranch >>= \case ProjectUtils.getCurrentProjectBranch >>= \case
Nothing -> switchToProjectAndBranchByTheseNames (This projectName) Nothing -> switchToProjectAndBranchByTheseNames (This projectName)
Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do
let currentProjectName = currentProject ^. #name
(projectExists, branchExists) <- (projectExists, branchExists) <-
Cli.runTransaction do Cli.runTransaction do
(,) (,)
<$> Queries.projectExistsByName projectName <$> Queries.projectExistsByName projectName
<*> Queries.projectBranchExistsByName (currentProject ^. #projectId) branchName <*> Queries.projectBranchExistsByName currentProject.projectId branchName
case (projectExists, branchExists) of case (projectExists, branchExists) of
(False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName) (False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName)
(False, True) -> switchToProjectAndBranchByTheseNames (These currentProjectName branchName) (False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName)
(True, False) -> switchToProjectAndBranchByTheseNames (This projectName) (True, False) -> switchToProjectAndBranchByTheseNames (This projectName)
(True, True) -> (True, True) ->
Cli.respondNumbered $ Cli.respondNumbered $
Output.AmbiguousSwitch Output.AmbiguousSwitch
projectName projectName
(ProjectAndBranch currentProjectName branchName) (ProjectAndBranch currentProject.name branchName)
ProjectAndBranchNames'Unambiguous projectAndBranchNames0 -> ProjectAndBranchNames'Unambiguous projectAndBranchNames0 ->
switchToProjectAndBranchByTheseNames projectAndBranchNames0 switchToProjectAndBranchByTheseNames projectAndBranchNames0
switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli () switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli ()
switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do
branch <- case projectAndBranchNames0 of branch <-
This projectName -> case projectAndBranchNames0 of
Cli.runTransactionWithRollback \rollback -> do This projectName ->
project <- Cli.runTransactionWithRollback \rollback -> do
Queries.loadProjectByName projectName & onNothingM do project <-
rollback (Output.LocalProjectDoesntExist projectName) Queries.loadProjectByName projectName & onNothingM do
Queries.loadMostRecentBranch (project ^. #projectId) >>= \case rollback (Output.LocalProjectDoesntExist projectName)
Nothing -> do let branchName = unsafeFrom @Text "main"
let branchName = unsafeFrom @Text "main" Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
branch <- rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
Queries.loadProjectBranchByName (project ^. #projectId) branchName & onNothingM do _ -> do
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0
setMostRecentBranch branch Cli.runTransactionWithRollback \rollback -> do
Just branchId ->
Queries.loadProjectBranch (project ^. #projectId) branchId >>= \case
Nothing -> error "impossible"
Just branch -> pure branch
_ -> do
projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0
Cli.runTransactionWithRollback \rollback -> do
branch <-
Queries.loadProjectBranchByNames projectName branchName & onNothingM do Queries.loadProjectBranchByNames projectName branchName & onNothingM do
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
setMostRecentBranch branch switchToProjectBranch (ProjectUtils.justTheIds' branch)
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId)))
where -- | Switch to a branch:
setMostRecentBranch branch = do --
Queries.setMostRecentBranch (branch ^. #projectId) (branch ^. #branchId) -- * Record it as the most-recent branch (so it's restored when ucm starts).
pure branch -- * Change the current path in the in-memory loop state.
switchToProjectBranch :: ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
switchToProjectBranch x = do
Cli.runTransaction (Queries.setMostRecentBranch x.project x.branch)
Cli.cd (ProjectUtils.projectBranchPath x)

View File

@ -7,14 +7,17 @@ module Unison.Codebase.Editor.HandleInput.Pull
) )
where where
import Control.Lens ((^.))
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Data.Text qualified as Text import Data.Text qualified as Text
import Data.These import Data.These
import U.Codebase.Sqlite.Project qualified as Sqlite (Project) import U.Codebase.Branch qualified as V2.Branch
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch) import U.Codebase.Causal qualified
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.DownloadUtils import Unison.Cli.DownloadUtils
import Unison.Cli.MergeTypes (MergeSource (..))
import Unison.Cli.Monad (Cli) import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.MonadUtils qualified as Cli
@ -25,6 +28,7 @@ import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch (Branch (..))
import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Merge qualified as Branch import Unison.Codebase.Branch.Merge qualified as Branch
import Unison.Codebase.Editor.HandleInput.Merge2 (AliceMergeInfo (..), BobMergeInfo (..), LcaMergeInfo (..), MergeInfo (..), doMerge)
import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper) import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper)
import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Input
import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Input qualified as Input
@ -37,7 +41,6 @@ import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch (Patch (..))
import Unison.Codebase.Path (Path') import Unison.Codebase.Path (Path')
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Verbosity qualified as Verbosity
import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPattern qualified as InputPattern
import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.CommandLine.InputPatterns qualified as InputPatterns
import Unison.NameSegment qualified as NameSegment import Unison.NameSegment qualified as NameSegment
@ -45,75 +48,100 @@ import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName) import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName)
import Witch (unsafeFrom) import Witch (unsafeFrom)
handlePull :: PullSourceTarget -> PullMode -> Verbosity.Verbosity -> Cli () handlePull :: PullSourceTarget -> PullMode -> Cli ()
handlePull unresolvedSourceAndTarget pullMode verbosity = do handlePull unresolvedSourceAndTarget pullMode = do
let includeSquashed = case pullMode of let includeSquashed = case pullMode of
Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithHistory -> Share.NoSquashedHead
Input.PullWithoutHistory -> Share.IncludeSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead
(source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget (source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget
remoteBranchObject <- do
Cli.Env {codebase} <- ask remoteCausalHash <- do
causalHash <- case source of
case source of ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError)
ReadRemoteNamespaceGit repo -> do ReadShare'ProjectBranch remoteBranch ->
downloadLooseCodeFromGitRepo downloadProjectBranchFromShare
codebase ( case pullMode of
( case pullMode of Input.PullWithHistory -> Share.NoSquashedHead
Input.PullWithHistory -> GitNamespaceHistoryTreatment'LetAlone Input.PullWithoutHistory -> Share.IncludeSquashedHead
Input.PullWithoutHistory -> GitNamespaceHistoryTreatment'DiscardAllHistory )
) remoteBranch
repo & onLeftM (Cli.returnEarly . Output.ShareError)
& onLeftM (Cli.returnEarly . Output.GitError)
ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError) remoteBranchIsEmpty <-
ReadShare'ProjectBranch remoteBranch -> Cli.runTransaction do
downloadProjectBranchFromShare causal <- Operations.expectCausalBranchByCausalHash remoteCausalHash
( case pullMode of branch <- causal.value
Input.PullWithHistory -> Share.NoSquashedHead V2.Branch.isEmpty branch
Input.PullWithoutHistory -> Share.IncludeSquashedHead
) when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source))
remoteBranch
& onLeftM (Cli.returnEarly . Output.ShareError) let targetAbsolutePath =
liftIO (Codebase.expectBranchForHash codebase causalHash) ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.branch.branchId)
when (Branch.isEmpty0 (Branch.head remoteBranchObject)) do
Cli.respond (PulledEmptyBranch source)
targetAbsolutePath <-
case target of
Left path -> Cli.resolvePath' path
Right (ProjectAndBranch project branch) ->
pure $ ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))
let description = let description =
Text.unwords Text.unwords
[ Text.pack . InputPattern.patternName $ [ Text.pack . InputPattern.patternName $
case pullMode of case pullMode of
PullWithoutHistory -> InputPatterns.pullWithoutHistory PullWithoutHistory -> InputPatterns.pullWithoutHistory
PullWithHistory -> InputPatterns.pull, PullWithHistory -> InputPatterns.pull,
printReadRemoteNamespace (\remoteBranch -> into @Text (ProjectAndBranch (remoteBranch ^. #projectName) (remoteBranch ^. #branchName))) source, printReadRemoteNamespace (\remoteBranch -> into @Text (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName)) source,
case target of case target of
Left path -> Path.toText' path ProjectAndBranch project branch -> into @Text (ProjectAndBranch project.name branch.name)
Right (ProjectAndBranch project branch) -> into @Text (ProjectAndBranch (project ^. #name) (branch ^. #name))
] ]
case pullMode of case pullMode of
Input.PullWithHistory -> do Input.PullWithHistory -> do
targetBranchObject <- Cli.getBranch0At targetAbsolutePath targetBranchObject <- Cli.getBranch0At targetAbsolutePath
if Branch.isEmpty0 targetBranchObject if Branch.isEmpty0 targetBranchObject
then do then do
Cli.Env {codebase} <- ask
remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash)
void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject) void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject)
Cli.respond $ MergeOverEmpty target Cli.respond $ MergeOverEmpty target
else do else do
Cli.respond AboutToMerge Cli.respond AboutToMerge
mergeBranchAndPropagateDefaultPatch
Branch.RegularMerge aliceCausalHash <-
description Cli.runTransaction do
(Just (PullAlreadyUpToDate source target)) causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute targetAbsolutePath)
remoteBranchObject pure causal.causalHash
(if Verbosity.isSilent verbosity then Nothing else Just target)
targetAbsolutePath lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash)
doMerge
MergeInfo
{ alice =
AliceMergeInfo
{ causalHash = aliceCausalHash,
projectAndBranch = target
},
bob =
BobMergeInfo
{ causalHash = remoteCausalHash,
source =
case source of
ReadShare'ProjectBranch remoteBranch ->
MergeSource'RemoteProjectBranch (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName)
ReadShare'LooseCode info -> MergeSource'RemoteLooseCode info
},
lca =
LcaMergeInfo
{ causalHash = lcaCausalHash
},
description
}
Input.PullWithoutHistory -> do Input.PullWithoutHistory -> do
Cli.Env {codebase} <- ask
remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash)
didUpdate <- didUpdate <-
Cli.updateAtM Cli.updateAtM
description description
targetAbsolutePath targetAbsolutePath
(\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject) (\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject)
Cli.respond Cli.respond
if didUpdate if didUpdate
then PullSuccessful source target then PullSuccessful source target
@ -124,13 +152,19 @@ resolveSourceAndTarget ::
PullSourceTarget -> PullSourceTarget ->
Cli Cli
( ReadRemoteNamespace Share.RemoteProjectBranch, ( ReadRemoteNamespace Share.RemoteProjectBranch,
Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch
) )
resolveSourceAndTarget includeSquashed = \case resolveSourceAndTarget includeSquashed = \case
Input.PullSourceTarget0 -> liftA2 (,) (resolveImplicitSource includeSquashed) resolveImplicitTarget Input.PullSourceTarget0 -> liftA2 (,) (resolveImplicitSource includeSquashed) resolveImplicitTarget
Input.PullSourceTarget1 source -> liftA2 (,) (resolveExplicitSource includeSquashed source) resolveImplicitTarget Input.PullSourceTarget1 source -> liftA2 (,) (resolveExplicitSource includeSquashed source) resolveImplicitTarget
Input.PullSourceTarget2 source target -> Input.PullSourceTarget2 source target ->
liftA2 (,) (resolveExplicitSource includeSquashed source) (ProjectUtils.expectLooseCodeOrProjectBranch target) liftA2
(,)
(resolveExplicitSource includeSquashed source)
( ProjectUtils.expectProjectAndBranchByTheseNames case target of
ProjectAndBranch Nothing branch -> That branch
ProjectAndBranch (Just project) branch -> These project branch
)
resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
resolveImplicitSource includeSquashed = resolveImplicitSource includeSquashed =
@ -139,8 +173,8 @@ resolveImplicitSource includeSquashed =
Just (localProjectAndBranch, _restPath) -> do Just (localProjectAndBranch, _restPath) -> do
(remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <- (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <-
Cli.runTransactionWithRollback \rollback -> do Cli.runTransactionWithRollback \rollback -> do
let localProjectId = localProjectAndBranch ^. #project . #projectId let localProjectId = localProjectAndBranch.project.projectId
let localBranchId = localProjectAndBranch ^. #branch . #branchId let localBranchId = localProjectAndBranch.branch.branchId
Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case
Just (remoteProjectId, Just remoteBranchId) -> do Just (remoteProjectId, Just remoteBranchId) -> do
remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri
@ -163,11 +197,10 @@ resolveExplicitSource ::
ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) -> ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) ->
Cli (ReadRemoteNamespace Share.RemoteProjectBranch) Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
resolveExplicitSource includeSquashed = \case resolveExplicitSource includeSquashed = \case
ReadRemoteNamespaceGit namespace -> pure (ReadRemoteNamespaceGit namespace)
ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace) ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace)
ReadShare'ProjectBranch (This remoteProjectName) -> do ReadShare'ProjectBranch (This remoteProjectName) -> do
remoteProject <- ProjectUtils.expectRemoteProjectByName remoteProjectName remoteProject <- ProjectUtils.expectRemoteProjectByName remoteProjectName
let remoteProjectId = remoteProject ^. #projectId let remoteProjectId = remoteProject.projectId
let remoteBranchName = unsafeFrom @Text "main" let remoteBranchName = unsafeFrom @Text "main"
remoteProjectBranch <- remoteProjectBranch <-
ProjectUtils.expectRemoteProjectBranchByName ProjectUtils.expectRemoteProjectBranchByName
@ -175,9 +208,9 @@ resolveExplicitSource includeSquashed = \case
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
pure (ReadShare'ProjectBranch remoteProjectBranch) pure (ReadShare'ProjectBranch remoteProjectBranch)
ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do
(ProjectAndBranch localProject localBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch (localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch
let localProjectId = localProject ^. #projectId let localProjectId = localProjectAndBranch.project.projectId
let localBranchId = localBranch ^. #branchId let localBranchId = localProjectAndBranch.branch.branchId
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
Just (remoteProjectId, _maybeProjectBranchId) -> do Just (remoteProjectId, _maybeProjectBranchId) -> do
remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri) remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri)
@ -194,12 +227,10 @@ resolveExplicitSource includeSquashed = \case
pure (ReadShare'ProjectBranch remoteProjectBranch) pure (ReadShare'ProjectBranch remoteProjectBranch)
Nothing -> do Nothing -> do
Cli.returnEarly $ Cli.returnEarly $
Output.NoAssociatedRemoteProject Output.NoAssociatedRemoteProject Share.hardCodedUri (ProjectUtils.justTheNames localProjectAndBranch)
Share.hardCodedUri
(ProjectAndBranch (localProject ^. #name) (localBranch ^. #name))
ReadShare'ProjectBranch (These projectName branchNameOrLatestRelease) -> do ReadShare'ProjectBranch (These projectName branchNameOrLatestRelease) -> do
remoteProject <- ProjectUtils.expectRemoteProjectByName projectName remoteProject <- ProjectUtils.expectRemoteProjectByName projectName
let remoteProjectId = remoteProject ^. #projectId let remoteProjectId = remoteProject.projectId
branchName <- branchName <-
case branchNameOrLatestRelease of case branchNameOrLatestRelease of
ProjectBranchNameOrLatestRelease'Name name -> pure name ProjectBranchNameOrLatestRelease'Name name -> pure name
@ -210,11 +241,10 @@ resolveExplicitSource includeSquashed = \case
(ProjectAndBranch (remoteProjectId, projectName) branchName) (ProjectAndBranch (remoteProjectId, projectName) branchName)
pure (ReadShare'ProjectBranch remoteProjectBranch) pure (ReadShare'ProjectBranch remoteProjectBranch)
resolveImplicitTarget :: Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
resolveImplicitTarget = resolveImplicitTarget = do
ProjectUtils.getCurrentProjectBranch <&> \case (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
Nothing -> Left Path.currentPath pure projectAndBranch
Just (projectAndBranch, _restPath) -> Right projectAndBranch
-- | supply `dest0` if you want to print diff messages -- | supply `dest0` if you want to print diff messages
-- supply unchangedMessage if you want to display it if merge had no effect -- supply unchangedMessage if you want to display it if merge had no effect

View File

@ -1,13 +1,11 @@
-- | @push@ input handler -- | @push@ input handler
module Unison.Codebase.Editor.HandleInput.Push module Unison.Codebase.Editor.HandleInput.Push
( handleGist, ( handlePushRemoteBranch,
handlePushRemoteBranch,
) )
where where
import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO) import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO)
import Control.Lens (over, view, (.~), (^.), _1, _2) import Control.Lens (over, view, (.~), (^.), _1, _2)
import Control.Monad.Reader (ask)
import Data.Set.NonEmpty qualified as Set.NonEmpty import Data.Set.NonEmpty qualified as Set.NonEmpty
import Data.Text as Text import Data.Text as Text
import Data.These (These (..)) 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.ProjectUtils qualified as ProjectUtils
import Unison.Cli.Share.Projects qualified as Share import Unison.Cli.Share.Projects qualified as Share
import Unison.Cli.UnisonConfigUtils qualified as UnisonConfigUtils 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.HandleInput.AuthLogin qualified as AuthLogin
import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Input
( GistInput (..), ( PushRemoteBranchInput (..),
PushRemoteBranchInput (..),
PushSource (..), PushSource (..),
PushSourceTarget (..), PushSourceTarget (..),
) )
@ -40,20 +34,13 @@ import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.Output.PushPull (PushPull (Push)) import Unison.Codebase.Editor.Output.PushPull (PushPull (Push))
import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..), ( WriteRemoteNamespace (..),
ReadRemoteNamespace (..),
WriteGitRemoteNamespace (..),
WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..), WriteShareRemoteNamespace (..),
writeToReadGit,
) )
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.PushBehavior (PushBehavior)
import Unison.Codebase.PushBehavior qualified as 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.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
import Unison.Hash qualified as Hash
import Unison.Hash32 (Hash32) import Unison.Hash32 (Hash32)
import Unison.Hash32 qualified as Hash32 import Unison.Hash32 qualified as Hash32
import Unison.Prelude import Unison.Prelude
@ -75,25 +62,6 @@ import Unison.Sqlite qualified as Sqlite
import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Share
import Witch (unsafeFrom) 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. -- | Handle a @push@ command.
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli () handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
@ -104,7 +72,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
Nothing -> do Nothing -> do
localPath <- Cli.getCurrentPath localPath <- Cli.getCurrentPath
UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case
WriteRemoteNamespaceGit namespace -> pushLooseCodeToGitLooseCode localPath namespace pushBehavior
WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior
WriteRemoteProjectBranch v -> absurd v WriteRemoteProjectBranch v -> absurd v
Just (localProjectAndBranch, _restPath) -> Just (localProjectAndBranch, _restPath) ->
@ -112,10 +79,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
force force
localProjectAndBranch localProjectAndBranch
Nothing Nothing
-- push <implicit> to .some.path (git)
PushSourceTarget1 (WriteRemoteNamespaceGit namespace) -> do
localPath <- Cli.getCurrentPath
pushLooseCodeToGitLooseCode localPath namespace pushBehavior
-- push <implicit> to .some.path (share) -- push <implicit> to .some.path (share)
PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do
localPath <- Cli.getCurrentPath localPath <- Cli.getCurrentPath
@ -129,10 +92,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
Just (localProjectAndBranch, _restPath) -> Just (localProjectAndBranch, _restPath) ->
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) 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) -- push .some.path to .some.path (share)
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do
localPath <- Cli.resolvePath' localPath0 localPath <- Cli.resolvePath' localPath0
@ -142,13 +101,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
localPath <- Cli.resolvePath' localPath0 localPath <- Cli.resolvePath' localPath0
remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0 remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch 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) -- push @some/project to .some.path (share)
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
@ -167,49 +119,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
PushBehavior.RequireEmpty -> False PushBehavior.RequireEmpty -> False
PushBehavior.RequireNonEmpty -> 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"). -- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code").
pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli () pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli ()
pushLooseCodeToShareLooseCode _ _ _ = do pushLooseCodeToShareLooseCode _ _ _ = do
@ -649,10 +558,11 @@ makeSetHeadAfterUploadAction ::
Share.RemoteProjectBranch -> Share.RemoteProjectBranch ->
Cli AfterUploadAction Cli AfterUploadAction
makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do 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 when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do
Cli.returnEarly (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames) Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames)
Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName)))
when (not force) do when (not force) do
whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do

View File

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

View File

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

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.Input (TestInput (..))
import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as 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.Codebase.Runtime qualified as Runtime
import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorReference (GConstructorReference (..))
import Unison.HashQualified qualified as HQ import Unison.HashQualified qualified as HQ
@ -38,6 +40,7 @@ import Unison.Parser.Ann (Ann)
import Unison.Prelude import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Reference (TermReferenceId)
import Unison.Reference qualified as Reference import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent import Unison.Referent qualified as Referent
import Unison.ShortHash qualified as SH 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.Relation qualified as R
import Unison.Util.Set qualified as Set import Unison.Util.Set qualified as Set
import Unison.WatchKind qualified as WK 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. -- | Handle a @test@ command.
-- Run pure tests in the current subnamespace. -- Run pure tests in the current subnamespace.
@ -137,7 +137,7 @@ handleIOTest main = do
(fails, oks) <- (fails, oks) <-
refs & foldMapM \(ref, typ) -> do refs & foldMapM \(ref, typ) -> do
when (not $ isIOTest 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 runIOTest suffixifiedPPE ref
Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails

View File

@ -10,6 +10,7 @@ import Data.List.NonEmpty (pattern (:|))
import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Text qualified as Text import Data.Text qualified as Text
import Text.Builder qualified
import U.Codebase.Sqlite.DbId (ProjectId) import U.Codebase.Sqlite.DbId (ProjectId)
import Unison.Cli.Monad (Cli) import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli import Unison.Cli.Monad qualified as Cli
@ -169,8 +170,7 @@ handleUpgrade oldName newName = do
Nothing -> "scratch.u" Nothing -> "scratch.u"
Just (file, _) -> file Just (file, _) -> file
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
Cli.respond (Output.UpgradeFailure scratchFilePath oldName newName) Cli.returnEarly (Output.UpgradeFailure scratchFilePath oldName newName)
Cli.returnEarlyWithoutOutput
branchUpdates <- branchUpdates <-
Cli.runTransactionWithRollback \abort -> do Cli.runTransactionWithRollback \abort -> do
@ -267,12 +267,25 @@ makeOldDepPPE oldName newName currentDeepNamesSansOld oldDeepNames oldLocalNames
-- like "upgrade-<oldDepName>-to-<newDepName>". -- like "upgrade-<oldDepName>-to-<newDepName>".
findTemporaryBranchName :: ProjectId -> NameSegment -> NameSegment -> Transaction ProjectBranchName findTemporaryBranchName :: ProjectId -> NameSegment -> NameSegment -> Transaction ProjectBranchName
findTemporaryBranchName projectId oldDepName newDepName = do findTemporaryBranchName projectId oldDepName newDepName = do
Cli.findTemporaryBranchName projectId preferred Cli.findTemporaryBranchName projectId $
-- First try something like
--
-- upgrade-unison_base_3_0_0-to-unison_base_4_0_0
--
-- and if that fails (which it shouldn't, but may because of symbols or something), back off to some
-- more-guaranteed-to-work mangled name like
--
-- upgrade-unisonbase300-to-unisonbase400
tryFrom @Text (mk oldDepText newDepText)
& fromRight (unsafeFrom @Text (mk (scrub oldDepText) (scrub newDepText)))
where where
preferred :: ProjectBranchName mk :: Text -> Text -> Text
preferred = mk old new =
unsafeFrom @Text $ Text.Builder.run ("upgrade-" <> Text.Builder.text old <> "-to-" <> Text.Builder.text new)
"upgrade-"
<> Text.filter Char.isAlpha (NameSegment.toEscapedText oldDepName) scrub :: Text -> Text
<> "-to-" scrub =
<> Text.filter Char.isAlpha (NameSegment.toEscapedText newDepName) Text.filter Char.isAlphaNum
oldDepText = NameSegment.toEscapedText oldDepName
newDepText = NameSegment.toEscapedText newDepName

View File

@ -1,8 +1,6 @@
module Unison.Codebase.Editor.Input module Unison.Codebase.Editor.Input
( Input (..), ( Input (..),
BranchSourceI (..), BranchSourceI (..),
DiffNamespaceToPatchInput (..),
GistInput (..),
PullSourceTarget (..), PullSourceTarget (..),
PushRemoteBranchInput (..), PushRemoteBranchInput (..),
PushSourceTarget (..), PushSourceTarget (..),
@ -32,16 +30,14 @@ where
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Text qualified as Text import Data.Text qualified as Text
import Data.These (These) import Data.These (These)
import U.Codebase.HashTags (CausalHash)
import Unison.Codebase.Branch.Merge qualified as Branch 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 (Path, Path')
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.Path.Parse qualified as Path
import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.PushBehavior (PushBehavior)
import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.Codebase.Verbosity (Verbosity)
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath) import Unison.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath)
import Unison.HashQualified qualified as HQ import Unison.HashQualified qualified as HQ
import Unison.Name (Name) import Unison.Name (Name)
@ -53,7 +49,6 @@ import Unison.Util.Pretty qualified as P
data Event data Event
= UnisonFileChanged SourceName Source = UnisonFileChanged SourceName Source
| IncomingRootBranch (Set CausalHash)
deriving stock (Show) deriving stock (Show)
type Source = Text -- "id x = x\nconst a b = a" type Source = Text -- "id x = x\nconst a b = a"
@ -114,7 +109,7 @@ data Input
MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode
| PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject | PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject
| DiffNamespaceI BranchId BranchId -- old new | DiffNamespaceI BranchId BranchId -- old new
| PullRemoteBranchI PullSourceTarget PullMode Verbosity | PullI !PullSourceTarget !PullMode
| PushRemoteBranchI PushRemoteBranchInput | PushRemoteBranchI PushRemoteBranchInput
| ResetRootI (Either ShortCausalHash Path') | ResetRootI (Either ShortCausalHash Path')
| ResetI | ResetI
@ -145,8 +140,6 @@ data Input
MoveTermI Path.HQSplit' Path.Split' MoveTermI Path.HQSplit' Path.Split'
| MoveTypeI Path.HQSplit' Path.Split' | MoveTypeI Path.HQSplit' Path.Split'
| MoveBranchI Path.Path' Path.Path' | MoveBranchI Path.Path' Path.Path'
| MovePatchI Path.Split' Path.Split'
| CopyPatchI Path.Split' Path.Split'
| -- delete = unname | -- delete = unname
DeleteI DeleteTarget DeleteI DeleteTarget
| -- edits stuff: | -- edits stuff:
@ -158,20 +151,12 @@ data Input
| Update2I | Update2I
| PreviewUpdateI (Set Name) | PreviewUpdateI (Set Name)
| TodoI (Maybe PatchPath) Path' | 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 | UndoI
| -- First `Maybe Int` is cap on number of results, if any | -- First `Maybe Int` is cap on number of results, if any
-- Second `Maybe Int` is cap on diff elements shown, if any -- Second `Maybe Int` is cap on diff elements shown, if any
HistoryI (Maybe Int) (Maybe Int) BranchId HistoryI (Maybe Int) (Maybe Int) BranchId
| -- execute an IO thunk with args | -- execute an IO thunk with args
ExecuteI Text [String] ExecuteI (HQ.HashQualified Name) [String]
| -- save the result of a previous Execute | -- save the result of a previous Execute
SaveExecuteResultI Name SaveExecuteResultI Name
| -- execute an IO [Result] | -- execute an IO [Result]
@ -181,7 +166,7 @@ data Input
| -- make a standalone binary file | -- make a standalone binary file
MakeStandaloneI String (HQ.HashQualified Name) MakeStandaloneI String (HQ.HashQualified Name)
| -- execute an IO thunk using scheme | -- execute an IO thunk using scheme
ExecuteSchemeI Text [String] ExecuteSchemeI (HQ.HashQualified Name) [String]
| -- compile to a scheme file | -- compile to a scheme file
CompileSchemeI Text (HQ.HashQualified Name) CompileSchemeI Text (HQ.HashQualified Name)
| TestI TestInput | TestI TestInput
@ -189,16 +174,14 @@ data Input
| -- Display provided definitions. | -- Display provided definitions.
DisplayI OutputLocation (NonEmpty (HQ.HashQualified Name)) DisplayI OutputLocation (NonEmpty (HQ.HashQualified Name))
| -- Display docs for provided terms. | -- Display docs for provided terms.
DocsI (NonEmpty Path.HQSplit') DocsI (NonEmpty Name)
| -- other | -- other
FindI Bool FindScope [String] -- FindI isVerbose findScope query FindI Bool FindScope [String] -- FindI isVerbose findScope query
| FindShallowI Path' | FindShallowI Path'
| FindPatchI
| StructuredFindI FindScope (HQ.HashQualified Name) -- sfind findScope query | StructuredFindI FindScope (HQ.HashQualified Name) -- sfind findScope query
| StructuredFindReplaceI (HQ.HashQualified Name) -- sfind.replace rewriteQuery | StructuredFindReplaceI (HQ.HashQualified Name) -- sfind.replace rewriteQuery
| -- Show provided definitions. | -- Show provided definitions.
ShowDefinitionI OutputLocation ShowDefinitionScope (NonEmpty (HQ.HashQualified Name)) ShowDefinitionI OutputLocation ShowDefinitionScope (NonEmpty (HQ.HashQualified Name))
| ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified Name]
| ShowReflogI | ShowReflogI
| UpdateBuiltinsI | UpdateBuiltinsI
| MergeBuiltinsI (Maybe Path) | MergeBuiltinsI (Maybe Path)
@ -226,10 +209,8 @@ data Input
| UiI Path' | UiI Path'
| DocToMarkdownI Name | DocToMarkdownI Name
| DocsToHtmlI Path' FilePath | DocsToHtmlI Path' FilePath
| GistI GistInput
| AuthLoginI | AuthLoginI
| VersionI | VersionI
| DiffNamespaceToPatchI DiffNamespaceToPatchInput
| ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName) | ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName)
| ProjectRenameI ProjectName | ProjectRenameI ProjectName
| ProjectSwitchI ProjectAndBranchNames | ProjectSwitchI ProjectAndBranchNames
@ -244,6 +225,7 @@ data Input
| -- New merge algorithm: merge the given project branch into the current one. | -- New merge algorithm: merge the given project branch into the current one.
MergeI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) MergeI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
| LibInstallI !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) | LibInstallI !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease))
| UpgradeCommitI
deriving (Eq, Show) deriving (Eq, Show)
-- | The source of a `branch` command: what to make the new branch from. -- | The source of a `branch` command: what to make the new branch from.
@ -256,27 +238,11 @@ data BranchSourceI
BranchSourceI'LooseCodeOrProject LooseCodeOrProject BranchSourceI'LooseCodeOrProject LooseCodeOrProject
deriving stock (Eq, Show) 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. -- | Pull source and target: either neither is specified, or only a source, or both.
data PullSourceTarget data PullSourceTarget
= PullSourceTarget0 = PullSourceTarget0
| PullSourceTarget1 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) | PullSourceTarget1 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease))
| PullSourceTarget2 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) LooseCodeOrProject | PullSourceTarget2 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
deriving stock (Eq, Show) deriving stock (Eq, Show)
data PushSource data PushSource
@ -335,8 +301,7 @@ data DeleteTarget
= DeleteTarget'TermOrType DeleteOutput [Path.HQSplit'] = DeleteTarget'TermOrType DeleteOutput [Path.HQSplit']
| DeleteTarget'Term DeleteOutput [Path.HQSplit'] | DeleteTarget'Term DeleteOutput [Path.HQSplit']
| DeleteTarget'Type DeleteOutput [Path.HQSplit'] | DeleteTarget'Type DeleteOutput [Path.HQSplit']
| DeleteTarget'Namespace Insistence (Maybe Path.Split') | DeleteTarget'Namespace Insistence (Maybe Path.Split)
| DeleteTarget'Patch Path.Split'
| DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
| DeleteTarget'Project ProjectName | DeleteTarget'Project ProjectName
deriving stock (Eq, Show) deriving stock (Eq, Show)

View File

@ -17,7 +17,6 @@ module Unison.Codebase.Editor.Output
where where
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty (NESet)
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Network.URI (URI) import Network.URI (URI)
@ -28,6 +27,7 @@ import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import Unison.Auth.Types (CredentialFailure) import Unison.Auth.Types (CredentialFailure)
import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget)
import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Cli.Share.Projects.Types qualified as Share
import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Input
import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput)
@ -36,16 +36,15 @@ import Unison.Codebase.Editor.Output.PushPull (PushPull)
import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.RemoteRepo
import Unison.Codebase.Editor.SlurpResult (SlurpResult (..)) import Unison.Codebase.Editor.SlurpResult (SlurpResult (..))
import Unison.Codebase.Editor.SlurpResult qualified as SR 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.Editor.TodoOutput qualified as TO
import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) import Unison.Codebase.IntegrityCheck (IntegrityResult (..))
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path') import Unison.Codebase.Path (Path')
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.PushBehavior (PushBehavior)
import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.Codebase.Type (GitError)
import Unison.CommandLine.InputPattern qualified as Input import Unison.CommandLine.InputPattern qualified as Input
import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration qualified as DD
import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.DataDeclaration.ConstructorId (ConstructorId)
@ -62,7 +61,7 @@ import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnvDecl qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName, Semver) import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName, Semver)
import Unison.Reference (Reference, TermReferenceId) import Unison.Reference (Reference, TermReferenceId, TypeReference)
import Unison.Reference qualified as Reference import Unison.Reference qualified as Reference
import Unison.Referent (Referent) import Unison.Referent (Referent)
import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.Backend (ShallowListEntry (..))
@ -84,7 +83,12 @@ type ListDetailed = Bool
type SourceName = Text 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 type HashLength = Int
@ -127,7 +131,6 @@ data NumberedOutput
HashLength HashLength
[(CausalHash, Names.Diff)] [(CausalHash, Names.Diff)]
HistoryTail -- 'origin point' of this view of history. HistoryTail -- 'origin point' of this view of history.
| ListEdits Patch PPE.PrettyPrintEnv
| ListProjects [Sqlite.Project] | ListProjects [Sqlite.Project]
| ListBranches ProjectName [(ProjectBranchName, [(URI, ProjectName, ProjectBranchName)])] | ListBranches ProjectName [(ProjectBranchName, [(URI, ProjectName, ProjectBranchName)])]
| AmbiguousSwitch ProjectName (ProjectAndBranch ProjectName ProjectBranchName) | AmbiguousSwitch ProjectName (ProjectAndBranch ProjectName ProjectBranchName)
@ -154,13 +157,13 @@ data Output
| InvalidSourceName String | InvalidSourceName String
| SourceLoadFailed String | SourceLoadFailed String
| -- No main function, the [Type v Ann] are the allowed types | -- 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 | -- | Function found, but has improper type
-- Note: the constructor name is misleading here; we weren't necessarily looking for a "main". -- Note: the constructor name is misleading here; we weren't necessarily looking for a "main".
BadMainFunction BadMainFunction
Text Text
-- ^ what we were trying to do (e.g. "run", "io.test") -- ^ what we were trying to do (e.g. "run", "io.test")
Text (HQ.HashQualified Name)
-- ^ name of function -- ^ name of function
(Type Symbol Ann) (Type Symbol Ann)
-- ^ bad type of function -- ^ bad type of function
@ -172,7 +175,6 @@ data Output
| CreatedNewBranch Path.Absolute | CreatedNewBranch Path.Absolute
| BranchAlreadyExists Path' | BranchAlreadyExists Path'
| FindNoLocalMatches | FindNoLocalMatches
| PatchAlreadyExists Path.Split'
| NoExactTypeMatches | NoExactTypeMatches
| TypeAlreadyExists Path.Split' (Set Reference) | TypeAlreadyExists Path.Split' (Set Reference)
| TypeParseError String (Parser.Err Symbol) | TypeParseError String (Parser.Err Symbol)
@ -191,13 +193,11 @@ data Output
| EmptyProjectBranchPush (ProjectAndBranch ProjectName ProjectBranchName) | EmptyProjectBranchPush (ProjectAndBranch ProjectName ProjectBranchName)
| NameNotFound Path.HQSplit' | NameNotFound Path.HQSplit'
| NamesNotFound [Name] | NamesNotFound [Name]
| PatchNotFound Path.Split'
| TypeNotFound Path.HQSplit' | TypeNotFound Path.HQSplit'
| TermNotFound Path.HQSplit' | TermNotFound Path.HQSplit'
| MoveNothingFound Path' | MoveNothingFound Path'
| TypeNotFound' ShortHash | TypeNotFound' ShortHash
| TermNotFound' ShortHash | TermNotFound' ShortHash
| TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name)
| NoLastRunResult | NoLastRunResult
| SaveTermNameConflict Name | SaveTermNameConflict Name
| SearchTermsNotFound [HQ.HashQualified Name] | SearchTermsNotFound [HQ.HashQualified Name]
@ -230,7 +230,6 @@ data Output
-- list of all the definitions within this branch -- list of all the definitions within this branch
| ListOfDefinitions FindScope PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann] | ListOfDefinitions FindScope PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann]
| ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann] | ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann]
| ListOfPatches (Set Name)
| ListStructuredFind [HQ.HashQualified Name] | ListStructuredFind [HQ.HashQualified Name]
| -- ListStructuredFind patternMatchingUsages termBodyUsages | -- ListStructuredFind patternMatchingUsages termBodyUsages
-- show the result of add/update -- show the result of add/update
@ -267,32 +266,30 @@ data Output
-- todo: eventually replace these sets with [SearchResult' v Ann] -- todo: eventually replace these sets with [SearchResult' v Ann]
-- and a nicer render. -- and a nicer render.
BustedBuiltins (Set Reference) (Set Reference) BustedBuiltins (Set Reference) (Set Reference)
| GitError GitError
| ShareError ShareError | ShareError ShareError
| ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName)) | ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName))
| NoConfiguredRemoteMapping PushPull Path.Absolute | NoConfiguredRemoteMapping PushPull Path.Absolute
| ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String | ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String
| TermMissingType Reference | TermMissingType Reference
| AboutToPropagatePatch | AboutToPropagatePatch
| -- todo: tell the user to run `todo` on the same patch they just used
NothingToPatch PatchPath Path'
| PatchNeedsToBeConflictFree | PatchNeedsToBeConflictFree
| PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference)
| WarnIncomingRootBranch ShortCausalHash (Set ShortCausalHash)
| StartOfCurrentPathHistory | StartOfCurrentPathHistory
| ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)] | ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)]
| PullAlreadyUpToDate | PullAlreadyUpToDate
(ReadRemoteNamespace Share.RemoteProjectBranch) (ReadRemoteNamespace Share.RemoteProjectBranch)
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
| PullSuccessful | PullSuccessful
(ReadRemoteNamespace Share.RemoteProjectBranch) (ReadRemoteNamespace Share.RemoteProjectBranch)
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
| AboutToMerge | AboutToMerge
| -- | Indicates a trivial merge where the destination was empty and was just replaced. | -- | Indicates a trivial merge where the destination was empty and was just replaced.
MergeOverEmpty (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) MergeOverEmpty (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
| MergeAlreadyUpToDate | MergeAlreadyUpToDate
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) (Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) (Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
| -- This will replace the above once `merge.old` is deleted
MergeAlreadyUpToDate2 !MergeSourceAndTarget
| PreviewMergeAlreadyUpToDate | PreviewMergeAlreadyUpToDate
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
@ -303,7 +300,7 @@ data Output
| ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms | ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
| -- | List dependents of a type or term. | -- | List dependents of a type or term.
ListDependents PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms ListDependents PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
| DumpNumberedArgs NumberedArgs | DumpNumberedArgs HashLength NumberedArgs
| DumpBitBooster CausalHash (Map CausalHash [CausalHash]) | DumpBitBooster CausalHash (Map CausalHash [CausalHash])
| DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)]
| BadName Text | BadName Text
@ -395,20 +392,20 @@ data Output
| UpgradeFailure !FilePath !NameSegment !NameSegment | UpgradeFailure !FilePath !NameSegment !NameSegment
| UpgradeSuccess !NameSegment !NameSegment | UpgradeSuccess !NameSegment !NameSegment
| LooseCodePushDeprecated | LooseCodePushDeprecated
| MergeFailure !FilePath !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) | MergeFailure !FilePath !MergeSourceAndTarget
| MergeSuccess !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) | MergeSuccess !MergeSourceAndTarget
| MergeSuccessFastForward !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) | MergeSuccessFastForward !MergeSourceAndTarget
| -- These are all merge precondition violations. See PreconditionViolation for more docs. | MergeConflictedAliases !MergeSourceOrTarget !Name !Name
MergeConflictedAliases !ProjectBranchName !Name !Name | MergeConflictedTermName !Name !(NESet Referent)
| MergeConflictedTermName !Name !(Set Referent) | MergeConflictedTypeName !Name !(NESet TypeReference)
| MergeConflictedTypeName !Name !(Set Reference.TypeReference)
| MergeConflictInvolvingBuiltin !Name | MergeConflictInvolvingBuiltin !Name
| MergeConstructorAlias !(Maybe ProjectBranchName) !Name !Name | MergeConstructorAlias !MergeSourceOrTarget !Name !Name !Name
| MergeDefnsInLib | MergeDefnsInLib !MergeSourceOrTarget
| MergeMissingConstructorName !Name | MergeMissingConstructorName !MergeSourceOrTarget !Name
| MergeNestedDeclAlias !Name !Name | MergeNestedDeclAlias !MergeSourceOrTarget !Name !Name
| MergeStrayConstructor !Name | MergeStrayConstructor !MergeSourceOrTarget !Name
| InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment | InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment
| NoUpgradeInProgress
data UpdateOrUpgrade = UOUUpdate | UOUUpgrade data UpdateOrUpgrade = UOUUpdate | UOUUpgrade
@ -487,7 +484,6 @@ isFailure o = case o of
BranchAlreadyExists {} -> True BranchAlreadyExists {} -> True
-- we do a global search after finding no local matches, so let's not call this a failure yet -- we do a global search after finding no local matches, so let's not call this a failure yet
FindNoLocalMatches {} -> False FindNoLocalMatches {} -> False
PatchAlreadyExists {} -> True
NoExactTypeMatches -> True NoExactTypeMatches -> True
BranchEmpty {} -> True BranchEmpty {} -> True
EmptyLooseCodePush {} -> True EmptyLooseCodePush {} -> True
@ -507,13 +503,11 @@ isFailure o = case o of
BranchNotFound {} -> True BranchNotFound {} -> True
NameNotFound {} -> True NameNotFound {} -> True
NamesNotFound _ -> True NamesNotFound _ -> True
PatchNotFound {} -> True
TypeNotFound {} -> True TypeNotFound {} -> True
TypeNotFound' {} -> True TypeNotFound' {} -> True
TermNotFound {} -> True TermNotFound {} -> True
MoveNothingFound {} -> True MoveNothingFound {} -> True
TermNotFound' {} -> True TermNotFound' {} -> True
TypeTermMismatch {} -> True
SearchTermsNotFound ts -> not (null ts) SearchTermsNotFound ts -> not (null ts)
SearchTermsNotFoundDetailed _ misses otherHits -> not (null misses && null otherHits) SearchTermsNotFoundDetailed _ misses otherHits -> not (null misses && null otherHits)
DeleteBranchConfirmation {} -> False DeleteBranchConfirmation {} -> False
@ -523,7 +517,6 @@ isFailure o = case o of
DeletedEverything -> False DeletedEverything -> False
ListNames _ _ tys tms -> null tms && null tys ListNames _ _ tys tms -> null tms && null tys
ListOfDefinitions _ _ _ ds -> null ds ListOfDefinitions _ _ _ ds -> null ds
ListOfPatches s -> Set.null s
ListStructuredFind tms -> null tms ListStructuredFind tms -> null tms
SlurpOutput _ _ sr -> not $ SR.isOk sr SlurpOutput _ _ sr -> not $ SR.isOk sr
ParseErrors {} -> True ParseErrors {} -> True
@ -541,15 +534,12 @@ isFailure o = case o of
TestIncrementalOutputEnd {} -> False TestIncrementalOutputEnd {} -> False
TestResults _ _ _ _ _ fails -> not (null fails) TestResults _ _ _ _ _ fails -> not (null fails)
CantUndo {} -> True CantUndo {} -> True
GitError {} -> True
BustedBuiltins {} -> True BustedBuiltins {} -> True
NoConfiguredRemoteMapping {} -> True NoConfiguredRemoteMapping {} -> True
ConfiguredRemoteMappingParseError {} -> True ConfiguredRemoteMappingParseError {} -> True
PatchNeedsToBeConflictFree {} -> True PatchNeedsToBeConflictFree {} -> True
PatchInvolvesExternalDependents {} -> True PatchInvolvesExternalDependents {} -> True
AboutToPropagatePatch {} -> False AboutToPropagatePatch {} -> False
NothingToPatch {} -> False
WarnIncomingRootBranch {} -> False
StartOfCurrentPathHistory -> True StartOfCurrentPathHistory -> True
NotImplemented -> True NotImplemented -> True
DumpNumberedArgs {} -> False DumpNumberedArgs {} -> False
@ -560,6 +550,7 @@ isFailure o = case o of
AboutToMerge {} -> False AboutToMerge {} -> False
MergeOverEmpty {} -> False MergeOverEmpty {} -> False
MergeAlreadyUpToDate {} -> False MergeAlreadyUpToDate {} -> False
MergeAlreadyUpToDate2 {} -> False
PreviewMergeAlreadyUpToDate {} -> False PreviewMergeAlreadyUpToDate {} -> False
NoConflictsOrEdits {} -> False NoConflictsOrEdits {} -> False
ListShallow _ es -> null es ListShallow _ es -> null es
@ -646,11 +637,12 @@ isFailure o = case o of
MergeConflictedTypeName {} -> True MergeConflictedTypeName {} -> True
MergeConflictInvolvingBuiltin {} -> True MergeConflictInvolvingBuiltin {} -> True
MergeConstructorAlias {} -> True MergeConstructorAlias {} -> True
MergeDefnsInLib -> True MergeDefnsInLib {} -> True
MergeMissingConstructorName {} -> True MergeMissingConstructorName {} -> True
MergeNestedDeclAlias {} -> True MergeNestedDeclAlias {} -> True
MergeStrayConstructor {} -> True MergeStrayConstructor {} -> True
InstalledLibdep {} -> False InstalledLibdep {} -> False
NoUpgradeInProgress {} -> True
isNumberedFailure :: NumberedOutput -> Bool isNumberedFailure :: NumberedOutput -> Bool
isNumberedFailure = \case isNumberedFailure = \case
@ -661,7 +653,6 @@ isNumberedFailure = \case
DeletedDespiteDependents {} -> False DeletedDespiteDependents {} -> False
History {} -> False History {} -> False
ListBranches {} -> False ListBranches {} -> False
ListEdits {} -> False
ListProjects {} -> False ListProjects {} -> False
ShowDiffAfterCreateAuthor {} -> False ShowDiffAfterCreateAuthor {} -> False
ShowDiffAfterDeleteBranch {} -> False ShowDiffAfterDeleteBranch {} -> False

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)

View File

@ -1,36 +1,26 @@
module Unison.Codebase.Editor.UriParser module Unison.Codebase.Editor.UriParser
( readRemoteNamespaceParser, ( readRemoteNamespaceParser,
writeGitRepo,
deprecatedWriteGitRemoteNamespace,
writeRemoteNamespace, writeRemoteNamespace,
writeRemoteNamespaceWith, writeRemoteNamespaceWith,
parseReadShareLooseCode, parseReadShareLooseCode,
) )
where where
import Data.Char (isAlphaNum, isDigit, isSpace) import Data.Char (isAlphaNum)
import Data.Sequence as Seq
import Data.Text qualified as Text import Data.Text qualified as Text
import Data.These (These) import Data.These (These)
import Data.Void import Data.Void
import Text.Megaparsec qualified as P import Text.Megaparsec qualified as P
import Text.Megaparsec.Char qualified as C import Text.Megaparsec.Char qualified as C
import U.Util.Base32Hex qualified as Base32Hex
import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..), ( ReadRemoteNamespace (..),
ReadGitRepo (..),
ReadRemoteNamespace (..),
ReadShareLooseCode (..), ReadShareLooseCode (..),
ShareCodeserver (DefaultCodeserver), ShareCodeserver (DefaultCodeserver),
ShareUserHandle (..), ShareUserHandle (..),
WriteGitRemoteNamespace (..),
WriteGitRepo (..),
WriteRemoteNamespace (..), WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..), WriteShareRemoteNamespace (..),
) )
import Unison.Codebase.Path (Path (..))
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
import Unison.NameSegment (NameSegment) import Unison.NameSegment (NameSegment)
import Unison.Prelude import Unison.Prelude
import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser)
@ -41,30 +31,10 @@ import Unison.Util.Pretty.MegaParsec qualified as P
type P = P.Parsec Void Text.Text 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 :: ProjectBranchSpecifier branch -> P (ReadRemoteNamespace (These ProjectName branch))
readRemoteNamespaceParser specifier = readRemoteNamespaceParser specifier =
P.label "generic repo" $ ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier
ReadRemoteNamespaceGit <$> readGitRemoteNamespace <|> ReadShare'LooseCode <$> readShareLooseCode
<|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier
<|> ReadShare'LooseCode <$> readShareLooseCode
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths :: projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ::
ProjectBranchSpecifier branch -> ProjectBranchSpecifier branch ->
@ -82,9 +52,7 @@ parseReadShareLooseCode label input =
in first printError (P.parse readShareLooseCode label (Text.pack input)) in first printError (P.parse readShareLooseCode label (Text.pack input))
-- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4" -- >>> 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 (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 :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName))
writeRemoteNamespace = writeRemoteNamespace =
writeRemoteNamespaceWith writeRemoteNamespaceWith
@ -92,8 +60,7 @@ writeRemoteNamespace =
writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a) writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a)
writeRemoteNamespaceWith projectBranchParser = writeRemoteNamespaceWith projectBranchParser =
WriteRemoteNamespaceGit <$> writeGitRemoteNamespace WriteRemoteProjectBranch <$> projectBranchParser
<|> WriteRemoteProjectBranch <$> projectBranchParser
<|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace <|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace
-- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4" -- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4"
@ -109,7 +76,7 @@ writeShareRemoteNamespace =
-- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4" -- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4"
-- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4" -- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4"
-- Nothing -- Nothing
-- Just (ReadShareLooseCode {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}) -- Just (ReadShareLooseCode {server = DefaultCodeserver, repo = ShareUserHandle {shareUserHandleToText = "unisonweb"}, path = base._releases.M4})
readShareLooseCode :: P ReadShareLooseCode readShareLooseCode :: P ReadShareLooseCode
readShareLooseCode = do readShareLooseCode = do
P.label "read share loose code" $ P.label "read share loose code" $
@ -131,252 +98,15 @@ shareUserHandle :: P ShareUserHandle
shareUserHandle = do shareUserHandle = do
ShareUserHandle . Text.pack <$> P.some (P.satisfy \c -> isAlphaNum c || c == '-' || c == '_') 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 data Scheme = Ssh | Https
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
data User = User Text data User = User Text
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
type UrlPath = Text
data HostInfo = HostInfo Text (Maybe Text) data HostInfo = HostInfo Text (Maybe Text)
deriving (Eq, Ord, Show) 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 :: P NameSegment
nameSegment = nameSegment =
NameSegment.unsafeParseText . Text.pack NameSegment.unsafeParseText . Text.pack
@ -384,14 +114,3 @@ nameSegment =
<$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar <$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar
<*> P.many (P.satisfy Unison.Syntax.Lexer.wordyIdChar) <*> 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)

View File

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

View File

@ -4,8 +4,10 @@
module Unison.CommandLine.InputPattern module Unison.CommandLine.InputPattern
( InputPattern (..), ( InputPattern (..),
Argument,
ArgumentType (..), ArgumentType (..),
ArgumentDescription, ArgumentDescription,
Arguments,
argType, argType,
FZFResolver (..), FZFResolver (..),
IsOptional (..), IsOptional (..),
@ -25,6 +27,7 @@ import System.Console.Haskeline qualified as Line
import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Codebase (Codebase) import Unison.Codebase (Codebase)
import Unison.Codebase.Editor.Input (Input (..)) import Unison.Codebase.Editor.Input (Input (..))
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
import Unison.Codebase.Path as Path import Unison.Codebase.Path as Path
import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.CommandLine.FZFResolvers (FZFResolver (..))
import Unison.Prelude import Unison.Prelude
@ -44,6 +47,14 @@ data IsOptional
data Visibility = Hidden | Visible data Visibility = Hidden | Visible
deriving (Show, Eq, Ord) 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 doesnt need to be parsed, as
-- weve 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 -- | Argument description
-- It should fit grammatically into sentences like "I was expecting an argument for the <argDesc>" -- 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. -- 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 visibility :: Visibility, -- Allow hiding certain commands when debugging or work-in-progress
args :: [(ArgumentDescription, IsOptional, ArgumentType)], args :: [(ArgumentDescription, IsOptional, ArgumentType)],
help :: P.Pretty CT.ColorText, help :: P.Pretty CT.ColorText,
parse :: [String] -> Either (P.Pretty CT.ColorText) Input parse :: Arguments -> Either (P.Pretty CT.ColorText) Input
} }
data ArgumentType = ArgumentType data ArgumentType = ArgumentType

File diff suppressed because it is too large Load Diff

View File

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

View File

@ -6,9 +6,7 @@
module Unison.CommandLine.OutputMessages where module Unison.CommandLine.OutputMessages where
import Control.Lens hiding (at) import Control.Lens hiding (at)
import Control.Monad.State
import Control.Monad.State.Strict qualified as 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.ByteString.Lazy qualified as LazyByteString
import Data.Foldable qualified as Foldable import Data.Foldable qualified as Foldable
import Data.List (stripPrefix) import Data.List (stripPrefix)
@ -37,10 +35,12 @@ import U.Codebase.Branch (NamespaceStats (..))
import U.Codebase.Branch.Diff (NameChanges (..)) import U.Codebase.Branch.Diff (NameChanges (..))
import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Reference qualified as Reference 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 import Unison.ABT qualified as ABT
import Unison.Auth.Types qualified as Auth import Unison.Auth.Types qualified as Auth
import Unison.Builtin.Decls qualified as DD import Unison.Builtin.Decls qualified as DD
import Unison.Cli.MergeTypes (MergeSourceAndTarget (..))
import Unison.Cli.Pretty import Unison.Cli.Pretty
import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.ServantClientUtils qualified as ServantClientUtils import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
@ -61,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 (ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..))
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult 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.Editor.TodoOutput qualified as TO
import Unison.Codebase.GitError
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors) import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors)
import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch (Patch (..))
import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Patch qualified as Patch
@ -72,11 +73,7 @@ import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.Codebase.SqliteCodebase.GitError
( GitSqliteCodebaseError (..),
)
import Unison.Codebase.TermEdit qualified as TermEdit import Unison.Codebase.TermEdit qualified as TermEdit
import Unison.Codebase.Type (GitError (GitCodebaseError, GitProtocolError, GitSqliteCodebaseError))
import Unison.Codebase.TypeEdit qualified as TypeEdit import Unison.Codebase.TypeEdit qualified as TypeEdit
import Unison.CommandLine (bigproblem, note, tip) import Unison.CommandLine (bigproblem, note, tip)
import Unison.CommandLine.FZFResolvers qualified as FZFResolvers import Unison.CommandLine.FZFResolvers qualified as FZFResolvers
@ -127,7 +124,6 @@ import Unison.Server.Backend qualified as Backend
import Unison.Server.SearchResult' qualified as SR' import Unison.Server.SearchResult' qualified as SR'
import Unison.Share.Sync qualified as Share import Unison.Share.Sync qualified as Share
import Unison.Share.Sync.Types (CodeserverTransportError (..)) import Unison.Share.Sync.Types (CodeserverTransportError (..))
import Unison.ShortHash qualified as ShortHash
import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Share
import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.DeclPrinter qualified as DeclPrinter
import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar) import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar)
@ -348,7 +344,7 @@ notifyNumbered = \case
] ]
branchHashes :: [CausalHash] branchHashes :: [CausalHash]
branchHashes = (fst <$> reversedHistory) <> tailHashes branchHashes = (fst <$> reversedHistory) <> tailHashes
in (msg, displayBranchHash <$> branchHashes) in (msg, SA.Namespace <$> branchHashes)
where where
toSCH :: CausalHash -> ShortCausalHash toSCH :: CausalHash -> ShortCausalHash
toSCH h = SCH.fromHash schLength h toSCH h = SCH.fromHash schLength h
@ -404,10 +400,9 @@ notifyNumbered = \case
], ],
numberedArgsForEndangerments ppeDecl endangerments numberedArgsForEndangerments ppeDecl endangerments
) )
ListEdits patch ppe -> showListEdits patch ppe
ListProjects projects -> ListProjects projects ->
( P.numberedList (map (prettyProjectName . view #name) 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 -> ListBranches projectName branches ->
( P.columnNHeader ( P.columnNHeader
@ -423,7 +418,9 @@ notifyNumbered = \case
] ]
: map (\branch -> ["", "", prettyRemoteBranchInfo branch]) remoteBranches : 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) -> AmbiguousSwitch project (ProjectAndBranch currentProject branch) ->
( P.wrap ( P.wrap
@ -448,8 +445,9 @@ notifyNumbered = \case
<> switch ["2"] <> switch ["2"]
<> " to pick one of these." <> " to pick one of these."
), ),
[ Text.unpack (Text.cons '/' (into @Text branch)), [ SA.ProjectBranch $ ProjectAndBranch Nothing branch,
Text.unpack (into @Text (ProjectAndBranch project (UnsafeProjectBranchName "main"))) SA.ProjectBranch . ProjectAndBranch (pure project) $
UnsafeProjectBranchName "main"
] ]
) )
where where
@ -478,8 +476,8 @@ notifyNumbered = \case
<> reset (resetArgs ["2"]) <> reset (resetArgs ["2"])
<> " to pick one of these." <> " to pick one of these."
), ),
[ Text.unpack (Text.cons '/' (into @Text branch)), [ SA.ProjectBranch $ ProjectAndBranch Nothing branch,
Text.unpack (into @Text (show absPath0)) SA.AbsolutePath absPath0
] ]
) )
where where
@ -515,13 +513,13 @@ notifyNumbered = \case
newNextNum = nextNum + length unnumberedNames newNextNum = nextNum + length unnumberedNames
in ( newNextNum, in ( newNextNum,
( nameToNum <> (Map.fromList (zip unnumberedNames [nextNum ..])), ( nameToNum <> (Map.fromList (zip unnumberedNames [nextNum ..])),
args <> fmap Name.toText unnumberedNames args <> unnumberedNames
) )
) )
) )
(1, (mempty, mempty)) (1, (mempty, mempty))
& snd & 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 :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)]
externalDepsTable = ifoldMap $ \ld dependents -> externalDepsTable = ifoldMap $ \ld dependents ->
[(prettyLD ld, prettyDependents dependents)] [(prettyLD ld, prettyDependents dependents)]
@ -550,99 +548,6 @@ undoTip =
<> IP.makeExample' IP.viewReflog <> IP.makeExample' IP.viewReflog
<> "to undo this change." <> "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 :: FilePath -> Output -> IO Pretty
notifyUser dir = \case notifyUser dir = \case
SaveTermNameConflict name -> SaveTermNameConflict name ->
@ -684,49 +589,6 @@ notifyUser dir = \case
$ "The namespaces " $ "The namespaces "
<> P.commas (prettyBranchId <$> ps) <> P.commas (prettyBranchId <$> ps)
<> " are empty. Was there a typo?" <> " 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 -> LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath ->
pure $ pure $
P.lines P.lines
@ -824,13 +686,6 @@ notifyUser dir = \case
<> " by someone else. Trying your command again might fix it." <> " by someone else. Trying your command again might fix it."
] ]
EvaluationFailure err -> pure err 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 | null hqs -> pure mempty
SearchTermsNotFound hqs -> SearchTermsNotFound hqs ->
pure $ pure $
@ -856,8 +711,6 @@ notifyUser dir = \case
P.warnCallout typeOrTermMsg P.warnCallout typeOrTermMsg
<> P.newline <> P.newline
<> P.syntaxToColor (P.indent " " (P.lines (prettyHashQualified <$> otherHits))) <> P.syntaxToColor (P.indent " " (P.lines (prettyHashQualified <$> otherHits)))
PatchNotFound _ ->
pure . P.warnCallout $ "I don't know about that patch."
NameNotFound _ -> NameNotFound _ ->
pure . P.warnCallout $ "I don't know about that name." pure . P.warnCallout $ "I don't know about that name."
NamesNotFound hqs -> NamesNotFound hqs ->
@ -875,8 +728,6 @@ notifyUser dir = \case
pure . P.warnCallout $ "A term by that name already exists." pure . P.warnCallout $ "A term by that name already exists."
TypeAlreadyExists _ _ -> TypeAlreadyExists _ _ ->
pure . P.warnCallout $ "A type by that name already exists." pure . P.warnCallout $ "A type by that name already exists."
PatchAlreadyExists _ ->
pure . P.warnCallout $ "A patch by that name already exists."
BranchEmpty b -> BranchEmpty b ->
pure . P.warnCallout . P.wrap $ pure . P.warnCallout . P.wrap $
P.group (prettyWhichBranchEmpty b) <> "is an empty namespace." P.group (prettyWhichBranchEmpty b) <> "is an empty namespace."
@ -888,21 +739,21 @@ notifyUser dir = \case
P.lines P.lines
[ P.wrap $ [ P.wrap $
"I looked for a function" "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:", <> "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 -> BadMainFunction what main ty ppe ts ->
pure . P.callout "😶" $ pure . P.callout "😶" $
P.lines P.lines
[ P.string "I found this function:", [ 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.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 NoUnisonFile -> do
dir' <- canonicalizePath dir dir' <- canonicalizePath dir
@ -1187,8 +1038,6 @@ notifyUser dir = \case
LoadingFile sourceName -> do LoadingFile sourceName -> do
fileName <- renderFileName $ Text.unpack sourceName fileName <- renderFileName $ Text.unpack sourceName
pure $ P.wrap $ "Loading changes detected in " <> P.group (fileName <> ".") pure $ P.wrap $ "Loading changes detected in " <> P.group (fileName <> ".")
-- TODO: Present conflicting TermEdits and TypeEdits
-- if we ever allow users to edit hashes directly.
Typechecked sourceName ppe slurpResult uf -> do Typechecked sourceName ppe slurpResult uf -> do
let fileStatusMsg = SlurpResult.pretty False ppe slurpResult let fileStatusMsg = SlurpResult.pretty False ppe slurpResult
let containsWatchExpressions = notNull $ UF.watchComponents uf let containsWatchExpressions = notNull $ UF.watchComponents uf
@ -1221,8 +1070,7 @@ notifyUser dir = \case
<> IP.makeExample' IP.add <> IP.makeExample' IP.add
<> " or " <> " or "
<> P.group (IP.makeExample' IP.update <> ",") <> P.group (IP.makeExample' IP.update <> ",")
<> "here's how your codebase would" <> "here's how your codebase would change:",
<> "change:",
P.indentN 2 $ SlurpResult.pretty False ppe slurpResult P.indentN 2 $ SlurpResult.pretty False ppe slurpResult
] ]
] ]
@ -1242,133 +1090,6 @@ notifyUser dir = \case
pure . P.wrap $ pure . P.wrap $
"I loaded " <> P.text sourceName <> " and didn't find anything." "I loaded " <> P.text sourceName <> " and didn't find anything."
else pure mempty 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) -> BustedBuiltins (Set.toList -> new) (Set.toList -> old) ->
-- todo: this could be prettier! Have a nice list like `find` gives, but -- todo: this could be prettier! Have a nice list like `find` gives, but
-- that requires querying the codebase to determine term types. Probably -- that requires querying the codebase to determine term types. Probably
@ -1398,17 +1119,6 @@ notifyUser dir = \case
"You're missing:" `P.hang` P.lines (fmap (P.text . Reference.toText) new), "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) "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 NoConfiguredRemoteMapping pp p -> do
let (localPathExample, sharePathExample) = let (localPathExample, sharePathExample) =
if Path.isRoot p if Path.isRoot p
@ -1428,7 +1138,7 @@ notifyUser dir = \case
"Type `help " <> PushPull.fold "push" "pull" pp <> "` for more information." "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 -> ConfiguredRemoteMappingParseError pp p url err ->
pure . P.fatalCallout . P.lines $ pure . P.fatalCallout . P.lines $
[ P.wrap $ [ P.wrap $
@ -1542,12 +1252,6 @@ notifyUser dir = \case
"I could't find a type with hash " "I could't find a type with hash "
<> (prettyShortHash sh) <> (prettyShortHash sh)
AboutToPropagatePatch -> pure "Applying changes from patch..." 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 -> PatchNeedsToBeConflictFree ->
pure . P.wrap $ pure . P.wrap $
"I tried to auto-apply the patch, but couldn't because it contained" "I tried to auto-apply the patch, but couldn't because it contained"
@ -1605,35 +1309,75 @@ notifyUser dir = \case
PullAlreadyUpToDate ns dest -> PullAlreadyUpToDate ns dest ->
pure . P.callout "😶" $ pure . P.callout "😶" $
P.wrap $ P.wrap $
prettyNamespaceKey dest prettyProjectAndBranchName (ProjectAndBranch dest.project.name dest.branch.name)
<> "was already up-to-date with" <> "was already up-to-date with"
<> P.group (prettyReadRemoteNamespace ns <> ".") <> P.group (prettyReadRemoteNamespace ns <> ".")
PullSuccessful ns dest -> PullSuccessful ns dest ->
pure . P.okCallout $ pure . P.okCallout $
P.wrap $ P.wrap $
"Successfully updated" "Successfully updated"
<> prettyNamespaceKey dest <> prettyProjectAndBranchName (ProjectAndBranch dest.project.name dest.branch.name)
<> "from" <> "from"
<> P.group (prettyReadRemoteNamespace ns <> ".") <> P.group (prettyReadRemoteNamespace ns <> ".")
AboutToMerge -> pure "Merging..." AboutToMerge -> pure "Merging..."
MergeOverEmpty dest -> MergeOverEmpty dest ->
pure . P.okCallout $ pure . P.okCallout $
P.wrap $ P.wrap $
"Successfully pulled into " <> P.group (prettyNamespaceKey dest <> ", which was empty.") "Successfully pulled into "
<> P.group
( prettyProjectAndBranchName (ProjectAndBranch dest.project.name dest.branch.name)
<> ", which was empty."
)
MergeAlreadyUpToDate src dest -> MergeAlreadyUpToDate src dest ->
pure . P.callout "😶" $ pure . P.callout "😶" $
P.wrap $ P.wrap $
prettyNamespaceKey dest either prettyPath' prettyProjectAndBranchName dest
<> "was already up-to-date with" <> "was already up-to-date with"
<> P.group (prettyNamespaceKey src <> ".") <> P.group (either prettyPath' prettyProjectAndBranchName src <> ".")
MergeConflictedAliases branch name1 name2 -> MergeAlreadyUpToDate2 aliceAndBob ->
pure . P.wrap $ pure . P.callout "😶" $
"On" P.wrap $
<> P.group (prettyProjectBranchName branch <> ",") prettyProjectAndBranchName aliceAndBob.alice
<> prettyName name1 <> "was already up-to-date with"
<> "and" <> P.group (prettyMergeSource aliceAndBob.bob <> ".")
<> prettyName name2 MergeConflictedAliases aliceOrBob name1 name2 ->
<> "are not aliases, but they used to be." pure $
P.wrap "Sorry, I wasn't able to perform the merge:"
<> P.newline
<> P.newline
<> P.wrap
( "On the merge ancestor,"
<> prettyName name1
<> "and"
<> prettyName name2
<> "were aliases for the same definition, but on"
<> prettyMergeSourceOrTarget aliceOrBob
<> "the names have different definitions currently. I'd need just a single new definition to use in their"
<> "dependents when I merge."
)
<> P.newline
<> P.newline
<> P.wrap ("Please fix up" <> prettyMergeSourceOrTarget aliceOrBob <> "to resolve this. For example,")
<> P.newline
<> P.newline
<> P.indentN
2
( P.bulleted
[ P.wrap
( IP.makeExample' IP.update
<> "the definitions to be the same again, so that there's nothing for me to decide."
),
P.wrap
( IP.makeExample' IP.moveAll
<> "or"
<> IP.makeExample' IP.delete
<> "all but one of the definitions; I'll use the remaining name when propagating updates."
)
]
)
<> P.newline
<> P.newline
<> P.wrap "and then try merging again."
MergeConflictedTermName name _refs -> MergeConflictedTermName name _refs ->
pure . P.wrap $ pure . P.wrap $
"The term name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging." "The term name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging."
@ -1641,49 +1385,101 @@ notifyUser dir = \case
pure . P.wrap $ pure . P.wrap $
"The type name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging." "The type name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging."
MergeConflictInvolvingBuiltin name -> MergeConflictInvolvingBuiltin name ->
pure . P.wrap $ pure . P.lines $
"There's a merge conflict on" [ P.wrap "Sorry, I wasn't able to perform the merge:",
<> P.group (prettyName name <> ",") "",
<> "but it's a builtin on one or both branches. We can't yet handle merge conflicts on builtins." P.wrap
MergeConstructorAlias maybeBranch name1 name2 -> ( "There's a merge conflict on"
<> P.group (prettyName name <> ",")
<> "but it's a builtin on one or both branches. I can't yet handle merge conflicts involving builtins."
),
"",
P.wrap
( "Please eliminate this conflict by updating one branch or the other, making"
<> prettyName name
<> "the same on both branches, or making neither of them a builtin, and then try the merge again."
)
]
MergeConstructorAlias aliceOrBob typeName conName1 conName2 ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName typeName
<> "has a constructor with multiple names, and I can't perform a merge in this situation:",
"",
P.indentN 2 (P.bulleted [prettyName conName1, prettyName conName2]),
"",
P.wrap "Please delete all but one name for each constructor, and then try merging again."
]
MergeDefnsInLib aliceOrBob ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "there's a type or term at the top level of the `lib` namespace, where I only expect to find"
<> "subnamespaces representing library dependencies.",
"",
P.wrap "Please move or remove it and then try merging again."
]
MergeMissingConstructorName aliceOrBob name ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName name
<> "has some constructors with missing names, and I can't perform a merge in this situation.",
"",
P.wrap $
"You can use"
<> IP.makeExample IP.view [prettyName name]
<> "and"
<> IP.makeExample IP.aliasTerm ["<hash>", prettyName name <> ".<ConstructorName>"]
<> "to give names to each unnamed constructor, and then try the merge again."
]
MergeNestedDeclAlias aliceOrBob shorterName longerName ->
pure . P.wrap $ pure . P.wrap $
"On" "On"
<> case maybeBranch of <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
Nothing -> "the LCA," <> "the type"
Just branch -> P.group (prettyProjectBranchName branch <> ",")
<> prettyName name1
<> "and"
<> prettyName name2
<> "are aliases. Every type declaration must have exactly one name for each constructor."
MergeDefnsInLib ->
pure . P.wrap $
"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 name ->
pure . P.wrap $
"The type"
<> prettyName name
<> "is missing a name for one of its constructors. Please add one before merging."
MergeNestedDeclAlias shorterName longerName ->
pure . P.wrap $
"The type"
<> prettyName longerName <> prettyName longerName
<> "is an alias of" <> "is an alias of"
<> P.group (prettyName shorterName <> ".") <> P.group (prettyName shorterName <> ".")
<> "Type aliases cannot be nested. Please make them disjoint before merging." <> "I'm not able to perform a merge when a type exists nested under an alias of itself. Please separate them or"
MergeStrayConstructor name -> <> "delete one copy, and then try merging again."
pure . P.wrap $ MergeStrayConstructor aliceOrBob name ->
"The constructor" pure . P.lines $
<> prettyName name [ P.wrap $
<> "is not in a subnamespace of a name of its type." "Sorry, I wasn't able to perform the merge, because I need all constructor names to be nested somewhere"
<> "Please either delete it or rename it before merging." <> "beneath the corresponding type name.",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the constructor"
<> prettyName name
<> "is not nested beneath the corresponding type name. Please either use"
<> IP.makeExample' IP.moveAll
<> "to move it, or if it's an extra copy, you can simply"
<> IP.makeExample' IP.delete
<> "it. Then try the merge again."
]
PreviewMergeAlreadyUpToDate src dest -> PreviewMergeAlreadyUpToDate src dest ->
pure . P.callout "😶" $ pure . P.callout "😶" $
P.wrap $ P.wrap $
prettyNamespaceKey dest prettyNamespaceKey dest
<> "is already up-to-date with" <> "is already up-to-date with"
<> P.group (prettyNamespaceKey src <> ".") <> 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 -> NoConflictsOrEdits ->
pure (P.okCallout "No conflicts or edits in progress.") pure (P.okCallout "No conflicts or edits in progress.")
HelpMessage pat -> pure $ IP.showPatternHelp pat HelpMessage pat -> pure $ IP.showPatternHelp pat
@ -1805,7 +1601,7 @@ notifyUser dir = \case
ShareError shareError -> pure (prettyShareError shareError) ShareError shareError -> pure (prettyShareError shareError)
ViewOnShare shareRef -> ViewOnShare shareRef ->
pure $ pure $
"View it on Unison Share: " <> case shareRef of "View it here: " <> case shareRef of
Left repoPath -> prettyShareLink repoPath Left repoPath -> prettyShareLink repoPath
Right branchInfo -> prettyRemoteBranchInfo branchInfo Right branchInfo -> prettyRemoteBranchInfo branchInfo
IntegrityCheck result -> pure $ case result of IntegrityCheck result -> pure $ case result of
@ -1931,12 +1727,17 @@ notifyUser dir = \case
"I just created" "I just created"
<> prettyProjectName projectName <> prettyProjectName projectName
<> "on" <> "on"
<> prettyURI host <> prettyShareURI host
CreatedRemoteProjectBranch host projectAndBranch -> CreatedRemoteProjectBranch host projectAndBranch ->
pure . P.wrap $ pure . P.wrap $
"I just created" <> prettyProjectAndBranchName projectAndBranch <> "on" <> prettyURI host "I just created" <> prettyProjectAndBranchName projectAndBranch <> "on" <> prettyShareURI host
RemoteProjectBranchIsUpToDate host projectAndBranch -> 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.")) 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.")) InvalidProjectBranchName name -> pure (P.wrap (P.text name <> "is not a valid branch name."))
ProjectNameAlreadyExists name -> ProjectNameAlreadyExists name ->
@ -1956,12 +1757,12 @@ notifyUser dir = \case
NotOnProjectBranch -> pure (P.wrap "You are not currently on a branch.") NotOnProjectBranch -> pure (P.wrap "You are not currently on a branch.")
NoAssociatedRemoteProject host projectAndBranch -> NoAssociatedRemoteProject host projectAndBranch ->
pure . P.wrap $ 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) -> NoAssociatedRemoteProjectBranch host (ProjectAndBranch project branch) ->
pure . P.wrap $ pure . P.wrap $
prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name)) prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name))
<> "isn't associated with any branch on" <> "isn't associated with any branch on"
<> prettyURI host <> prettyShareURI host
LocalProjectDoesntExist project -> LocalProjectDoesntExist project ->
pure . P.wrap $ pure . P.wrap $
prettyProjectName project <> "does not exist." prettyProjectName project <> "does not exist."
@ -1977,17 +1778,17 @@ notifyUser dir = \case
<> "exists." <> "exists."
RemoteProjectDoesntExist host project -> RemoteProjectDoesntExist host project ->
pure . P.wrap $ pure . P.wrap $
prettyProjectName project <> "does not exist on" <> prettyURI host prettyProjectName project <> "does not exist on" <> prettyShareURI host
RemoteProjectBranchDoesntExist host projectAndBranch -> RemoteProjectBranchDoesntExist host projectAndBranch ->
pure . P.wrap $ pure . P.wrap $
prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyURI host prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyShareURI host
RemoteProjectBranchDoesntExist'Push host projectAndBranch -> RemoteProjectBranchDoesntExist'Push host projectAndBranch ->
let push = P.group . P.backticked . IP.patternName $ IP.push let push = P.group . P.backticked . IP.patternName $ IP.push
in pure . P.wrap $ in pure . P.wrap $
"The previous push target named" "The previous push target named"
<> prettyProjectAndBranchName projectAndBranch <> prettyProjectAndBranchName projectAndBranch
<> "has been deleted from" <> "has been deleted from"
<> P.group (prettyURI host <> ".") <> P.group (prettyShareURI host <> ".")
<> "I've deleted the invalid push target." <> "I've deleted the invalid push target."
<> "Run the" <> "Run the"
<> push <> push
@ -1996,14 +1797,14 @@ notifyUser dir = \case
pure . P.wrap $ pure . P.wrap $
prettyProjectAndBranchName projectAndBranch prettyProjectAndBranchName projectAndBranch
<> "on" <> "on"
<> prettyURI host <> prettyShareURI host
<> "has some history that I don't know about." <> "has some history that I don't know about."
RemoteProjectPublishedReleaseCannotBeChanged host projectAndBranch -> RemoteProjectPublishedReleaseCannotBeChanged host projectAndBranch ->
pure . P.wrap $ pure . P.wrap $
"The release" "The release"
<> prettyProjectAndBranchName projectAndBranch <> prettyProjectAndBranchName projectAndBranch
<> "on" <> "on"
<> prettyURI host <> prettyShareURI host
<> "has already been published and cannot be changed." <> "has already been published and cannot be changed."
<> "Consider making a new release instead." <> "Consider making a new release instead."
RemoteProjectReleaseIsDeprecated host projectAndBranch -> RemoteProjectReleaseIsDeprecated host projectAndBranch ->
@ -2011,7 +1812,7 @@ notifyUser dir = \case
"The release" "The release"
<> prettyProjectAndBranchName projectAndBranch <> prettyProjectAndBranchName projectAndBranch
<> "on" <> "on"
<> prettyURI host <> prettyShareURI host
<> "has been deprecated." <> "has been deprecated."
Unauthorized message -> Unauthorized message ->
pure . P.wrap $ pure . P.wrap $
@ -2260,32 +2061,34 @@ notifyUser dir = \case
"", "",
"Your non-project code is still available to pull from Share, and you can pull it into a local namespace using `pull myhandle.public`" "Your non-project code is still available to pull from Share, and you can pull it into a local namespace using `pull myhandle.public`"
] ]
MergeFailure path base target -> MergeFailure path aliceAndBob ->
pure . P.wrap $ pure . P.wrap $
"I couldn't automatically merge" "I couldn't automatically merge"
<> prettyProjectBranchName (view #branch target) <> prettyMergeSource aliceAndBob.bob
<> "into" <> "into"
<> P.group (prettyProjectBranchName (view #branch base) <> ".") <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".")
<> "However, I've added the definitions that need attention to the top of" <> "However, I've added the definitions that need attention to the top of"
<> P.group (prettyFilePath path <> ".") <> P.group (prettyFilePath path <> ".")
MergeSuccess base target -> MergeSuccess aliceAndBob ->
pure . P.wrap $ pure . P.wrap $
"I merged" "I merged"
<> prettyProjectBranchName (view #branch target) <> prettyMergeSource aliceAndBob.bob
<> "into" <> "into"
<> P.group (prettyProjectBranchName (view #branch base) <> ".") <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".")
MergeSuccessFastForward base target -> MergeSuccessFastForward aliceAndBob ->
pure . P.wrap $ pure . P.wrap $
"I fast-forward merged" "I fast-forward merged"
<> prettyProjectBranchName (view #branch target) <> prettyMergeSource aliceAndBob.bob
<> "into" <> "into"
<> P.group (prettyProjectBranchName (view #branch base) <> ".") <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".")
InstalledLibdep libdep segment -> InstalledLibdep libdep segment ->
pure . P.wrap $ pure . P.wrap $
"I installed" "I installed"
<> prettyProjectAndBranchName libdep <> prettyProjectAndBranchName libdep
<> "as" <> "as"
<> P.group (P.text (NameSegment.toEscapedText segment) <> ".") <> P.group (P.text (NameSegment.toEscapedText segment) <> ".")
NoUpgradeInProgress ->
pure . P.wrap $ "It doesn't look like there's an upgrade in progress."
expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty
expectedEmptyPushDest namespace = expectedEmptyPushDest namespace =
@ -2770,7 +2573,7 @@ renderNameConflicts ppe conflictedNames = do
P.lines <$> do P.lines <$> do
for (Map.toList conflictedNames) $ \(name, hashes) -> do for (Map.toList conflictedNames) $ \(name, hashes) -> do
prettyConflicts <- for hashes \hash -> 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 $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash)
pure . P.wrap $ pure . P.wrap $
( "The " ( "The "
@ -2802,7 +2605,7 @@ renderEditConflicts ppe Patch {..} = do
<> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits) <> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits)
numberedHQName :: HQ.HashQualified Name -> Numbered Pretty numberedHQName :: HQ.HashQualified Name -> Numbered Pretty
numberedHQName hqName = do numberedHQName hqName = do
n <- addNumberedArg (Text.unpack (HQ.toText hqName)) n <- addNumberedArg $ SA.HashQualified hqName
pure $ formatNum n <> styleHashQualified P.bold hqName pure $ formatNum n <> styleHashQualified P.bold hqName
formatTypeEdits :: formatTypeEdits ::
(Reference, Set TypeEdit.TypeEdit) -> (Reference, Set TypeEdit.TypeEdit) ->
@ -2841,9 +2644,9 @@ renderEditConflicts ppe Patch {..} = do
Numbered Pretty Numbered Pretty
formatConflict = either formatTypeEdits formatTermEdits 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 addNumberedArg s = do
(n, args) <- State.get (n, args) <- State.get
State.put (n + 1, args Seq.|> s) State.put (n + 1, args Seq.|> s)
@ -2915,11 +2718,11 @@ todoOutput ppe todo = runNumbered do
todoEdits :: Numbered Pretty todoEdits :: Numbered Pretty
todoEdits = do todoEdits = do
numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> 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) pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj)
let filteredTerms = goodTerms (unscore <$> dirtyTerms) let filteredTerms = goodTerms (unscore <$> dirtyTerms)
termNumbers <- for filteredTerms \(ref, _, _) -> do 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 pure $ formatNum n
let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms
numberedTerms = zipWith (<>) termNumbers formattedTerms numberedTerms = zipWith (<>) termNumbers formattedTerms
@ -3324,21 +3127,13 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
-- DeclPrinter.prettyDeclHeader : HQ -> Either -- DeclPrinter.prettyDeclHeader : HQ -> Either
numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty
numPatch prefix name = numPatch prefix name =
addNumberedArg' $ prefixBranchId prefix name addNumberedArg' $ SA.NameWithBranchPrefix prefix name
numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty
numHQ' prefix hq r = numHQ' prefix hq r =
addNumberedArg' . HQ'.toStringWith (prefixBranchId prefix) . HQ'.requalify hq $ r addNumberedArg' . SA.HashQualifiedWithBranchPrefix prefix $ HQ'.requalify hq r
-- E.g. addNumberedArg' :: StructuredArgument -> Numbered Pretty
-- 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' s = case sn of addNumberedArg' s = case sn of
ShowNumbers -> do ShowNumbers -> do
n <- addNumberedArg s n <- addNumberedArg s
@ -3593,7 +3388,7 @@ numberedArgsForEndangerments (PPED.unsuffixifiedPPE -> ppe) m =
m m
& Map.elems & Map.elems
& concatMap toList & 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. -- | Format and render all dependents which are endangered by references going extinct.
endangeredDependentsTable :: endangeredDependentsTable ::

View File

@ -389,7 +389,7 @@ markdownDocsForFQN fileUri fqn =
nameSearch <- lift $ getNameSearch nameSearch <- lift $ getNameSearch
Env {codebase, runtime} <- ask Env {codebase, runtime} <- ask
liftIO $ do liftIO $ do
docRefs <- Backend.docsForDefinitionName codebase nameSearch ExactName name docRefs <- Codebase.runTransaction codebase $ Backend.docsForDefinitionName codebase nameSearch ExactName name
for docRefs $ \docRef -> do for docRefs $ \docRef -> do
Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef) Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef)
pure . Md.toText $ Md.toMarkdown doc pure . Md.toText $ Md.toMarkdown doc

View File

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

View File

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

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

View File

@ -7,15 +7,11 @@ import Data.Void (Void)
import EasyTest import EasyTest
import Text.Megaparsec qualified as P import Text.Megaparsec qualified as P
import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.RemoteRepo
( ReadGitRepo (..), ( ReadRemoteNamespace (..),
ReadRemoteNamespace (..),
ShareCodeserver (..), ShareCodeserver (..),
ShareUserHandle (..), ShareUserHandle (..),
WriteGitRemoteNamespace (..),
WriteGitRepo (..),
WriteRemoteNamespace (..), WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..), WriteShareRemoteNamespace (..),
pattern ReadGitRemoteNamespace,
pattern ReadShareLooseCode, pattern ReadShareLooseCode,
) )
import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Editor.UriParser qualified as UriParser
@ -34,22 +30,7 @@ test =
[ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]), [ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]),
("project", branchR (This "project")), ("project", branchR (This "project")),
("/branch", branchR (That "branch")), ("/branch", branchR (That "branch")),
("project/branch", branchR (These "project" "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"])
] ]
[".unisonweb.base"], [".unisonweb.base"],
parserTests parserTests
@ -58,36 +39,15 @@ test =
[ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]), [ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]),
("project", branchW (This "project")), ("project", branchW (This "project")),
("/branch", branchW (That "branch")), ("/branch", branchW (That "branch")),
("project/branch", branchW (These "project" "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 [])
] ]
[ ".unisonweb.base", [ ".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"
] ]
] ]
mkPath :: [Text] -> Path.Path mkPath :: [Text] -> Path.Path
mkPath = Path.fromList . fmap NameSegment mkPath = Path.fromList . fmap NameSegment
gitR :: Text -> Maybe Text -> Maybe ShortCausalHash -> [Text] -> ReadRemoteNamespace void
gitR url ref sch path = ReadRemoteNamespaceGit (ReadGitRemoteNamespace (ReadGitRepo url ref) sch (mkPath path))
gitW :: Text -> Maybe Text -> [Text] -> WriteRemoteNamespace void
gitW url branch path = WriteRemoteNamespaceGit (WriteGitRemoteNamespace (WriteGitRepo url branch) (mkPath path))
looseR :: Text -> [Text] -> ReadRemoteNamespace void looseR :: Text -> [Text] -> ReadRemoteNamespace void
looseR user path = looseR user path =
ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (mkPath path)) ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (mkPath path))

View File

@ -1,6 +1,6 @@
cabal-version: 1.12 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 -- see: https://github.com/sol/hpack
@ -35,6 +35,7 @@ library
Unison.Auth.Types Unison.Auth.Types
Unison.Auth.UserInfo Unison.Auth.UserInfo
Unison.Cli.DownloadUtils Unison.Cli.DownloadUtils
Unison.Cli.MergeTypes
Unison.Cli.Monad Unison.Cli.Monad
Unison.Cli.MonadUtils Unison.Cli.MonadUtils
Unison.Cli.NamesUtils Unison.Cli.NamesUtils
@ -54,6 +55,7 @@ library
Unison.Codebase.Editor.HandleInput.Branch Unison.Codebase.Editor.HandleInput.Branch
Unison.Codebase.Editor.HandleInput.Branches Unison.Codebase.Editor.HandleInput.Branches
Unison.Codebase.Editor.HandleInput.BranchRename Unison.Codebase.Editor.HandleInput.BranchRename
Unison.Codebase.Editor.HandleInput.CommitUpgrade
Unison.Codebase.Editor.HandleInput.DebugDefinition Unison.Codebase.Editor.HandleInput.DebugDefinition
Unison.Codebase.Editor.HandleInput.DebugFoldRanges Unison.Codebase.Editor.HandleInput.DebugFoldRanges
Unison.Codebase.Editor.HandleInput.DeleteBranch Unison.Codebase.Editor.HandleInput.DeleteBranch
@ -96,6 +98,7 @@ library
Unison.Codebase.Editor.Slurp Unison.Codebase.Editor.Slurp
Unison.Codebase.Editor.SlurpComponent Unison.Codebase.Editor.SlurpComponent
Unison.Codebase.Editor.SlurpResult Unison.Codebase.Editor.SlurpResult
Unison.Codebase.Editor.StructuredArgument
Unison.Codebase.Editor.TodoOutput Unison.Codebase.Editor.TodoOutput
Unison.Codebase.Editor.UCMVersion Unison.Codebase.Editor.UCMVersion
Unison.Codebase.Editor.UriParser Unison.Codebase.Editor.UriParser
@ -426,7 +429,6 @@ test-suite cli-tests
other-modules: other-modules:
Unison.Test.ClearCache Unison.Test.ClearCache
Unison.Test.Cli.Monad Unison.Test.Cli.Monad
Unison.Test.GitSync
Unison.Test.LSP Unison.Test.LSP
Unison.Test.Ucm Unison.Test.Ucm
Unison.Test.UriParser Unison.Test.UriParser

View File

@ -33,10 +33,11 @@ module Unison.DataDeclaration
constructors_, constructors_,
asDataDecl_, asDataDecl_,
declAsDataDecl_, declAsDataDecl_,
setConstructorNames,
) )
where 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 Control.Monad.State (evalState)
import Data.Map qualified as Map import Data.Map qualified as Map
import Data.Set qualified as Set import Data.Set qualified as Set
@ -164,6 +165,20 @@ constructorVars dd = fst <$> constructors dd
constructorNames :: (Var v) => DataDeclaration v a -> [Text] constructorNames :: (Var v) => DataDeclaration v a -> [Text]
constructorNames dd = Var.name <$> constructorVars dd 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. -- 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 -- It should probably be hashed directly from the Decl, once we have a
-- reliable way of doing that. —AI -- reliable way of doing that. —AI

View File

@ -17,6 +17,8 @@ module Unison.Project
ProjectBranchSpecifier (..), ProjectBranchSpecifier (..),
ProjectAndBranch (..), ProjectAndBranch (..),
projectAndBranchNamesParser, projectAndBranchNamesParser,
projectAndOptionalBranchParser,
branchWithOptionalProjectParser,
ProjectAndBranchNames (..), ProjectAndBranchNames (..),
projectAndBranchNamesParser2, projectAndBranchNamesParser2,
projectNameParser, projectNameParser,

View File

@ -16,11 +16,12 @@ import U.Codebase.Sqlite.Operations qualified as Operations
import Unison.Builtin qualified as Builtins import Unison.Builtin qualified as Builtins
import Unison.Codebase (Codebase) import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as V1 import Unison.Codebase.SqliteCodebase.Operations qualified as Operations (expectDeclComponent)
import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorReference (GConstructorReference (..))
import Unison.ConstructorType (ConstructorType) import Unison.ConstructorType (ConstructorType)
import Unison.DataDeclaration qualified as V1 (Decl) import Unison.DataDeclaration qualified as V1 (Decl)
import Unison.DataDeclaration qualified as V1.Decl import Unison.DataDeclaration qualified as V1.Decl
import Unison.Hash (Hash)
import Unison.Parser.Ann qualified as V1 (Ann) import Unison.Parser.Ann qualified as V1 (Ann)
import Unison.Prelude import Unison.Prelude
import Unison.Referent qualified as V1 (Referent) import Unison.Referent qualified as V1 (Referent)
@ -29,6 +30,7 @@ import Unison.Sqlite (Transaction)
import Unison.Sqlite qualified as Sqlite import Unison.Sqlite qualified as Sqlite
import Unison.Symbol qualified as V1 (Symbol) import Unison.Symbol qualified as V1 (Symbol)
import Unison.Term qualified as V1 (Term) import Unison.Term qualified as V1 (Term)
import Unison.Type qualified as V1 (Type)
import Unison.Util.Cache qualified as Cache import Unison.Util.Cache qualified as Cache
------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------
@ -39,9 +41,10 @@ data MergeDatabase = MergeDatabase
{ loadCausal :: CausalHash -> Transaction (CausalBranch Transaction), { loadCausal :: CausalHash -> Transaction (CausalBranch Transaction),
loadDeclNumConstructors :: TypeReferenceId -> Transaction Int, loadDeclNumConstructors :: TypeReferenceId -> Transaction Int,
loadDeclType :: TypeReference -> Transaction ConstructorType, loadDeclType :: TypeReference -> Transaction ConstructorType,
loadV1Branch :: CausalHash -> Transaction (V1.Branch Transaction),
loadV1Decl :: TypeReferenceId -> Transaction (V1.Decl V1.Symbol V1.Ann), loadV1Decl :: TypeReferenceId -> Transaction (V1.Decl V1.Symbol V1.Ann),
loadV1Term :: TermReferenceId -> Transaction (V1.Term V1.Symbol V1.Ann) loadV1DeclComponent :: Hash -> Transaction [V1.Decl V1.Symbol V1.Ann],
loadV1Term :: TermReferenceId -> Transaction (V1.Term V1.Symbol V1.Ann),
loadV1TermComponent :: Hash -> Transaction [(V1.Term V1.Symbol V1.Ann, V1.Type V1.Symbol V1.Ann)]
} }
makeMergeDatabase :: MonadIO m => Codebase IO V1.Symbol V1.Ann -> m MergeDatabase makeMergeDatabase :: MonadIO m => Codebase IO V1.Symbol V1.Ann -> m MergeDatabase
@ -53,7 +56,6 @@ makeMergeDatabase codebase = liftIO do
loadDeclNumConstructors <- do loadDeclNumConstructors <- do
cache <- Cache.semispaceCache 1024 cache <- Cache.semispaceCache 1024
pure (Sqlite.cacheTransaction cache Operations.expectDeclNumConstructors) pure (Sqlite.cacheTransaction cache Operations.expectDeclNumConstructors)
let loadV1Branch = undefined -- Codebase.expectBranchForHash codebase
loadV1Decl <- do loadV1Decl <- do
cache <- Cache.semispaceCache 1024 cache <- Cache.semispaceCache 1024
pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTypeDeclaration codebase)) pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTypeDeclaration codebase))
@ -67,7 +69,18 @@ makeMergeDatabase codebase = liftIO do
loadV1Term <- do loadV1Term <- do
cache <- Cache.semispaceCache 1024 cache <- Cache.semispaceCache 1024
pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTerm codebase)) pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTerm codebase))
pure MergeDatabase {loadCausal, loadDeclNumConstructors, loadDeclType, loadV1Branch, loadV1Decl, loadV1Term} let loadV1TermComponent = Codebase.unsafeGetTermComponent codebase
let loadV1DeclComponent = Operations.expectDeclComponent
pure
MergeDatabase
{ loadCausal,
loadDeclNumConstructors,
loadDeclType,
loadV1Decl,
loadV1DeclComponent,
loadV1Term,
loadV1TermComponent
}
-- Convert a v2 referent (missing decl type) to a v1 referent. -- Convert a v2 referent (missing decl type) to a v1 referent.
referent2to1 :: MergeDatabase -> Referent -> Transaction V1.Referent referent2to1 :: MergeDatabase -> Referent -> Transaction V1.Referent

View File

@ -82,10 +82,11 @@
module Unison.Merge.DeclCoherencyCheck module Unison.Merge.DeclCoherencyCheck
( IncoherentDeclReason (..), ( IncoherentDeclReason (..),
checkDeclCoherency, checkDeclCoherency,
lenientCheckDeclCoherency,
) )
where where
import Control.Lens (view, (%=), (.=)) import Control.Lens (over, view, (%=), (.=), _2)
import Control.Monad.Except (ExceptT) import Control.Monad.Except (ExceptT)
import Control.Monad.Except qualified as Except import Control.Monad.Except qualified as Except
import Control.Monad.State.Strict (StateT) import Control.Monad.State.Strict (StateT)
@ -101,6 +102,7 @@ import Data.Maybe (fromJust)
import Data.Set qualified as Set import Data.Set qualified as Set
import U.Codebase.Reference (Reference' (..), TypeReference, TypeReferenceId) import U.Codebase.Reference (Reference' (..), TypeReference, TypeReferenceId)
import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorReference (GConstructorReference (..))
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Merge.DeclNameLookup (DeclNameLookup (..)) import Unison.Merge.DeclNameLookup (DeclNameLookup (..))
import Unison.Name (Name) import Unison.Name (Name)
import Unison.Name qualified as Name import Unison.Name qualified as Name
@ -108,9 +110,8 @@ import Unison.NameSegment (NameSegment)
import Unison.Prelude import Unison.Prelude
import Unison.Referent (Referent) import Unison.Referent (Referent)
import Unison.Referent qualified as Referent import Unison.Referent qualified as Referent
import Unison.Sqlite (Transaction)
import Unison.Util.Defns (Defns (..), DefnsF) 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 (..)) import Unison.Util.Nametree (Nametree (..))
data IncoherentDeclReason data IncoherentDeclReason
@ -119,7 +120,7 @@ data IncoherentDeclReason
-- Foo#Foo -- Foo#Foo
-- Foo.Bar#Foo#0 -- Foo.Bar#Foo#0
-- Foo.Some.Other.Name.For.Bar#Foo#0 -- Foo.Some.Other.Name.For.Bar#Foo#0
IncoherentDeclReason'ConstructorAlias !Name !Name IncoherentDeclReason'ConstructorAlias !Name !Name !Name -- type, first constructor, second constructor
| IncoherentDeclReason'MissingConstructorName !Name | IncoherentDeclReason'MissingConstructorName !Name
| -- | A second naming of a decl was discovered underneath its name, e.g. | -- | A second naming of a decl was discovered underneath its name, e.g.
-- --
@ -129,9 +130,11 @@ data IncoherentDeclReason
| IncoherentDeclReason'StrayConstructor !Name | IncoherentDeclReason'StrayConstructor !Name
checkDeclCoherency :: checkDeclCoherency ::
(TypeReferenceId -> Transaction Int) -> forall m.
Monad m =>
(TypeReferenceId -> m Int) ->
Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
Transaction (Either IncoherentDeclReason DeclNameLookup) m (Either IncoherentDeclReason DeclNameLookup)
checkDeclCoherency loadDeclNumConstructors = checkDeclCoherency loadDeclNumConstructors =
Except.runExceptT Except.runExceptT
. fmap (view #declNameLookup) . fmap (view #declNameLookup)
@ -140,10 +143,10 @@ checkDeclCoherency loadDeclNumConstructors =
where where
go :: go ::
[NameSegment] -> [NameSegment] ->
(Nametree (Defns (Map NameSegment Referent) (Map NameSegment TypeReference))) -> (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason Transaction) () StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason m) ()
go prefix (Nametree Defns {terms, types} children) = do go prefix (Nametree defns children) = do
for_ (Map.toList terms) \case for_ (Map.toList defns.terms) \case
(_, Referent.Ref _) -> pure () (_, Referent.Ref _) -> pure ()
(_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure () (_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure ()
(name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do (name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do
@ -152,35 +155,33 @@ checkDeclCoherency loadDeclNumConstructors =
#expectedConstructors .= expectedConstructors1 #expectedConstructors .= expectedConstructors1
where where
f :: f ::
Maybe (Name, IntMap MaybeConstructorName) -> Maybe (Name, ConstructorNames) ->
Either IncoherentDeclReason (Name, IntMap MaybeConstructorName) Either IncoherentDeclReason (Name, ConstructorNames)
f = \case f = \case
Nothing -> Left (IncoherentDeclReason'StrayConstructor (fullName name)) Nothing -> Left (IncoherentDeclReason'StrayConstructor name1)
Just (typeName, expected) -> (typeName,) <$> IntMap.alterF g (fromIntegral @Word64 @Int conId) expected Just (typeName, expected) ->
where case recordConstructorName conId name1 expected of
g :: Maybe MaybeConstructorName -> Either IncoherentDeclReason (Maybe MaybeConstructorName) Left existingName -> Left (IncoherentDeclReason'ConstructorAlias typeName existingName name1)
g = \case Right expected1 -> Right (typeName, expected1)
Nothing -> error "didnt put expected constructor id" where
Just NoConstructorNameYet -> Right (Just (YesConstructorName (fullName name))) name1 = fullName name
Just (YesConstructorName firstName) ->
Left (IncoherentDeclReason'ConstructorAlias firstName (fullName name))
childrenWeWentInto <- childrenWeWentInto <-
forMaybe (Map.toList types) \case forMaybe (Map.toList defns.types) \case
(_, ReferenceBuiltin _) -> pure Nothing (_, ReferenceBuiltin _) -> pure Nothing
(name, ReferenceDerived typeRef) -> do (name, ReferenceDerived typeRef) -> do
DeclCoherencyCheckState {expectedConstructors} <- State.get DeclCoherencyCheckState {expectedConstructors} <- State.get
whatHappened <- do whatHappened <- do
let recordNewDecl :: let recordNewDecl ::
Maybe (Name, IntMap MaybeConstructorName) -> Maybe (Name, ConstructorNames) ->
Compose (ExceptT IncoherentDeclReason Transaction) WhatHappened (Name, IntMap MaybeConstructorName) Compose (ExceptT IncoherentDeclReason m) WhatHappened (Name, ConstructorNames)
recordNewDecl = recordNewDecl =
Compose . \case Compose . \case
Just (shorterTypeName, _) -> Except.throwError (IncoherentDeclReason'NestedDeclAlias shorterTypeName typeName) Just (shorterTypeName, _) -> Except.throwError (IncoherentDeclReason'NestedDeclAlias shorterTypeName typeName)
Nothing -> Nothing ->
lift (loadDeclNumConstructors typeRef) <&> \case lift (loadDeclNumConstructors typeRef) <&> \case
0 -> UninhabitedDecl 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)) lift (getCompose (Map.upsertF recordNewDecl typeRef expectedConstructors))
case whatHappened of case whatHappened of
UninhabitedDecl -> do UninhabitedDecl -> do
@ -197,18 +198,88 @@ checkDeclCoherency loadDeclNumConstructors =
let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) = let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) =
Map.deleteLookup typeRef expectedConstructors Map.deleteLookup typeRef expectedConstructors
constructorNames <- constructorNames <-
unMaybeConstructorNames maybeConstructorNames & onNothing do sequence (IntMap.elems maybeConstructorNames) & onNothing do
Except.throwError (IncoherentDeclReason'MissingConstructorName typeName) Except.throwError (IncoherentDeclReason'MissingConstructorName typeName)
#expectedConstructors .= expectedConstructors1 #expectedConstructors .= expectedConstructors1
#declNameLookup %= \declNameLookup -> #declNameLookup . #constructorToDecl %= \constructorToDecl ->
DeclNameLookup List.foldl'
{ constructorToDecl = (\acc constructorName -> Map.insert constructorName typeName acc)
List.foldl' constructorToDecl
(\acc constructorName -> Map.insert constructorName typeName acc) constructorNames
declNameLookup.constructorToDecl #declNameLookup . #declToConstructors %= Map.insert typeName constructorNames
constructorNames, pure (Just name)
declToConstructors = Map.insert typeName constructorNames declNameLookup.declToConstructors 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) pure (Just name)
where where
typeName = fullName name typeName = fullName name
@ -220,23 +291,47 @@ checkDeclCoherency loadDeclNumConstructors =
Name.fromReverseSegments (name :| prefix) Name.fromReverseSegments (name :| prefix)
data DeclCoherencyCheckState = DeclCoherencyCheckState data DeclCoherencyCheckState = DeclCoherencyCheckState
{ expectedConstructors :: !(Map TypeReferenceId (Name, IntMap MaybeConstructorName)), { expectedConstructors :: !(Map TypeReferenceId (Name, ConstructorNames)),
declNameLookup :: !DeclNameLookup declNameLookup :: !DeclNameLookup
} }
deriving stock (Generic) deriving stock (Generic)
data MaybeConstructorName data LenientDeclCoherencyCheckState = LenientDeclCoherencyCheckState
= NoConstructorNameYet { expectedConstructors :: !(Map TypeReferenceId (Map Name ConstructorNames)),
| YesConstructorName !Name declToConstructors :: !(Map Name [Maybe Name])
}
deriving stock (Generic)
unMaybeConstructorNames :: IntMap MaybeConstructorName -> Maybe [Name] -- A partial mapping from constructor id to name; a collection of constructor names starts out with the correct number
unMaybeConstructorNames = -- of keys (per the number of data constructors) all mapped to Nothing. Then, as names are discovered by walking a
traverse f . IntMap.elems -- 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 where
f :: MaybeConstructorName -> Maybe Name f :: Maybe (Maybe Name) -> Either Name (Maybe (Maybe Name))
f = \case f = \case
NoConstructorNameYet -> Nothing Nothing -> error (reportBug "E397219" ("recordConstructorName: didn't expect constructor id " ++ show conId))
YesConstructorName name -> Just name 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 data WhatHappened a
= UninhabitedDecl = UninhabitedDecl

View File

@ -2,19 +2,13 @@ module Unison.Merge.DeclNameLookup
( DeclNameLookup (..), ( DeclNameLookup (..),
expectDeclName, expectDeclName,
expectConstructorNames, expectConstructorNames,
setConstructorNames,
) )
where where
import Control.Lens (over)
import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as DataDeclaration
import Unison.Name (Name) import Unison.Name (Name)
import Unison.Prelude import Unison.Prelude
import Unison.Syntax.Name qualified as Name
import Unison.Var (Var)
-- | A lookup from decl-to-constructor name and vice-versa. -- | A lookup from decl-to-constructor name and vice-versa.
-- --
@ -57,22 +51,3 @@ expectConstructorNames DeclNameLookup {declToConstructors} x =
case Map.lookup x declToConstructors of case Map.lookup x declToConstructors of
Nothing -> error (reportBug "E077058" ("Expected decl name key " <> show x <> " in decl name lookup")) Nothing -> error (reportBug "E077058" ("Expected decl name key " <> show x <> " in decl name lookup"))
Just y -> y 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
)

View File

@ -9,23 +9,30 @@ import Data.Semialign (alignWith)
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.These (These (..)) import Data.These (These (..))
import U.Codebase.Reference (TypeReference) 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.HashQualified' qualified as HQ'
import Unison.Merge.Database (MergeDatabase (..)) import Unison.Merge.Database (MergeDatabase (..))
import Unison.Merge.DeclNameLookup (DeclNameLookup) import Unison.Merge.DeclNameLookup (DeclNameLookup)
import Unison.Merge.DeclNameLookup qualified as DeclNameLookup import Unison.Merge.DeclNameLookup qualified as DeclNameLookup
import Unison.Merge.DiffOp (DiffOp (..)) import Unison.Merge.DiffOp (DiffOp (..))
import Unison.Merge.Synhash qualified as Synhash import Unison.Merge.Synhash
import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.Synhashed (Synhashed (..))
import Unison.Merge.ThreeWay (ThreeWay (..)) import Unison.Merge.ThreeWay (ThreeWay (..))
import Unison.Merge.ThreeWay qualified as ThreeWay
import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Merge.TwoWay (TwoWay (..))
import Unison.Merge.Updated (Updated (..)) import Unison.Merge.Updated (Updated (..))
import Unison.Name (Name) import Unison.Name (Name)
import Unison.Parser.Ann (Ann)
import Unison.Prelude hiding (catMaybes) import Unison.Prelude hiding (catMaybes)
import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) import Unison.PrettyPrintEnv (PrettyPrintEnv (..))
import Unison.PrettyPrintEnv qualified as Ppe import Unison.PrettyPrintEnv qualified as Ppe
import Unison.Reference (Reference' (..), TypeReferenceId)
import Unison.Referent (Referent) import Unison.Referent (Referent)
import Unison.Sqlite (Transaction) import Unison.Sqlite (Transaction)
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name
import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith) 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. -- branches. If the hash of a name did not change, it will not appear in the map.
nameBasedNamespaceDiff :: nameBasedNamespaceDiff ::
MergeDatabase -> MergeDatabase ->
ThreeWay DeclNameLookup -> TwoWay DeclNameLookup ->
Map Name [Maybe Name] ->
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
Transaction (TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)) Transaction (TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference))
nameBasedNamespaceDiff db declNameLookups defns = do nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns = do
diffs <- sequence (synhashDefns <$> declNameLookups <*> defns) lcaHashes <-
pure (diffNamespaceDefns diffs.lca <$> TwoWay {alice = diffs.alice, bob = diffs.bob}) 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 where
synhashDefns :: synhashDefns ::
DeclNameLookup -> DeclNameLookup ->
@ -55,16 +79,20 @@ nameBasedNamespaceDiff db declNameLookups defns = do
-- FIXME: use cache so we only synhash each thing once -- FIXME: use cache so we only synhash each thing once
synhashDefnsWith hashTerm hashType synhashDefnsWith hashTerm hashType
where where
hashTerm :: Referent -> Transaction Hash
hashTerm =
Synhash.hashTerm db.loadV1Term ppe
hashType :: Name -> TypeReference -> Transaction Hash hashType :: Name -> TypeReference -> Transaction Hash
hashType name = hashType name = \case
Synhash.hashDecl ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin)
(fmap (DeclNameLookup.setConstructorNames declNameLookup name) . db.loadV1Decl) ReferenceDerived ref -> do
ppe decl <- loadDeclWithGoodConstructorNames (DeclNameLookup.expectConstructorNames declNameLookup name) ref
name 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 :: PrettyPrintEnv
ppe = ppe =

View File

@ -1,39 +0,0 @@
module Unison.Merge.PreconditionViolation
( PreconditionViolation (..),
)
where
import U.Codebase.Reference (TypeReference)
import Unison.Core.Project (ProjectBranchName)
import Unison.Name (Name)
import Unison.Prelude
import Unison.Referent (Referent)
-- | A reason that a merge could not be performed.
data PreconditionViolation
= -- | @ConflictedAliases branch foo bar@: in project branch @branch@, @foo@ and @bar@ refer to different things,
-- but at one time (in the LCA of another branch, in fact) they referred to the same thing.
ConflictedAliases !ProjectBranchName !Name !Name
| -- | @ConflictedTermName name refs@: @name@ refers to 2+ referents @refs@.
ConflictedTermName !Name !(Set Referent)
| -- | @ConflictedTypeName name refs@: @name@ refers to 2+ type references @refs@.
ConflictedTypeName !Name !(Set TypeReference)
| -- | @ConflictInvolvingBuiltin name@: @name@ is involved in a conflict, but it refers to a builtin (on at least one
-- side). Since we can't put a builtin in a scratch file, we bomb in these cases.
ConflictInvolvingBuiltin !Name
| -- | A second naming of a constructor was discovered underneath a decl's name, e.g.
--
-- Foo#Foo
-- Foo.Bar#Foo#0
-- Foo.Some.Other.Name.For.Bar#Foo#0
--
-- If the project branch name is missing, it means the LCA is in violation.
ConstructorAlias !(Maybe ProjectBranchName) !Name !Name -- first name we found, second name we found
| -- | There were some definitions at the top level of lib.*, which we don't like
DefnsInLib
| -- | This type name is missing a name for one of its constructors.
MissingConstructorName !Name
| -- | This type name is a nested alias, e.g. "Foo.Bar.Baz" which is an alias of "Foo" or "Foo.Bar".
NestedDeclAlias !Name !Name -- shorter name, longer name
| StrayConstructor !Name
deriving stock (Show)

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

View File

@ -10,4 +10,4 @@ data TwoOrThreeWay a = TwoOrThreeWay
alice :: a, alice :: a,
bob :: a bob :: a
} }
deriving stock (Functor, Generic) deriving stock (Foldable, Functor, Generic, Traversable)

View File

@ -27,7 +27,6 @@ library
Unison.Merge.EitherWayI Unison.Merge.EitherWayI
Unison.Merge.Libdeps Unison.Merge.Libdeps
Unison.Merge.PartitionCombinedDiffs Unison.Merge.PartitionCombinedDiffs
Unison.Merge.PreconditionViolation
Unison.Merge.Synhash Unison.Merge.Synhash
Unison.Merge.Synhashed Unison.Merge.Synhashed
Unison.Merge.ThreeWay Unison.Merge.ThreeWay

View File

@ -17,6 +17,7 @@ dependencies:
- bytes - bytes
- bytestring - bytestring
- containers - containers
- Diff
- directory - directory
- errors - errors
- extra - extra

View File

@ -14,6 +14,7 @@ module Unison.Server.Backend
FoundRef (..), FoundRef (..),
IncludeCycles (..), IncludeCycles (..),
DefinitionResults (..), DefinitionResults (..),
SyntaxText,
-- * Endpoints -- * Endpoints
fuzzyFind, fuzzyFind,
@ -66,7 +67,9 @@ module Unison.Server.Backend
-- * Re-exported for Share Server -- * Re-exported for Share Server
termsToSyntax, termsToSyntax,
termsToSyntaxOf,
typesToSyntax, typesToSyntax,
typesToSyntaxOf,
definitionResultsDependencies, definitionResultsDependencies,
evalDocRef, evalDocRef,
mkTermDefinition, mkTermDefinition,
@ -88,7 +91,6 @@ import Data.Set qualified as Set
import Data.Text qualified as Text import Data.Text qualified as Text
import Data.Text.Encoding qualified as TextE import Data.Text.Encoding qualified as TextE
import Data.Text.Lazy (toStrict) import Data.Text.Lazy (toStrict)
import Data.Tuple.Extra (dupe)
import Data.Yaml qualified as Yaml import Data.Yaml qualified as Yaml
import Lucid qualified import Lucid qualified
import System.Directory import System.Directory
@ -148,7 +150,7 @@ import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Project.Util qualified as ProjectUtils import Unison.Project.Util qualified as ProjectUtils
import Unison.Reference (Reference, TermReference) import Unison.Reference (Reference, TermReference, TypeReference)
import Unison.Reference qualified as Reference import Unison.Reference qualified as Reference
import Unison.Referent (Referent) import Unison.Referent (Referent)
import Unison.Referent qualified as Referent import Unison.Referent qualified as Referent
@ -845,14 +847,13 @@ docsForDefinitionName ::
NameSearch Sqlite.Transaction -> NameSearch Sqlite.Transaction ->
Names.SearchType -> Names.SearchType ->
Name -> Name ->
IO [TermReference] Sqlite.Transaction [TermReference]
docsForDefinitionName codebase (NameSearch {termSearch}) searchType name = do docsForDefinitionName codebase (NameSearch {termSearch}) searchType name = do
let potentialDocNames = [name, name Cons.:> NameSegment.docSegment] let potentialDocNames = [name, name Cons.:> NameSegment.docSegment]
Codebase.runTransaction codebase do refs <-
refs <- potentialDocNames & foldMapM \name ->
potentialDocNames & foldMapM \name -> lookupRelativeHQRefs' termSearch searchType (HQ'.NameOnly name)
lookupRelativeHQRefs' termSearch searchType (HQ'.NameOnly name) filterForDocs (toList refs)
filterForDocs (toList refs)
where where
filterForDocs :: [Referent] -> Sqlite.Transaction [TermReference] filterForDocs :: [Referent] -> Sqlite.Transaction [TermReference]
filterForDocs rs = do filterForDocs rs = do
@ -1119,19 +1120,55 @@ displayType codebase = \case
decl <- Codebase.unsafeGetTypeDeclaration codebase rid decl <- Codebase.unsafeGetTypeDeclaration codebase rid
pure (UserObject decl) pure (UserObject decl)
-- | Version of 'termsToSyntax' which works over arbitrary traversals.
--
-- E.g.
-- @@
-- termsToSyntaxOf suff width pped traversed [(ref, dispObj)]
--
-- or
--
-- termsToSyntaxOf suff width pped id (ref, dispObj)
--
-- or
--
-- termsToSyntaxOf suff width pped Map.asList_ (Map.singleton ref dispObj)
-- @@
-- e.g. 'traversed'
termsToSyntaxOf ::
(Var v) =>
(Ord a) =>
Suffixify ->
Width ->
PPED.PrettyPrintEnvDecl ->
Traversal s t (TermReference, DisplayObject (Type v a) (Term v a)) (TermReference, DisplayObject SyntaxText SyntaxText) ->
s ->
t
termsToSyntaxOf suff width ppe0 trav s =
s & over (unsafePartsOf trav) (\displayObjs -> termsToSyntax suff width ppe0 displayObjs)
-- | Converts Type Display Objects into Syntax Text.
termsToSyntax :: termsToSyntax ::
(Var v) => (Var v) =>
(Ord a) => (Ord a) =>
Suffixify -> Suffixify ->
Width -> Width ->
PPED.PrettyPrintEnvDecl -> PPED.PrettyPrintEnvDecl ->
Map Reference.Reference (DisplayObject (Type v a) (Term v a)) -> [(TermReference, (DisplayObject (Type v a) (Term v a)))] ->
Map Reference.Reference (DisplayObject SyntaxText SyntaxText) [(TermReference, DisplayObject SyntaxText SyntaxText)]
termsToSyntax suff width ppe0 terms = termsToSyntax suff width ppe0 terms =
Map.fromList . map go . Map.toList $ terms
Map.mapKeys <&> \(r, dispObj) ->
(first (PPE.termName ppeDecl . Referent.Ref) . dupe) let n = PPE.termName ppeDecl . Referent.Ref $ r
terms in (r,) case dispObj of
DisplayObject.BuiltinObject typ ->
DisplayObject.BuiltinObject $
formatType' (ppeBody r) width typ
DisplayObject.MissingObject sh -> DisplayObject.MissingObject sh
DisplayObject.UserObject tm ->
DisplayObject.UserObject
. Pretty.render width
$ TermPrinter.prettyBinding (ppeBody r) n tm
where where
ppeBody r = ppeBody r =
if suffixified suff if suffixified suff
@ -1139,41 +1176,57 @@ termsToSyntax suff width ppe0 terms =
else PPE.declarationPPE ppe0 r else PPE.declarationPPE ppe0 r
ppeDecl = ppeDecl =
(if suffixified suff then PPED.suffixifiedPPE else PPED.unsuffixifiedPPE) ppe0 (if suffixified suff then PPED.suffixifiedPPE else PPED.unsuffixifiedPPE) ppe0
go ((n, r), dt) = (r,) $ case dt of
DisplayObject.BuiltinObject typ ->
DisplayObject.BuiltinObject $
formatType' (ppeBody r) width typ
DisplayObject.MissingObject sh -> DisplayObject.MissingObject sh
DisplayObject.UserObject tm ->
DisplayObject.UserObject
. Pretty.render width
$ TermPrinter.prettyBinding (ppeBody r) n tm
-- | Version of 'typesToSyntax' which works over arbitrary traversals.
--
-- E.g.
-- @@
-- typesToSyntaxOf suff width pped traversed [(ref, dispObj)]
--
-- or
--
-- typesToSyntaxOf suff width pped id (ref, dispObj)
--
-- or
--
-- typesToSyntaxOf suff width pped Map.asList_ (Map.singleton ref dispObj)
-- @@
typesToSyntaxOf ::
(Var v) =>
(Ord a) =>
Suffixify ->
Width ->
PPED.PrettyPrintEnvDecl ->
Traversal s t (TypeReference, DisplayObject () (DD.Decl v a)) (TypeReference, DisplayObject SyntaxText SyntaxText) ->
s ->
t
typesToSyntaxOf suff width ppe0 trav s =
s & over (unsafePartsOf trav) (typesToSyntax suff width ppe0)
-- | Converts Type Display Objects into Syntax Text.
typesToSyntax :: typesToSyntax ::
(Var v) => (Var v) =>
(Ord a) => (Ord a) =>
Suffixify -> Suffixify ->
Width -> Width ->
PPED.PrettyPrintEnvDecl -> PPED.PrettyPrintEnvDecl ->
Map Reference.Reference (DisplayObject () (DD.Decl v a)) -> [(TypeReference, (DisplayObject () (DD.Decl v a)))] ->
Map Reference.Reference (DisplayObject SyntaxText SyntaxText) [(TypeReference, (DisplayObject SyntaxText SyntaxText))]
typesToSyntax suff width ppe0 types = typesToSyntax suff width ppe0 types =
Map.fromList $ types
map go . Map.toList $ <&> \(r, dispObj) ->
Map.mapKeys let n = PPE.typeName ppeDecl r
(first (PPE.typeName ppeDecl) . dupe) in (r,) $ case dispObj of
types BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r)
MissingObject sh -> MissingObject sh
UserObject d ->
UserObject . Pretty.render width $
DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d
where where
ppeDecl = ppeDecl =
if suffixified suff if suffixified suff
then PPED.suffixifiedPPE ppe0 then PPED.suffixifiedPPE ppe0
else PPED.unsuffixifiedPPE ppe0 else PPED.unsuffixifiedPPE ppe0
go ((n, r), dt) = (r,) $ case dt of
BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r)
MissingObject sh -> MissingObject sh
UserObject d ->
UserObject . Pretty.render width $
DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d
-- | Renders a type to its decl header, e.g. -- | Renders a type to its decl header, e.g.
-- --

View File

@ -0,0 +1,63 @@
-- | Utilities for displaying diffs between definitions.
module Unison.Server.Backend.DefinitionDiff
( diffDisplayObjects,
)
where
import Data.Algorithm.Diff qualified as Diff
import Data.Foldable qualified as Foldable
import Data.Function
import Data.List qualified as List
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
import Unison.Prelude
import Unison.Server.Syntax (SyntaxText)
import Unison.Server.Syntax qualified as Syntax
import Unison.Server.Types (DisplayObjectDiff (..), SemanticSyntaxDiff (..))
import Unison.Util.AnnotatedText (AnnotatedText (..))
import Unison.Util.AnnotatedText qualified as AT
diffDisplayObjects :: HasCallStack => DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff
diffDisplayObjects from to = case (from, to) of
(BuiltinObject fromST, BuiltinObject toST) -> DisplayObjectDiff (BuiltinObject (diffSyntaxText fromST toST))
(MissingObject fromSH, MissingObject toSH)
| fromSH == toSH -> DisplayObjectDiff (MissingObject fromSH)
| otherwise -> MismatchedDisplayObjects (MissingObject fromSH) (MissingObject toSH)
(UserObject fromST, UserObject toST) -> DisplayObjectDiff (UserObject (diffSyntaxText fromST toST))
(l, r) -> MismatchedDisplayObjects l r
diffSyntaxText :: SyntaxText -> SyntaxText -> [SemanticSyntaxDiff]
diffSyntaxText (AnnotatedText fromST) (AnnotatedText toST) =
Diff.getGroupedDiffBy
diffEq
(Foldable.toList @Seq fromST)
(Foldable.toList @Seq toST)
& expandSpecialCases
where
-- We special-case situations where the name of a definition changed but its hash didn't;
-- and cases where the name didn't change but the hash did.
-- So, we treat these elements as equal then detect them in a post-processing step.
diffEq :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Bool
diffEq (AT.Segment {segment = fromSegment, annotation = fromAnnotation}) (AT.Segment {segment = toSegment, annotation = toAnnotation}) =
fromSegment == toSegment || fromAnnotation == toAnnotation
expandSpecialCases :: [Diff.Diff [AT.Segment (Syntax.Element)]] -> [SemanticSyntaxDiff]
expandSpecialCases xs =
xs
& foldMap \case
Diff.First ys -> [Old ys]
Diff.Second ys -> [New ys]
Diff.Both from to ->
-- Each list should always be the same length.
zipWith detectSpecialCase from to
& (flip List.foldr [])
( \next acc -> case (acc, next) of
(Both xs : rest, Left seg) -> Both (seg : xs) : rest
(_, Left seg) -> Both [seg] : acc
(_, Right diff) -> diff : acc
)
detectSpecialCase :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Either (AT.Segment Syntax.Element) SemanticSyntaxDiff
detectSpecialCase fromSegment toSegment
| fromSegment == toSegment = Left fromSegment
| AT.annotation fromSegment == AT.annotation toSegment = Right (SegmentChange (AT.segment fromSegment, AT.segment toSegment) (AT.annotation fromSegment))
| AT.segment fromSegment == AT.segment toSegment = Right (AnnotationChange (AT.segment fromSegment) (AT.annotation fromSegment, AT.annotation toSegment))
| otherwise = error "diffSyntaxText: found Syntax Elements in 'both' which have nothing in common."

View File

@ -48,6 +48,7 @@ import Servant
serve, serve,
throwError, throwError,
) )
import Servant qualified as Servant
import Servant.API import Servant.API
( Accept (..), ( Accept (..),
Capture, Capture,
@ -60,11 +61,13 @@ import Servant.API
) )
import Servant.Docs import Servant.Docs
( DocIntro (DocIntro), ( DocIntro (DocIntro),
ToParam (..),
ToSample (..), ToSample (..),
docsWithIntros, docsWithIntros,
markdown, markdown,
singleSample, singleSample,
) )
import Servant.Docs qualified as Servant
import Servant.OpenApi (HasOpenApi (toOpenApi)) import Servant.OpenApi (HasOpenApi (toOpenApi))
import Servant.Server import Servant.Server
( Application, ( Application,
@ -85,17 +88,24 @@ import System.Random.MWC (createSystemRandom)
import U.Codebase.HashTags (CausalHash) import U.Codebase.HashTags (CausalHash)
import Unison.Codebase (Codebase) import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Runtime qualified as Rt import Unison.Codebase.Runtime qualified as Rt
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.HashQualified import Unison.HashQualified
import Unison.HashQualified qualified as HQ
import Unison.Name as Name (Name, segments) import Unison.Name as Name (Name, segments)
import Unison.Parser.Ann (Ann) import Unison.Parser.Ann (Ann)
import Unison.Prelude import Unison.Prelude
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl)
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Server.Backend (Backend, BackendEnv, runBackend) import Unison.Server.Backend (Backend, BackendEnv, runBackend)
import Unison.Server.Backend qualified as Backend import Unison.Server.Backend qualified as Backend
import Unison.Server.Backend.DefinitionDiff qualified as DefinitionDiff
import Unison.Server.Errors (backendError) import Unison.Server.Errors (backendError)
import Unison.Server.Local.Definitions qualified as Defn
import Unison.Server.Local.Endpoints.DefinitionSummary (TermSummaryAPI, TypeSummaryAPI, serveTermSummary, serveTypeSummary) import Unison.Server.Local.Endpoints.DefinitionSummary (TermSummaryAPI, TypeSummaryAPI, serveTermSummary, serveTypeSummary)
import Unison.Server.Local.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind) import Unison.Server.Local.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind)
import Unison.Server.Local.Endpoints.GetDefinitions import Unison.Server.Local.Endpoints.GetDefinitions
@ -106,10 +116,17 @@ import Unison.Server.Local.Endpoints.NamespaceDetails qualified as NamespaceDeta
import Unison.Server.Local.Endpoints.NamespaceListing qualified as NamespaceListing import Unison.Server.Local.Endpoints.NamespaceListing qualified as NamespaceListing
import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, ListProjectsEndpoint, projectBranchListingEndpoint, projectListingEndpoint) import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, ListProjectsEndpoint, projectBranchListingEndpoint, projectListingEndpoint)
import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer) import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer)
import Unison.Server.Types (mungeString, setCacheControl) import Unison.Server.NameSearch (NameSearch (..))
import Unison.Server.NameSearch.FromNames qualified as Names
import Unison.Server.Types (TermDefinition (..), TermDiffResponse (..), TypeDefinition (..), TypeDiffResponse (..), mungeString, setCacheControl)
import Unison.ShortHash qualified as ShortHash import Unison.ShortHash qualified as ShortHash
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol) import Unison.Symbol (Symbol)
import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Syntax.NameSegment qualified as NameSegment
import Unison.Util.Pretty qualified as Pretty
-- | Fail the route with a reasonable error if the query param is missing.
type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict]
-- HTML content type -- HTML content type
data HTML = HTML data HTML = HTML
@ -143,8 +160,51 @@ type CodebaseServerAPI =
type ProjectsAPI = type ProjectsAPI =
ListProjectsEndpoint ListProjectsEndpoint
:<|> (Capture "project-name" ProjectName :> "branches" :> ListProjectBranchesEndpoint) :<|> ( Capture "project-name" ProjectName
:<|> (Capture "project-name" ProjectName :> "branches" :> Capture "branch-name" ProjectBranchName :> CodebaseServerAPI) :> ( ( "branches"
:> ( ListProjectBranchesEndpoint
:<|> (Capture "branch-name" ProjectBranchName :> CodebaseServerAPI)
)
)
:<|> ( "diff"
:> ( "terms" :> ProjectDiffTermsEndpoint
:<|> "types" :> ProjectDiffTypesEndpoint
)
)
)
)
type ProjectDiffTermsEndpoint =
RequiredQueryParam "oldBranchRef" ProjectBranchName
:> RequiredQueryParam "newBranchRef" ProjectBranchName
:> RequiredQueryParam "oldTerm" Name
:> RequiredQueryParam "newTerm" Name
:> Get '[JSON] TermDiffResponse
type ProjectDiffTypesEndpoint =
RequiredQueryParam "oldBranchRef" ProjectBranchName
:> RequiredQueryParam "newBranchRef" ProjectBranchName
:> RequiredQueryParam "oldType" Name
:> RequiredQueryParam "newType" Name
:> Get '[JSON] TypeDiffResponse
instance ToParam (Servant.QueryParam' mods "oldBranchRef" a) where
toParam _ = Servant.DocQueryParam "oldBranchRef" ["main"] "The name of the old branch" Servant.Normal
instance ToParam (Servant.QueryParam' mods "newBranchRef" a) where
toParam _ = Servant.DocQueryParam "newBranchRef" ["main"] "The name of the new branch" Servant.Normal
instance ToParam (Servant.QueryParam' mods "oldTerm" a) where
toParam _ = Servant.DocQueryParam "oldTerm" ["main"] "The name of the old term" Servant.Normal
instance ToParam (Servant.QueryParam' mods "newTerm" a) where
toParam _ = Servant.DocQueryParam "newTerm" ["main"] "The name of the new term" Servant.Normal
instance ToParam (Servant.QueryParam' mods "oldType" a) where
toParam _ = Servant.DocQueryParam "oldType" ["main"] "The name of the old type" Servant.Normal
instance ToParam (Servant.QueryParam' mods "newType" a) where
toParam _ = Servant.DocQueryParam "newType" ["main"] "The name of the new type" Servant.Normal
type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml
@ -529,40 +589,94 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do
where where
projectAndBranchName = ProjectAndBranch projectName branchName projectAndBranchName = ProjectAndBranch projectName branchName
namespaceListingEndpoint _rootParam rel name = do namespaceListingEndpoint _rootParam rel name = do
root <- resolveProjectRoot root <- resolveProjectRoot codebase projectAndBranchName
setCacheControl <$> NamespaceListing.serve codebase (Just root) rel name setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name
namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do
root <- resolveProjectRoot root <- resolveProjectRoot codebase projectAndBranchName
setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just root) renderWidth setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth
serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do
root <- resolveProjectRoot root <- resolveProjectRoot codebase projectAndBranchName
setCacheControl <$> serveDefinitions rt codebase (Just root) relativePath rawHqns renderWidth suff setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff
serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do
root <- resolveProjectRoot root <- resolveProjectRoot codebase projectAndBranchName
setCacheControl <$> serveFuzzyFind codebase (Just root) relativePath limit renderWidth query setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query
serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
root <- resolveProjectRoot root <- resolveProjectRoot codebase projectAndBranchName
setCacheControl <$> serveTermSummary codebase shortHash mayName (Just root) relativeTo renderWidth setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth
serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
root <- resolveProjectRoot root <- resolveProjectRoot codebase projectAndBranchName
setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just root) relativeTo renderWidth setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth
resolveProjectRoot :: Backend IO (Either ShortCausalHash CausalHash) resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash
resolveProjectRoot = do resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do
mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName
case mayCH of case mayCH of
Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName)
Just ch -> pure (Right ch) Just ch -> pure ch
serveProjectDiffTermsEndpoint :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ProjectName -> ProjectBranchName -> ProjectBranchName -> Name -> Name -> Backend IO TermDiffResponse
serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef oldTerm newTerm = do
(oldPPED, oldNameSearch) <- contextForProjectBranch codebase projectName oldBranchRef
(newPPED, newNameSearch) <- contextForProjectBranch codebase projectName newBranchRef
oldTerm@TermDefinition {termDefinition = oldTermDispObject} <- Defn.termDefinitionByName codebase oldPPED oldNameSearch width rt oldTerm `whenNothingM` throwError (Backend.NoSuchDefinition (HQ.NameOnly oldTerm))
newTerm@TermDefinition {termDefinition = newTermDisplayObj} <- Defn.termDefinitionByName codebase newPPED newNameSearch width rt newTerm `whenNothingM` throwError (Backend.NoSuchDefinition (HQ.NameOnly newTerm))
let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldTermDispObject newTermDisplayObj
pure
TermDiffResponse
{ project = projectName,
oldBranch = oldBranchRef,
newBranch = newBranchRef,
oldTerm = oldTerm,
newTerm = newTerm,
diff = termDiffDisplayObject
}
where
width = Pretty.Width 80
contextForProjectBranch :: (Codebase IO v a) -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction)
contextForProjectBranch codebase projectName branchName = do
projectRootHash <- resolveProjectRoot codebase (ProjectAndBranch projectName branchName)
projectRootBranch <- liftIO $ Codebase.expectBranchForHash codebase projectRootHash
hashLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength
let names = Branch.toNames (Branch.head projectRootBranch)
let pped = PPED.makePPED (PPE.hqNamer hashLength names) (PPE.suffixifyByHash names)
let nameSearch = Names.makeNameSearch hashLength names
pure (pped, nameSearch)
serveProjectDiffTypesEndpoint :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ProjectName -> ProjectBranchName -> ProjectBranchName -> Name -> Name -> Backend IO TypeDiffResponse
serveProjectDiffTypesEndpoint codebase rt projectName oldBranchRef newBranchRef oldType newType = do
(oldPPED, oldNameSearch) <- contextForProjectBranch codebase projectName oldBranchRef
(newPPED, newNameSearch) <- contextForProjectBranch codebase projectName newBranchRef
oldType@TypeDefinition {typeDefinition = oldTypeDispObj} <- Defn.typeDefinitionByName codebase oldPPED oldNameSearch width rt oldType `whenNothingM` throwError (Backend.NoSuchDefinition (HQ.NameOnly oldType))
newType@TypeDefinition {typeDefinition = newTypeDisplayObj} <- Defn.typeDefinitionByName codebase newPPED newNameSearch width rt newType `whenNothingM` throwError (Backend.NoSuchDefinition (HQ.NameOnly newType))
let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldTypeDispObj newTypeDisplayObj
pure
TypeDiffResponse
{ project = projectName,
oldBranch = oldBranchRef,
newBranch = newBranchRef,
oldType = oldType,
newType = newType,
diff = typeDiffDisplayObject
}
where
width = Pretty.Width 80
serveProjectsAPI :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ServerT ProjectsAPI (Backend IO) serveProjectsAPI :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ServerT ProjectsAPI (Backend IO)
serveProjectsAPI codebase rt = serveProjectsAPI codebase rt =
projectListingEndpoint codebase projectListingEndpoint codebase
:<|> projectBranchListingEndpoint codebase :<|> ( \projectName ->
:<|> serveProjectsCodebaseServerAPI codebase rt ( projectBranchListingEndpoint codebase projectName
:<|> serveProjectsCodebaseServerAPI codebase rt projectName
)
:<|> ( serveProjectDiffTermsEndpoint codebase rt projectName
:<|> serveProjectDiffTypesEndpoint codebase rt projectName
)
)
serveUnisonLocal :: serveUnisonLocal ::
BackendEnv -> BackendEnv ->

View File

@ -1,16 +1,28 @@
module Unison.Server.Local.Definitions (prettyDefinitionsForHQName) where module Unison.Server.Local.Definitions
( prettyDefinitionsForHQName,
termDefinitionByName,
typeDefinitionByName,
)
where
import Control.Lens hiding ((??)) import Control.Lens hiding ((??))
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Trans.Maybe (mapMaybeT)
import Data.Map qualified as Map import Data.Map qualified as Map
import Data.Set.NonEmpty qualified as NESet
import U.Codebase.Branch qualified as V2Branch import U.Codebase.Branch qualified as V2Branch
import U.Codebase.Causal qualified as V2Causal import U.Codebase.Causal qualified as V2Causal
import U.Codebase.Reference (TermReference, TypeReference)
import Unison.Codebase (Codebase) import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.DisplayObject (DisplayObject)
import Unison.Codebase.Path (Path) import Unison.Codebase.Path (Path)
import Unison.Codebase.Runtime qualified as Rt import Unison.Codebase.Runtime qualified as Rt
import Unison.DataDeclaration qualified as DD
import Unison.HashQualified qualified as HQ import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ'
import Unison.Name (Name) import Unison.Name (Name)
import Unison.NamesWithHistory qualified as NS
import Unison.NamesWithHistory qualified as Names import Unison.NamesWithHistory qualified as Names
import Unison.Parser.Ann (Ann) import Unison.Parser.Ann (Ann)
import Unison.Prelude import Unison.Prelude
@ -19,13 +31,20 @@ import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Reference qualified as Reference import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent import Unison.Referent qualified as Referent
import Unison.Server.Backend import Unison.Server.Backend
import Unison.Server.Backend qualified as Backend
import Unison.Server.Doc qualified as Doc import Unison.Server.Doc qualified as Doc
import Unison.Server.Local qualified as Local import Unison.Server.Local qualified as Local
import Unison.Server.NameSearch (NameSearch)
import Unison.Server.NameSearch qualified as NS
import Unison.Server.NameSearch qualified as NameSearch
import Unison.Server.NameSearch.FromNames (makeNameSearch) import Unison.Server.NameSearch.FromNames (makeNameSearch)
import Unison.Server.Types import Unison.Server.Types
import Unison.Sqlite qualified as Sqlite import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol) import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Syntax.HashQualified qualified as HQ (toText)
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Util.Map qualified as Map
import Unison.Util.Pretty (Width) import Unison.Util.Pretty (Width)
-- | Renders a definition for the given name or hash alongside its documentation. -- | Renders a definition for the given name or hash alongside its documentation.
@ -70,19 +89,19 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings
let width = mayDefaultWidth renderWidth let width = mayDefaultWidth renderWidth
let docResults :: Name -> IO [(HashQualifiedName, UnisonHash, Doc.Doc)] let docResults :: Name -> IO [(HashQualifiedName, UnisonHash, Doc.Doc)]
docResults name = do docResults name = do
docRefs <- docsForDefinitionName codebase nameSearch Names.ExactName name docRefs <- Codebase.runTransaction codebase $ docsForDefinitionName codebase nameSearch Names.ExactName name
renderDocRefs pped width codebase rt docRefs renderDocRefs pped width codebase rt docRefs
-- local server currently ignores doc eval errors -- local server currently ignores doc eval errors
<&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc) <&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc)
let fqnPPE = PPED.unsuffixifiedPPE pped let fqnPPE = PPED.unsuffixifiedPPE pped
typeDefinitions <- typeDefinitions <-
ifor (typesToSyntax suffixifyBindings width pped types) \ref tp -> do ifor (typesToSyntaxOf suffixifyBindings width pped (Map.asList_ . traversed) types) \ref tp -> do
let hqTypeName = PPE.typeNameOrHashOnly fqnPPE ref let hqTypeName = PPE.typeNameOrHashOnly fqnPPE ref
docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTypeName)) docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTypeName))
mkTypeDefinition codebase pped width ref docs tp mkTypeDefinition codebase pped width ref docs tp
termDefinitions <- termDefinitions <-
ifor (termsToSyntax suffixifyBindings width pped terms) \reference trm -> do ifor (termsToSyntaxOf suffixifyBindings width pped (Map.asList_ . traversed) terms) \reference trm -> do
let referent = Referent.Ref reference let referent = Referent.Ref reference
let hqTermName = PPE.termNameOrHashOnly fqnPPE referent let hqTermName = PPE.termNameOrHashOnly fqnPPE referent
docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTermName)) docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTermName))
@ -95,3 +114,66 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings
renderedDisplayTerms renderedDisplayTerms
renderedDisplayTypes renderedDisplayTypes
renderedMisses renderedMisses
-- | Find the term referenced by the given name and return a display object for it.
termDisplayObjectByName :: Codebase m Symbol Ann -> NameSearch Sqlite.Transaction -> Name -> Sqlite.Transaction (Maybe (TermReference, DisplayObject (Type Symbol Ann) (Term Symbol Ann)))
termDisplayObjectByName codebase nameSearch name = runMaybeT do
refs <- lift $ NameSearch.lookupRelativeHQRefs' (NS.termSearch nameSearch) NS.ExactName (HQ'.NameOnly name)
ref <- fmap NESet.findMin . hoistMaybe $ NESet.nonEmptySet refs
case ref of
Referent.Ref r -> (r,) <$> lift (Backend.displayTerm codebase r)
Referent.Con _ _ ->
-- TODO: Should we error here or some other sensible thing rather than returning no
-- result?
empty
termDefinitionByName ::
Codebase IO Symbol Ann ->
PPED.PrettyPrintEnvDecl ->
NameSearch Sqlite.Transaction ->
Width ->
Rt.Runtime Symbol ->
Name ->
Backend IO (Maybe TermDefinition)
termDefinitionByName codebase pped nameSearch width rt name = runMaybeT $ do
let biasedPPED = PPED.biasTo [name] pped
(ref, displayObject, docRefs) <- mapMaybeT (liftIO . Codebase.runTransaction codebase) $ do
(ref, displayObject) <- MaybeT $ termDisplayObjectByName codebase nameSearch name
docRefs <- lift $ Backend.docsForDefinitionName codebase nameSearch NS.ExactName name
pure (ref, displayObject, docRefs)
renderedDocs <-
liftIO $
renderDocRefs pped width codebase rt docRefs
-- local server currently ignores doc eval errors
<&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc)
let (_ref, syntaxDO) = Backend.termsToSyntaxOf (Suffixify False) width pped id (ref, displayObject)
lift $ Backend.mkTermDefinition codebase biasedPPED width ref renderedDocs syntaxDO
-- | Find the type referenced by the given name and return a display object for it.
typeDisplayObjectByName :: Codebase m Symbol Ann -> NameSearch Sqlite.Transaction -> Name -> Sqlite.Transaction (Maybe (TypeReference, DisplayObject () (DD.Decl Symbol Ann)))
typeDisplayObjectByName codebase nameSearch name = runMaybeT do
refs <- lift $ NameSearch.lookupRelativeHQRefs' (NS.typeSearch nameSearch) NS.ExactName (HQ'.NameOnly name)
ref <- fmap NESet.findMin . hoistMaybe $ NESet.nonEmptySet refs
fmap (ref,) . lift $ Backend.displayType codebase ref
typeDefinitionByName ::
Codebase IO Symbol Ann ->
PPED.PrettyPrintEnvDecl ->
NameSearch Sqlite.Transaction ->
Width ->
Rt.Runtime Symbol ->
Name ->
Backend IO (Maybe TypeDefinition)
typeDefinitionByName codebase pped nameSearch width rt name = runMaybeT $ do
let biasedPPED = PPED.biasTo [name] pped
(ref, displayObject, docRefs) <- mapMaybeT (liftIO . Codebase.runTransaction codebase) $ do
(ref, displayObject) <- MaybeT $ typeDisplayObjectByName codebase nameSearch name
docRefs <- lift $ Backend.docsForDefinitionName codebase nameSearch NS.ExactName name
pure (ref, displayObject, docRefs)
renderedDocs <-
liftIO $
renderDocRefs pped width codebase rt docRefs
-- local server currently ignores doc eval errors
<&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc)
let (_ref, syntaxDO) = Backend.typesToSyntaxOf (Suffixify False) width pped id (ref, displayObject)
lift $ Backend.mkTypeDefinition codebase biasedPPED width ref renderedDocs syntaxDO

View File

@ -38,15 +38,16 @@ import U.Codebase.HashTags
import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Editor.DisplayObject (DisplayObject)
import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path qualified as Path
import Unison.Core.Project (ProjectBranchName)
import Unison.Hash qualified as Hash import Unison.Hash qualified as Hash
import Unison.HashQualified qualified as HQ import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ' import Unison.HashQualified' qualified as HQ'
import Unison.Name (Name) import Unison.Name (Name)
import Unison.Prelude import Unison.Prelude
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) import Unison.Project (ProjectAndBranch, ProjectName)
import Unison.Server.Doc (Doc) import Unison.Server.Doc (Doc)
import Unison.Server.Orphans () import Unison.Server.Orphans ()
import Unison.Server.Syntax (SyntaxText) import Unison.Server.Syntax qualified as Syntax
import Unison.ShortHash (ShortHash) import Unison.ShortHash (ShortHash)
import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Syntax.HashQualified qualified as HQ (parseText)
import Unison.Syntax.Name qualified as Name import Unison.Syntax.Name qualified as Name
@ -191,6 +192,20 @@ instance ToJSON DefinitionDisplayResults where
deriving instance ToSchema DefinitionDisplayResults deriving instance ToSchema DefinitionDisplayResults
data TermDefinitionDiff = TermDefinitionDiff
{ left :: TermDefinition,
right :: TermDefinition,
diff :: DisplayObjectDiff
}
deriving (Eq, Show, Generic)
data TypeDefinitionDiff = TypeDefinitionDiff
{ left :: TypeDefinition,
right :: TypeDefinition,
diff :: DisplayObjectDiff
}
deriving (Eq, Show, Generic)
newtype Suffixify = Suffixify {suffixified :: Bool} newtype Suffixify = Suffixify {suffixified :: Bool}
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
@ -198,8 +213,8 @@ data TermDefinition = TermDefinition
{ termNames :: [HashQualifiedName], { termNames :: [HashQualifiedName],
bestTermName :: HashQualifiedName, bestTermName :: HashQualifiedName,
defnTermTag :: TermTag, defnTermTag :: TermTag,
termDefinition :: DisplayObject SyntaxText SyntaxText, termDefinition :: DisplayObject Syntax.SyntaxText Syntax.SyntaxText,
signature :: SyntaxText, signature :: Syntax.SyntaxText,
termDocs :: [(HashQualifiedName, UnisonHash, Doc)] termDocs :: [(HashQualifiedName, UnisonHash, Doc)]
} }
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
@ -208,7 +223,7 @@ data TypeDefinition = TypeDefinition
{ typeNames :: [HashQualifiedName], { typeNames :: [HashQualifiedName],
bestTypeName :: HashQualifiedName, bestTypeName :: HashQualifiedName,
defnTypeTag :: TypeTag, defnTypeTag :: TypeTag,
typeDefinition :: DisplayObject SyntaxText SyntaxText, typeDefinition :: DisplayObject Syntax.SyntaxText Syntax.SyntaxText,
typeDocs :: [(HashQualifiedName, UnisonHash, Doc)] typeDocs :: [(HashQualifiedName, UnisonHash, Doc)]
} }
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
@ -233,6 +248,64 @@ data TermTag = Doc | Test | Plain | Constructor TypeTag
data TypeTag = Ability | Data data TypeTag = Ability | Data
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
-- | A type for semantic diffing of definitions.
-- Includes special-cases for when the name in a definition has changed but the hash hasn't
-- (rename/alias), and when the hash has changed but the name hasn't (update propagation).
data SemanticSyntaxDiff
= Old [Syntax.SyntaxSegment]
| New [Syntax.SyntaxSegment]
| Both [Syntax.SyntaxSegment]
| -- (fromSegment, toSegment) (shared annotation)
SegmentChange (String, String) (Maybe Syntax.Element)
| -- (shared segment) (fromAnnotation, toAnnotation)
AnnotationChange String (Maybe Syntax.Element, Maybe Syntax.Element)
deriving (Eq, Show, Generic)
deriving instance ToSchema SemanticSyntaxDiff
instance ToJSON SemanticSyntaxDiff where
toJSON = \case
Old segments ->
object
[ "diffTag" .= ("old" :: Text),
"elements" .= segments
]
New segments ->
object
[ "diffTag" .= ("new" :: Text),
"elements" .= segments
]
Both segments ->
object
[ "diffTag" .= ("both" :: Text),
"elements" .= segments
]
SegmentChange (fromSegment, toSegment) annotation ->
object
[ "diffTag" .= ("segmentChange" :: Text),
"fromSegment" .= fromSegment,
"toSegment" .= toSegment,
"annotation" .= annotation
]
AnnotationChange segment (fromAnnotation, toAnnotation) ->
object
[ "diffTag" .= ("annotationChange" :: Text),
"segment" .= segment,
"fromAnnotation" .= fromAnnotation,
"toAnnotation" .= toAnnotation
]
-- | A diff of the syntax of a term or type
--
-- It doesn't make sense to diff builtins with ABTs, so in that case we just provide the
-- undiffed syntax.
data DisplayObjectDiff
= DisplayObjectDiff (DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff])
| MismatchedDisplayObjects (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) (DisplayObject Syntax.SyntaxText Syntax.SyntaxText)
deriving stock (Show, Eq, Generic)
deriving instance ToSchema DisplayObjectDiff
data UnisonRef data UnisonRef
= TypeRef UnisonHash = TypeRef UnisonHash
| TermRef UnisonHash | TermRef UnisonHash
@ -247,7 +320,7 @@ data NamedTerm = NamedTerm
{ -- The name of the term, should be hash qualified if conflicted, otherwise name only. { -- The name of the term, should be hash qualified if conflicted, otherwise name only.
termName :: HQ'.HashQualified Name, termName :: HQ'.HashQualified Name,
termHash :: ShortHash, termHash :: ShortHash,
termType :: Maybe SyntaxText, termType :: Maybe Syntax.SyntaxText,
termTag :: TermTag termTag :: TermTag
} }
deriving (Eq, Generic, Show) deriving (Eq, Generic, Show)
@ -391,3 +464,79 @@ instance Docs.ToCapture (Capture "project-and-branch" ProjectBranchNameParam) wh
DocCapture DocCapture
"project-and-branch" "project-and-branch"
"The name of a project and branch e.g. `@unison%2Fbase%2Fmain` or `@unison%2Fbase%2F@runarorama%2Fmain`" "The name of a project and branch e.g. `@unison%2Fbase%2Fmain` or `@unison%2Fbase%2F@runarorama%2Fmain`"
data TermDiffResponse = TermDiffResponse
{ project :: ProjectName,
oldBranch :: ProjectBranchName,
newBranch :: ProjectBranchName,
oldTerm :: TermDefinition,
newTerm :: TermDefinition,
diff :: DisplayObjectDiff
}
deriving (Eq, Show, Generic)
deriving instance ToSchema TermDiffResponse
instance Docs.ToSample TermDiffResponse where
toSamples _ = []
instance ToJSON TermDiffResponse where
toJSON (TermDiffResponse {diff, project, oldBranch, newBranch, oldTerm, newTerm}) =
case diff of
DisplayObjectDiff dispDiff ->
object
[ "diff" .= dispDiff,
"diffKind" .= ("diff" :: Text),
"project" .= project,
"oldBranchRef" .= oldBranch,
"newBranchRef" .= newBranch,
"oldTerm" .= oldTerm,
"newTerm" .= newTerm
]
MismatchedDisplayObjects {} ->
object
[ "diffKind" .= ("mismatched" :: Text),
"project" .= project,
"oldBranchRef" .= oldBranch,
"newBranchRef" .= newBranch,
"oldTerm" .= oldTerm,
"newTerm" .= newTerm
]
data TypeDiffResponse = TypeDiffResponse
{ project :: ProjectName,
oldBranch :: ProjectBranchName,
newBranch :: ProjectBranchName,
oldType :: TypeDefinition,
newType :: TypeDefinition,
diff :: DisplayObjectDiff
}
deriving (Eq, Show, Generic)
deriving instance ToSchema TypeDiffResponse
instance Docs.ToSample TypeDiffResponse where
toSamples _ = []
instance ToJSON TypeDiffResponse where
toJSON (TypeDiffResponse {diff, project, oldBranch, newBranch, oldType, newType}) =
case diff of
DisplayObjectDiff dispDiff ->
object
[ "diff" .= dispDiff,
"diffKind" .= ("diff" :: Text),
"project" .= project,
"oldBranchRef" .= oldBranch,
"newBranchRef" .= newBranch,
"oldType" .= oldType,
"newType" .= newType
]
MismatchedDisplayObjects {} ->
object
[ "diffKind" .= ("mismatched" :: Text),
"project" .= project,
"oldBranchRef" .= oldBranch,
"newBranchRef" .= newBranch,
"oldType" .= oldType,
"newType" .= newType
]

View File

@ -18,6 +18,7 @@ source-repository head
library library
exposed-modules: exposed-modules:
Unison.Server.Backend Unison.Server.Backend
Unison.Server.Backend.DefinitionDiff
Unison.Server.CodebaseServer Unison.Server.CodebaseServer
Unison.Server.Doc Unison.Server.Doc
Unison.Server.Doc.AsHtml Unison.Server.Doc.AsHtml
@ -82,7 +83,8 @@ library
ImportQualifiedPost ImportQualifiedPost
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
NanoID Diff
, NanoID
, aeson >=2.0.0.0 , aeson >=2.0.0.0
, async , async
, base , base

View File

@ -34,6 +34,7 @@ module Unison.Share.API.Projects
ProjectBranchIds (..), ProjectBranchIds (..),
NotFound (..), NotFound (..),
Unauthorized (..), Unauthorized (..),
BranchName,
) )
where where

View File

@ -5,7 +5,7 @@ Next, we'll download the jit project and generate a few Racket files from it.
```ucm ```ucm
.> project.create-empty jit-setup .> 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 ```unison

View File

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

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

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

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

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

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

Some files were not shown because too many files have changed in this diff Show More