mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
Merge remote-tracking branch 'upstream/trunk' into restrict-NameSegment
This commit is contained in:
commit
5a7e001d7c
11
.editorconfig
Normal file
11
.editorconfig
Normal file
@ -0,0 +1,11 @@
|
|||||||
|
# Multi-editor style config: https://EditorConfig.org
|
||||||
|
|
||||||
|
root = true
|
||||||
|
|
||||||
|
[*]
|
||||||
|
charset = utf-8
|
||||||
|
end_of_line = lf
|
||||||
|
indent_style = space
|
||||||
|
insert_final_newline = true
|
||||||
|
max_line_length = 120
|
||||||
|
trim_trailing_whitespace = true
|
2
.github/workflows/ci.yaml
vendored
2
.github/workflows/ci.yaml
vendored
@ -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 }}"
|
||||||
|
4
.github/workflows/nix-dev-cache.yaml
vendored
4
.github/workflows/nix-dev-cache.yaml
vendored
@ -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
4
.gitignore
vendored
@ -24,5 +24,7 @@ dist-newstyle
|
|||||||
|
|
||||||
# Mac developers
|
# Mac developers
|
||||||
**/.DS_Store
|
**/.DS_Store
|
||||||
|
|
||||||
/libb2.dylib
|
/libb2.dylib
|
||||||
|
|
||||||
|
# Nix
|
||||||
|
result
|
||||||
|
@ -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:
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
```
|
```
|
||||||
|
22
flake.nix
22
flake.nix
@ -88,16 +88,22 @@
|
|||||||
'';
|
'';
|
||||||
};
|
};
|
||||||
};
|
};
|
||||||
|
|
||||||
|
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 =
|
||||||
|
nixpkgs-packages
|
||||||
|
// renameAttrs (name: "component-${name}") haskell-nix-flake.packages
|
||||||
|
// renameAttrs (name: "docker-${name}") (import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; })
|
||||||
|
// {
|
||||||
default = haskell-nix-flake.defaultPackage;
|
default = haskell-nix-flake.defaultPackage;
|
||||||
haskell-nix = haskell-nix-flake.packages;
|
|
||||||
docker = import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; };
|
|
||||||
build-tools = pkgs.symlinkJoin {
|
build-tools = pkgs.symlinkJoin {
|
||||||
name = "build-tools";
|
name = "build-tools";
|
||||||
paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs;
|
paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs;
|
||||||
@ -117,13 +123,15 @@
|
|||||||
};
|
};
|
||||||
};
|
};
|
||||||
|
|
||||||
apps = haskell-nix-flake.apps // {
|
apps = renameAttrs (name: "component-${name}") haskell-nix-flake.apps // {
|
||||||
default = self.apps."${system}"."unison-cli-main:exe:unison";
|
default = self.apps."${system}"."component-unison-cli-main:exe:unison";
|
||||||
};
|
};
|
||||||
|
|
||||||
devShells = nixpkgs-devShells // {
|
devShells =
|
||||||
|
nixpkgs-devShells
|
||||||
|
// renameAttrs (name: "cabal-${name}") haskell-nix-flake.devShells
|
||||||
|
// {
|
||||||
default = self.devShells."${system}".only-tools-nixpkgs;
|
default = self.devShells."${system}".only-tools-nixpkgs;
|
||||||
haskell-nix = haskell-nix-flake.devShells;
|
|
||||||
};
|
};
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
|
@ -12,6 +12,7 @@ dependencies:
|
|||||||
- base
|
- base
|
||||||
- bytestring
|
- bytestring
|
||||||
- containers
|
- containers
|
||||||
|
- directory
|
||||||
- generic-lens
|
- generic-lens
|
||||||
- either
|
- either
|
||||||
- extra
|
- extra
|
||||||
|
@ -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
|
||||||
|
@ -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,12 +237,17 @@ 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
|
||||||
|
Directory.doesFileExist path >>= \case
|
||||||
|
False -> writeUtf8 path txt
|
||||||
|
True -> do
|
||||||
let withTempFile tmpFilePath tmpHandle = do
|
let withTempFile tmpFilePath tmpHandle = do
|
||||||
|
Handle.hSetEncoding tmpHandle IO.utf8
|
||||||
Text.hPutStrLn tmpHandle txt
|
Text.hPutStrLn tmpHandle txt
|
||||||
IO.withFile path IO.ReadMode \currentScratchFile -> do
|
IO.withFile path IO.ReadMode \currentScratchFile -> do
|
||||||
|
Handle.hSetEncoding currentScratchFile IO.utf8
|
||||||
let copyLoop = do
|
let copyLoop = do
|
||||||
chunk <- Text.hGetChunk currentScratchFile
|
chunk <- Text.hGetChunk currentScratchFile
|
||||||
case Text.length chunk == 0 of
|
case Text.length chunk == 0 of
|
||||||
|
@ -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 =
|
||||||
|
@ -65,6 +65,7 @@ library
|
|||||||
base
|
base
|
||||||
, bytestring
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
|
, directory
|
||||||
, either
|
, either
|
||||||
, extra
|
, extra
|
||||||
, filepath
|
, filepath
|
||||||
|
@ -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" ];
|
||||||
};
|
};
|
||||||
}
|
}
|
||||||
|
@ -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
|
||||||
|
@ -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.
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
|
@ -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,
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
|
@ -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,23 +25,19 @@ 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)
|
|
||||||
Just hq -> do
|
|
||||||
let refs = Names.lookupHQTerm Names.IncludeSuffixes hq parseNames
|
|
||||||
let a = Parser.Ann.External
|
let a = Parser.Ann.External
|
||||||
case toList refs of
|
case toList refs of
|
||||||
[] -> pure (NotFound mainName)
|
[] -> pure (NotFound mainName)
|
||||||
@ -53,7 +48,7 @@ getMainTerm loadTypeOfTerm parseNames mainName mainType =
|
|||||||
if Typechecker.fitsScheme typ mainType
|
if Typechecker.fitsScheme typ mainType
|
||||||
then do
|
then do
|
||||||
let tm = DD.forceTerm a a (Term.ref a ref)
|
let tm = DD.forceTerm a a (Term.ref a ref)
|
||||||
return (Success hq tm typ)
|
return (Success mainName tm typ)
|
||||||
else pure (BadType mainName $ Just typ)
|
else pure (BadType mainName $ Just typ)
|
||||||
_ -> pure (BadType mainName Nothing)
|
_ -> pure (BadType mainName Nothing)
|
||||||
_ -> pure (error "multiple matching refs") -- TODO: make a real exception
|
_ -> pure (error "multiple matching refs") -- TODO: make a real exception
|
||||||
|
@ -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 aren’t
|
||||||
|
-- required to enter the full hash. However, these inputs may also come from an internal source, and in such cases,
|
||||||
|
-- there is no reason to truncate the hash.
|
||||||
|
fromFullHash :: (Coercible h Hash.Hash) => h -> ShortCausalHash
|
||||||
|
fromFullHash = ShortCausalHash . Hash.toBase32HexText . coerce
|
||||||
|
|
||||||
-- abc -> SCH abc
|
-- abc -> SCH abc
|
||||||
-- #abc -> SCH abc
|
-- #abc -> SCH abc
|
||||||
fromText :: Text -> Maybe ShortCausalHash
|
fromText :: Text -> Maybe ShortCausalHash
|
||||||
|
@ -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.
|
||||||
|
@ -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)
|
|
@ -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 ()
|
||||||
|
@ -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
|
|
||||||
|
@ -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) =
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||||
]
|
]
|
||||||
|
@ -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
|
||||||
|
@ -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, () #))
|
|
@ -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
|
||||||
|
@ -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 =
|
||||||
|
@ -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)
|
|
||||||
|
31
unison-cli/src/Unison/Cli/MergeTypes.hs
Normal file
31
unison-cli/src/Unison/Cli/MergeTypes.hs
Normal 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
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
@ -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 =
|
||||||
|
Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main")
|
||||||
|
in Cli.runTransaction loadMain <&> \case
|
||||||
Nothing -> Path.Absolute Path.empty
|
Nothing -> Path.Absolute Path.empty
|
||||||
Just mainBranch -> ProjectUtils.projectBranchPath (ProjectAndBranch projectId (mainBranch ^. #branchId))
|
Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch)
|
||||||
Just parentBranchId -> pure (ProjectUtils.projectBranchPath (ProjectAndBranch projectId parentBranchId))
|
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))
|
||||||
|
)
|
||||||
|
@ -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) ->
|
||||||
|
@ -118,6 +118,7 @@ fresh bump taken x =
|
|||||||
makeDependencyName :: ProjectName -> ProjectBranchName -> NameSegment
|
makeDependencyName :: ProjectName -> ProjectBranchName -> NameSegment
|
||||||
makeDependencyName projectName branchName =
|
makeDependencyName projectName branchName =
|
||||||
NameSegment.unsafeParseText $
|
NameSegment.unsafeParseText $
|
||||||
|
Text.replace "-" "_" $
|
||||||
Text.intercalate "_" $
|
Text.intercalate "_" $
|
||||||
fold
|
fold
|
||||||
[ case projectNameToUserProjectSlugs projectName of
|
[ case projectNameToUserProjectSlugs projectName of
|
||||||
@ -127,16 +128,12 @@ makeDependencyName projectName branchName =
|
|||||||
[project]
|
[project]
|
||||||
],
|
],
|
||||||
case classifyProjectBranchName branchName of
|
case classifyProjectBranchName branchName of
|
||||||
ProjectBranchNameKind'Contributor user branch -> [user, underscorify branch]
|
ProjectBranchNameKind'Contributor user branch -> [user, into @Text branch]
|
||||||
ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"]
|
ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"]
|
||||||
ProjectBranchNameKind'Release ver -> semverSegments ver
|
ProjectBranchNameKind'Release ver -> semverSegments ver
|
||||||
ProjectBranchNameKind'NothingSpecial -> [underscorify branchName]
|
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
|
|
||||||
|
@ -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,45 +140,91 @@ 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
|
||||||
|
|
||||||
|
Cli.label \done -> do
|
||||||
|
-- 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 ()
|
||||||
|
|
||||||
|
-- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done.
|
||||||
|
when (info.lca.causalHash == Just info.alice.causalHash) do
|
||||||
|
bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash)
|
||||||
|
_ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch)
|
||||||
|
Cli.respond (Output.MergeSuccessFastForward mergeSourceAndTarget)
|
||||||
|
done ()
|
||||||
|
|
||||||
-- Create a bunch of cached database lookup functions
|
-- Create a bunch of cached database lookup functions
|
||||||
db <- makeMergeDatabase codebase
|
db <- makeMergeDatabase codebase
|
||||||
|
|
||||||
-- Load the current project branch ("Alice"), and the branch from the same project to merge in ("Bob")
|
|
||||||
info <- loadMergeInfo bobSpecifier
|
|
||||||
let projectAndBranchNames = (\x -> ProjectAndBranch x.project.name x.branch.name) <$> info.branches
|
|
||||||
|
|
||||||
-- Load Alice/Bob/LCA causals
|
-- Load Alice/Bob/LCA causals
|
||||||
causals <-
|
causals <- Cli.runTransaction do
|
||||||
Cli.runTransaction do
|
traverse
|
||||||
alice <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute info.paths.alice)
|
Operations.expectCausalBranchByCausalHash
|
||||||
bob <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute info.paths.bob)
|
TwoOrThreeWay
|
||||||
lca <-
|
{ alice = info.alice.causalHash,
|
||||||
Operations.lca alice.causalHash bob.causalHash >>= \case
|
bob = info.bob.causalHash,
|
||||||
Nothing -> pure Nothing
|
lca = info.lca.causalHash
|
||||||
Just lcaCausalHash -> Just <$> db.loadCausal lcaCausalHash
|
}
|
||||||
pure TwoOrThreeWay {lca, alice, bob}
|
|
||||||
|
|
||||||
-- If alice == bob, then we are done.
|
|
||||||
when (causals.alice == causals.bob) do
|
|
||||||
Cli.returnEarly (Output.MergeAlreadyUpToDate (Right info.branches.bob) (Right info.branches.alice))
|
|
||||||
|
|
||||||
-- Otherwise, if LCA == bob, then we are ahead of bob, so we are done.
|
|
||||||
when (causals.lca == Just causals.bob) do
|
|
||||||
Cli.returnEarly (Output.MergeAlreadyUpToDate (Right info.branches.bob) (Right info.branches.alice))
|
|
||||||
|
|
||||||
-- Otherwise, if LCA == alice, then we can fast forward to bob, and we're done.
|
|
||||||
when (causals.lca == Just causals.alice) do
|
|
||||||
bobBranch <- Cli.getBranchAt info.paths.bob
|
|
||||||
_ <- Cli.updateAt (textualDescriptionOfMerge info) info.paths.alice (\_aliceBranch -> bobBranch)
|
|
||||||
Cli.returnEarly (Output.MergeSuccessFastForward projectAndBranchNames.alice projectAndBranchNames.bob)
|
|
||||||
|
|
||||||
liftIO (debugFunctions.debugCausals causals)
|
liftIO (debugFunctions.debugCausals causals)
|
||||||
|
|
||||||
@ -176,25 +236,62 @@ handleMerge bobSpecifier = do
|
|||||||
lca <- for causals.lca \causal -> causal.value
|
lca <- for causals.lca \causal -> causal.value
|
||||||
pure TwoOrThreeWay {lca, alice, bob}
|
pure TwoOrThreeWay {lca, alice, bob}
|
||||||
|
|
||||||
-- Load Alice/Bob/LCA definitions and decl name lookups
|
-- Assert that neither Alice nor Bob have defns in lib
|
||||||
(defns3, declNameLookups3) <-
|
for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do
|
||||||
Cli.runTransactionWithRollback \abort -> do
|
libdeps <-
|
||||||
loadDefns abort db (view #branch <$> info.branches) branches
|
case Map.lookup NameSegment.libSegment branch.children of
|
||||||
let defns = ThreeWay.forgetLca defns3
|
Nothing -> pure V2.Branch.empty
|
||||||
let declNameLookups = ThreeWay.forgetLca declNameLookups3
|
Just libdeps -> Cli.runTransaction libdeps.value
|
||||||
|
when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do
|
||||||
|
Cli.returnEarly (Output.MergeDefnsInLib who)
|
||||||
|
|
||||||
liftIO (debugFunctions.debugDefns defns3 declNameLookups3)
|
-- 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
|
-- Diff LCA->Alice and LCA->Bob
|
||||||
diffs <-
|
diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns3)
|
||||||
Cli.runTransaction do
|
|
||||||
Merge.nameBasedNamespaceDiff db declNameLookups3 defns3
|
|
||||||
|
|
||||||
liftIO (debugFunctions.debugDiffs diffs)
|
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
|
-- 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 ->
|
for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) ->
|
||||||
Cli.returnEarly (mergePreconditionViolationToOutput violation)
|
whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) ->
|
||||||
|
Cli.returnEarly (Output.MergeConflictedAliases who name1 name2)
|
||||||
|
|
||||||
-- Combine the LCA->Alice and LCA->Bob diffs together
|
-- Combine the LCA->Alice and LCA->Bob diffs together
|
||||||
let diff = combineDiffs diffs
|
let diff = combineDiffs diffs
|
||||||
@ -204,7 +301,7 @@ handleMerge bobSpecifier = do
|
|||||||
-- Partition the combined diff into the conflicted things and the unconflicted things
|
-- Partition the combined diff into the conflicted things and the unconflicted things
|
||||||
(conflicts, unconflicts) <-
|
(conflicts, unconflicts) <-
|
||||||
partitionCombinedDiffs defns declNameLookups diff & onLeft \name ->
|
partitionCombinedDiffs defns declNameLookups diff & onLeft \name ->
|
||||||
Cli.returnEarly (mergePreconditionViolationToOutput (Merge.ConflictInvolvingBuiltin name))
|
Cli.returnEarly (Output.MergeConflictInvolvingBuiltin name)
|
||||||
|
|
||||||
liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts)
|
liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts)
|
||||||
|
|
||||||
@ -273,7 +370,23 @@ handleMerge bobSpecifier = do
|
|||||||
<*> hydratedThings
|
<*> hydratedThings
|
||||||
<*> ppes
|
<*> ppes
|
||||||
|
|
||||||
let prettyUnisonFile = makePrettyUnisonFile (into @Text <$> projectAndBranchNames) renderedConflicts renderedDependents
|
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
|
let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps
|
||||||
|
|
||||||
@ -288,84 +401,68 @@ handleMerge bobSpecifier = do
|
|||||||
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
|
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
|
||||||
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
|
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
|
||||||
|
|
||||||
|
let parents =
|
||||||
|
(\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals
|
||||||
|
|
||||||
case maybeTypecheckedUnisonFile of
|
case maybeTypecheckedUnisonFile of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
Cli.Env {writeSource} <- ask
|
Cli.Env {writeSource} <- ask
|
||||||
aliceBranch <- Cli.getBranchAt info.paths.alice
|
|
||||||
bobBranch <- Cli.getBranchAt info.paths.bob
|
|
||||||
_temporaryBranchId <-
|
_temporaryBranchId <-
|
||||||
HandleInput.Branch.doCreateBranch'
|
HandleInput.Branch.doCreateBranch'
|
||||||
(Branch.mergeNode stageOneBranch aliceBranch bobBranch)
|
(Branch.mergeNode stageOneBranch parents.alice parents.bob)
|
||||||
Nothing
|
Nothing
|
||||||
info.branches.alice.project
|
info.alice.projectAndBranch.project
|
||||||
(findTemporaryBranchName info)
|
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
|
||||||
(textualDescriptionOfMerge info)
|
info.description
|
||||||
scratchFilePath <-
|
scratchFilePath <-
|
||||||
Cli.getLatestFile <&> \case
|
Cli.getLatestFile <&> \case
|
||||||
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 $
|
Cli.respond (Output.MergeFailure scratchFilePath mergeSourceAndTarget)
|
||||||
Output.MergeFailure
|
|
||||||
scratchFilePath
|
|
||||||
projectAndBranchNames.alice
|
|
||||||
projectAndBranchNames.bob
|
|
||||||
Just tuf -> do
|
Just tuf -> do
|
||||||
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
|
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
|
||||||
bobBranch <- Cli.getBranchAt info.paths.bob
|
|
||||||
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
|
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
|
||||||
_ <-
|
_ <-
|
||||||
Cli.updateAt
|
Cli.updateAt
|
||||||
(textualDescriptionOfMerge info)
|
info.description
|
||||||
info.paths.alice
|
alicePath
|
||||||
(\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch)
|
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
||||||
Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob)
|
Cli.respond (Output.MergeSuccess mergeSourceAndTarget)
|
||||||
|
|
||||||
|
doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
|
||||||
|
doMergeLocalBranch branches = do
|
||||||
|
(aliceCausalHash, bobCausalHash, lcaCausalHash) <-
|
||||||
|
Cli.runTransaction do
|
||||||
|
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice)
|
||||||
|
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob)
|
||||||
|
-- Using Alice and Bob's causal hashes, find the LCA (if it exists)
|
||||||
|
lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash
|
||||||
|
pure (aliceCausalHash, bobCausalHash, lcaCausalHash)
|
||||||
|
|
||||||
|
-- Do the merge!
|
||||||
|
doMerge
|
||||||
|
MergeInfo
|
||||||
|
{ alice =
|
||||||
|
AliceMergeInfo
|
||||||
|
{ causalHash = aliceCausalHash,
|
||||||
|
projectAndBranch = branches.alice
|
||||||
|
},
|
||||||
|
bob =
|
||||||
|
BobMergeInfo
|
||||||
|
{ causalHash = bobCausalHash,
|
||||||
|
source = MergeSource'LocalProjectBranch (ProjectUtils.justTheNames branches.bob)
|
||||||
|
},
|
||||||
|
lca =
|
||||||
|
LcaMergeInfo
|
||||||
|
{ causalHash = lcaCausalHash
|
||||||
|
},
|
||||||
|
description = "merge " <> into @Text (ProjectUtils.justTheNames branches.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,7 +599,10 @@ 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
|
||||||
|
-- dependents
|
||||||
|
let thereAre defns = TwoWay.or (not . defnsAreEmpty <$> defns)
|
||||||
|
in if thereAre conflicts && thereAre dependents
|
||||||
then
|
then
|
||||||
fold
|
fold
|
||||||
[ "-- The definitions below are not conflicted, but they each depend on one or more\n",
|
[ "-- The definitions below are not conflicted, but they each depend on one or more\n",
|
||||||
@ -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 $
|
||||||
|
Text.Builder.run $
|
||||||
"merge-"
|
"merge-"
|
||||||
<> mangle info.branches.bob.branch.name
|
<> mangleMergeSource mergeSourceAndTarget.bob
|
||||||
<> "-into-"
|
<> "-into-"
|
||||||
<> mangle info.branches.alice.branch.name
|
<> 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 ->
|
||||||
|
m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference))
|
||||||
|
go f branch = do
|
||||||
|
terms <- for branch.terms (fmap (Set.NonEmpty.fromList . List.NonEmpty.fromList) . traverse referent2to1 . Map.keys)
|
||||||
|
let types = Map.map (Set.NonEmpty.unsafeFromSet . Map.keysSet) branch.types
|
||||||
children <-
|
children <-
|
||||||
for (Map.delete NameSegment.libSegment branch.children) \childCausal -> do
|
for (f branch.children) \childCausal -> do
|
||||||
childBranch <- childCausal.value
|
child <- childCausal.value
|
||||||
loadNamespaceInfo0_ referent2to1 childBranch
|
go id child
|
||||||
pure Nametree {value = Defns {terms, types}, children}
|
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)
|
||||||
|
|
||||||
|
@ -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 <-
|
||||||
|
case projectAndBranchNames0 of
|
||||||
This projectName ->
|
This projectName ->
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
project <-
|
project <-
|
||||||
Queries.loadProjectByName projectName & onNothingM do
|
Queries.loadProjectByName projectName & onNothingM do
|
||||||
rollback (Output.LocalProjectDoesntExist projectName)
|
rollback (Output.LocalProjectDoesntExist projectName)
|
||||||
Queries.loadMostRecentBranch (project ^. #projectId) >>= \case
|
|
||||||
Nothing -> do
|
|
||||||
let branchName = unsafeFrom @Text "main"
|
let branchName = unsafeFrom @Text "main"
|
||||||
branch <-
|
Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
|
||||||
Queries.loadProjectBranchByName (project ^. #projectId) branchName & onNothingM do
|
|
||||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||||
setMostRecentBranch branch
|
|
||||||
Just branchId ->
|
|
||||||
Queries.loadProjectBranch (project ^. #projectId) branchId >>= \case
|
|
||||||
Nothing -> error "impossible"
|
|
||||||
Just branch -> pure branch
|
|
||||||
_ -> do
|
_ -> do
|
||||||
projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0
|
projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
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)
|
||||||
|
@ -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,25 +48,16 @@ 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
|
||||||
ReadRemoteNamespaceGit repo -> do
|
|
||||||
downloadLooseCodeFromGitRepo
|
|
||||||
codebase
|
|
||||||
( case pullMode of
|
|
||||||
Input.PullWithHistory -> GitNamespaceHistoryTreatment'LetAlone
|
|
||||||
Input.PullWithoutHistory -> GitNamespaceHistoryTreatment'DiscardAllHistory
|
|
||||||
)
|
|
||||||
repo
|
|
||||||
& onLeftM (Cli.returnEarly . Output.GitError)
|
|
||||||
ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError)
|
ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError)
|
||||||
ReadShare'ProjectBranch remoteBranch ->
|
ReadShare'ProjectBranch remoteBranch ->
|
||||||
downloadProjectBranchFromShare
|
downloadProjectBranchFromShare
|
||||||
@ -73,47 +67,81 @@ handlePull unresolvedSourceAndTarget pullMode verbosity = do
|
|||||||
)
|
)
|
||||||
remoteBranch
|
remoteBranch
|
||||||
& onLeftM (Cli.returnEarly . Output.ShareError)
|
& onLeftM (Cli.returnEarly . Output.ShareError)
|
||||||
liftIO (Codebase.expectBranchForHash codebase causalHash)
|
|
||||||
when (Branch.isEmpty0 (Branch.head remoteBranchObject)) do
|
remoteBranchIsEmpty <-
|
||||||
Cli.respond (PulledEmptyBranch source)
|
Cli.runTransaction do
|
||||||
targetAbsolutePath <-
|
causal <- Operations.expectCausalBranchByCausalHash remoteCausalHash
|
||||||
case target of
|
branch <- causal.value
|
||||||
Left path -> Cli.resolvePath' path
|
V2.Branch.isEmpty branch
|
||||||
Right (ProjectAndBranch project branch) ->
|
|
||||||
pure $ ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))
|
when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source))
|
||||||
|
|
||||||
|
let targetAbsolutePath =
|
||||||
|
ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.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 <-
|
||||||
|
Cli.runTransaction do
|
||||||
|
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute targetAbsolutePath)
|
||||||
|
pure causal.causalHash
|
||||||
|
|
||||||
|
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
|
description
|
||||||
(Just (PullAlreadyUpToDate source target))
|
}
|
||||||
remoteBranchObject
|
|
||||||
(if Verbosity.isSilent verbosity then Nothing else Just target)
|
|
||||||
targetAbsolutePath
|
|
||||||
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
|
||||||
|
@ -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
|
||||||
|
@ -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 shouldn’t need to serialize mainName` for this check
|
||||||
|
let mainComponent = filter ((\v -> Var.name v == HQ.toText mainName) . view _1) components
|
||||||
case mainComponent of
|
case mainComponent of
|
||||||
[(v, _, tm, ty)] ->
|
[(v, _, tm, ty)] ->
|
||||||
checkType ty \otyp ->
|
checkType ty \otyp ->
|
||||||
|
@ -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])
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
29
unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs
Normal file
29
unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs
Normal 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)
|
@ -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,29 +31,9 @@ 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'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier
|
|
||||||
<|> ReadShare'LooseCode <$> readShareLooseCode
|
<|> ReadShare'LooseCode <$> readShareLooseCode
|
||||||
|
|
||||||
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ::
|
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ::
|
||||||
@ -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)
|
|
||||||
|
@ -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
|
||||||
|
@ -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 doesn’t need to be parsed, as
|
||||||
|
-- we’ve preserved its representation (although the numbered argument could
|
||||||
|
-- still be of the wrong type, which should result in an error).
|
||||||
|
type Argument = Either String StructuredArgument
|
||||||
|
|
||||||
|
type Arguments = [Argument]
|
||||||
|
|
||||||
-- | Argument description
|
-- | 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
@ -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 =
|
||||||
|
@ -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
|
||||||
|
<> "was already up-to-date with"
|
||||||
|
<> P.group (prettyMergeSource aliceAndBob.bob <> ".")
|
||||||
|
MergeConflictedAliases aliceOrBob name1 name2 ->
|
||||||
|
pure $
|
||||||
|
P.wrap "Sorry, I wasn't able to perform the merge:"
|
||||||
|
<> P.newline
|
||||||
|
<> P.newline
|
||||||
|
<> P.wrap
|
||||||
|
( "On the merge ancestor,"
|
||||||
<> prettyName name1
|
<> prettyName name1
|
||||||
<> "and"
|
<> "and"
|
||||||
<> prettyName name2
|
<> prettyName name2
|
||||||
<> "are not aliases, but they used to be."
|
<> "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.wrap
|
||||||
|
( "There's a merge conflict on"
|
||||||
<> P.group (prettyName name <> ",")
|
<> P.group (prettyName name <> ",")
|
||||||
<> "but it's a builtin on one or both branches. We can't yet handle merge conflicts on builtins."
|
<> "but it's a builtin on one or both branches. I can't yet handle merge conflicts involving builtins."
|
||||||
MergeConstructorAlias maybeBranch name1 name2 ->
|
),
|
||||||
|
"",
|
||||||
|
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 $
|
||||||
|
[ P.wrap $
|
||||||
|
"Sorry, I wasn't able to perform the merge, because I need all constructor names to be nested somewhere"
|
||||||
|
<> "beneath the corresponding type name.",
|
||||||
|
"",
|
||||||
|
P.wrap $
|
||||||
|
"On"
|
||||||
|
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
|
||||||
|
<> "the constructor"
|
||||||
<> prettyName name
|
<> prettyName name
|
||||||
<> "is not in a subnamespace of a name of its type."
|
<> "is not nested beneath the corresponding type name. Please either use"
|
||||||
<> "Please either delete it or rename it before merging."
|
<> 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 ::
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -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
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -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
|
|
@ -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))
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -17,6 +17,8 @@ module Unison.Project
|
|||||||
ProjectBranchSpecifier (..),
|
ProjectBranchSpecifier (..),
|
||||||
ProjectAndBranch (..),
|
ProjectAndBranch (..),
|
||||||
projectAndBranchNamesParser,
|
projectAndBranchNamesParser,
|
||||||
|
projectAndOptionalBranchParser,
|
||||||
|
branchWithOptionalProjectParser,
|
||||||
ProjectAndBranchNames (..),
|
ProjectAndBranchNames (..),
|
||||||
projectAndBranchNamesParser2,
|
projectAndBranchNamesParser2,
|
||||||
projectNameParser,
|
projectNameParser,
|
||||||
|
@ -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
|
||||||
|
@ -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) ->
|
||||||
|
case recordConstructorName conId name1 expected of
|
||||||
|
Left existingName -> Left (IncoherentDeclReason'ConstructorAlias typeName existingName name1)
|
||||||
|
Right expected1 -> Right (typeName, expected1)
|
||||||
where
|
where
|
||||||
g :: Maybe MaybeConstructorName -> Either IncoherentDeclReason (Maybe MaybeConstructorName)
|
name1 = fullName name
|
||||||
g = \case
|
|
||||||
Nothing -> error "didnt put expected constructor id"
|
|
||||||
Just NoConstructorNameYet -> Right (Just (YesConstructorName (fullName name)))
|
|
||||||
Just (YesConstructorName firstName) ->
|
|
||||||
Left (IncoherentDeclReason'ConstructorAlias firstName (fullName name))
|
|
||||||
|
|
||||||
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
|
|
||||||
{ constructorToDecl =
|
|
||||||
List.foldl'
|
List.foldl'
|
||||||
(\acc constructorName -> Map.insert constructorName typeName acc)
|
(\acc constructorName -> Map.insert constructorName typeName acc)
|
||||||
declNameLookup.constructorToDecl
|
constructorToDecl
|
||||||
constructorNames,
|
constructorNames
|
||||||
declToConstructors = Map.insert typeName constructorNames declNameLookup.declToConstructors
|
#declNameLookup . #declToConstructors %= Map.insert typeName constructorNames
|
||||||
}
|
pure (Just name)
|
||||||
|
where
|
||||||
|
typeName = fullName name
|
||||||
|
|
||||||
|
let childrenWeHaventGoneInto = children `Map.withoutKeys` Set.fromList childrenWeWentInto
|
||||||
|
for_ (Map.toList childrenWeHaventGoneInto) \(name, child) -> go (name : prefix) child
|
||||||
|
where
|
||||||
|
fullName name =
|
||||||
|
Name.fromReverseSegments (name :| prefix)
|
||||||
|
|
||||||
|
-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns a mapping from decl name to
|
||||||
|
-- constructor names, where constructor names can be missing.
|
||||||
|
--
|
||||||
|
-- This function exists merely to extract a best-effort decl-name-to-constructor-name mapping for the LCA of a merge.
|
||||||
|
-- We require Alice and Bob to have coherent decls, but their LCA is out of the user's control and may have incoherent
|
||||||
|
-- decls, and whether or not it does, we still need to compute *some* syntactic hash for its decls.
|
||||||
|
lenientCheckDeclCoherency ::
|
||||||
|
forall m.
|
||||||
|
Monad m =>
|
||||||
|
(TypeReferenceId -> m Int) ->
|
||||||
|
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
|
||||||
|
m (Map Name [Maybe Name])
|
||||||
|
lenientCheckDeclCoherency loadDeclNumConstructors =
|
||||||
|
fmap (view #declToConstructors)
|
||||||
|
. (`State.execStateT` LenientDeclCoherencyCheckState Map.empty Map.empty)
|
||||||
|
. go []
|
||||||
|
where
|
||||||
|
go ::
|
||||||
|
[NameSegment] ->
|
||||||
|
(Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
|
||||||
|
StateT LenientDeclCoherencyCheckState m ()
|
||||||
|
go prefix (Nametree defns children) = do
|
||||||
|
for_ (Map.toList defns.terms) \case
|
||||||
|
(_, Referent.Ref _) -> pure ()
|
||||||
|
(_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure ()
|
||||||
|
(name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do
|
||||||
|
#expectedConstructors %= Map.adjust (Map.map (lenientRecordConstructorName conId (fullName name))) typeRef
|
||||||
|
|
||||||
|
childrenWeWentInto <-
|
||||||
|
forMaybe (Map.toList defns.types) \case
|
||||||
|
(_, ReferenceBuiltin _) -> pure Nothing
|
||||||
|
(name, ReferenceDerived typeRef) -> do
|
||||||
|
whatHappened <- do
|
||||||
|
let recordNewDecl :: m (WhatHappened (Map Name ConstructorNames))
|
||||||
|
recordNewDecl =
|
||||||
|
loadDeclNumConstructors typeRef <&> \case
|
||||||
|
0 -> UninhabitedDecl
|
||||||
|
n -> InhabitedDecl (Map.singleton typeName (emptyConstructorNames n))
|
||||||
|
state <- State.get
|
||||||
|
lift (getCompose (Map.upsertF (\_ -> Compose recordNewDecl) typeRef state.expectedConstructors))
|
||||||
|
case whatHappened of
|
||||||
|
UninhabitedDecl -> do
|
||||||
|
#declToConstructors %= Map.insert typeName []
|
||||||
|
pure Nothing
|
||||||
|
InhabitedDecl expectedConstructors1 -> do
|
||||||
|
let child = Map.findWithDefault (Nametree (Defns Map.empty Map.empty) Map.empty) name children
|
||||||
|
#expectedConstructors .= expectedConstructors1
|
||||||
|
go (name : prefix) child
|
||||||
|
state <- State.get
|
||||||
|
let (maybeConstructorNames, expectedConstructors) =
|
||||||
|
Map.alterF f typeRef state.expectedConstructors
|
||||||
|
where
|
||||||
|
f ::
|
||||||
|
Maybe (Map Name ConstructorNames) ->
|
||||||
|
(ConstructorNames, Maybe (Map Name ConstructorNames))
|
||||||
|
f =
|
||||||
|
-- fromJust is safe here because we upserted `typeRef` key above
|
||||||
|
-- deleteLookupJust is safe here because we upserted `typeName` key above
|
||||||
|
fromJust
|
||||||
|
>>> Map.deleteLookupJust typeName
|
||||||
|
>>> over _2 \m -> if Map.null m then Nothing else Just m
|
||||||
|
#expectedConstructors .= expectedConstructors
|
||||||
|
#declToConstructors %= Map.insert typeName (IntMap.elems maybeConstructorNames)
|
||||||
pure (Just name)
|
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
|
||||||
|
@ -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
|
|
||||||
)
|
|
||||||
|
@ -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
|
||||||
|
hashType :: Name -> TypeReference -> Transaction Hash
|
||||||
|
hashType name = \case
|
||||||
|
ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin)
|
||||||
|
ReferenceDerived ref -> do
|
||||||
|
decl <- loadDeclWithGoodConstructorNames (DeclNameLookup.expectConstructorNames declNameLookup name) ref
|
||||||
|
pure (synhashDerivedDecl ppe name decl)
|
||||||
|
|
||||||
|
loadDeclWithGoodConstructorNames :: [Name] -> TypeReferenceId -> Transaction (Decl Symbol Ann)
|
||||||
|
loadDeclWithGoodConstructorNames names =
|
||||||
|
fmap (DataDeclaration.setConstructorNames (map Name.toVar names)) . db.loadV1Decl
|
||||||
|
|
||||||
hashTerm :: Referent -> Transaction Hash
|
hashTerm :: Referent -> Transaction Hash
|
||||||
hashTerm =
|
hashTerm =
|
||||||
Synhash.hashTerm db.loadV1Term ppe
|
synhashTerm db.loadV1Term ppe
|
||||||
|
|
||||||
hashType :: Name -> TypeReference -> Transaction Hash
|
|
||||||
hashType name =
|
|
||||||
Synhash.hashDecl
|
|
||||||
(fmap (DeclNameLookup.setConstructorNames declNameLookup name) . db.loadV1Decl)
|
|
||||||
ppe
|
|
||||||
name
|
|
||||||
|
|
||||||
ppe :: PrettyPrintEnv
|
ppe :: PrettyPrintEnv
|
||||||
ppe =
|
ppe =
|
||||||
|
@ -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)
|
|
@ -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]
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -17,6 +17,7 @@ dependencies:
|
|||||||
- bytes
|
- bytes
|
||||||
- bytestring
|
- bytestring
|
||||||
- containers
|
- containers
|
||||||
|
- Diff
|
||||||
- directory
|
- directory
|
||||||
- errors
|
- errors
|
||||||
- extra
|
- extra
|
||||||
|
@ -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,10 +847,9 @@ 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)
|
||||||
@ -1119,27 +1120,47 @@ 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 $
|
|
||||||
Map.mapKeys
|
|
||||||
(first (PPE.termName ppeDecl . Referent.Ref) . dupe)
|
|
||||||
terms
|
terms
|
||||||
where
|
<&> \(r, dispObj) ->
|
||||||
ppeBody r =
|
let n = PPE.termName ppeDecl . Referent.Ref $ r
|
||||||
if suffixified suff
|
in (r,) case dispObj of
|
||||||
then PPED.suffixifiedPPE ppe0
|
|
||||||
else PPE.declarationPPE ppe0 r
|
|
||||||
ppeDecl =
|
|
||||||
(if suffixified suff then PPED.suffixifiedPPE else PPED.unsuffixifiedPPE) ppe0
|
|
||||||
go ((n, r), dt) = (r,) $ case dt of
|
|
||||||
DisplayObject.BuiltinObject typ ->
|
DisplayObject.BuiltinObject typ ->
|
||||||
DisplayObject.BuiltinObject $
|
DisplayObject.BuiltinObject $
|
||||||
formatType' (ppeBody r) width typ
|
formatType' (ppeBody r) width typ
|
||||||
@ -1148,32 +1169,64 @@ termsToSyntax suff width ppe0 terms =
|
|||||||
DisplayObject.UserObject
|
DisplayObject.UserObject
|
||||||
. Pretty.render width
|
. Pretty.render width
|
||||||
$ TermPrinter.prettyBinding (ppeBody r) n tm
|
$ TermPrinter.prettyBinding (ppeBody r) n tm
|
||||||
|
where
|
||||||
|
ppeBody r =
|
||||||
|
if suffixified suff
|
||||||
|
then PPED.suffixifiedPPE ppe0
|
||||||
|
else PPE.declarationPPE ppe0 r
|
||||||
|
ppeDecl =
|
||||||
|
(if suffixified suff then PPED.suffixifiedPPE else PPED.unsuffixifiedPPE) ppe0
|
||||||
|
|
||||||
|
-- | 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 $
|
|
||||||
map go . Map.toList $
|
|
||||||
Map.mapKeys
|
|
||||||
(first (PPE.typeName ppeDecl) . dupe)
|
|
||||||
types
|
types
|
||||||
where
|
<&> \(r, dispObj) ->
|
||||||
ppeDecl =
|
let n = PPE.typeName ppeDecl r
|
||||||
if suffixified suff
|
in (r,) $ case dispObj of
|
||||||
then PPED.suffixifiedPPE ppe0
|
|
||||||
else PPED.unsuffixifiedPPE ppe0
|
|
||||||
go ((n, r), dt) = (r,) $ case dt of
|
|
||||||
BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r)
|
BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r)
|
||||||
MissingObject sh -> MissingObject sh
|
MissingObject sh -> MissingObject sh
|
||||||
UserObject d ->
|
UserObject d ->
|
||||||
UserObject . Pretty.render width $
|
UserObject . Pretty.render width $
|
||||||
DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d
|
DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d
|
||||||
|
where
|
||||||
|
ppeDecl =
|
||||||
|
if suffixified suff
|
||||||
|
then PPED.suffixifiedPPE ppe0
|
||||||
|
else PPED.unsuffixifiedPPE ppe0
|
||||||
|
|
||||||
-- | Renders a type to its decl header, e.g.
|
-- | Renders a type to its decl header, e.g.
|
||||||
--
|
--
|
||||||
|
63
unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs
Normal file
63
unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs
Normal 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."
|
@ -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 ->
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
]
|
||||||
|
@ -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
|
||||||
|
@ -34,6 +34,7 @@ module Unison.Share.API.Projects
|
|||||||
ProjectBranchIds (..),
|
ProjectBranchIds (..),
|
||||||
NotFound (..),
|
NotFound (..),
|
||||||
Unauthorized (..),
|
Unauthorized (..),
|
||||||
|
BranchName,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
12
unison-src/transcripts-using-base/fix3939.md
Normal file
12
unison-src/transcripts-using-base/fix3939.md
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
```unison
|
||||||
|
{{
|
||||||
|
A simple doc.
|
||||||
|
}}
|
||||||
|
meh = 9
|
||||||
|
```
|
||||||
|
|
||||||
|
```ucm
|
||||||
|
.> add
|
||||||
|
.> find meh
|
||||||
|
.> docs 1
|
||||||
|
```
|
40
unison-src/transcripts-using-base/fix3939.output.md
Normal file
40
unison-src/transcripts-using-base/fix3939.output.md
Normal 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.
|
||||||
|
|
||||||
|
```
|
@ -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
|
|
||||||
```
|
|
@ -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
|
|
||||||
|
|
||||||
```
|
|
@ -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
|
|
||||||
```
|
|
@ -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
Loading…
Reference in New Issue
Block a user