diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 000000000..24503cfc2 --- /dev/null +++ b/.editorconfig @@ -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 diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index bee857575..4ee48187b 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -378,7 +378,7 @@ jobs: contents: | ```ucm .> project.create-empty jit-setup - jit-setup/main> pull ${{ env.jit_version }} lib.jit + jit-setup/main> lib.install ${{ env.jit_version }} ``` ```unison go = generateSchemeBoot "${{ env.jit_generated_src_scheme }}" diff --git a/.github/workflows/nix-dev-cache.yaml b/.github/workflows/nix-dev-cache.yaml index aacb38342..915b42090 100644 --- a/.github/workflows/nix-dev-cache.yaml +++ b/.github/workflows/nix-dev-cache.yaml @@ -23,12 +23,12 @@ jobs: - macOS-12 steps: - uses: actions/checkout@v4 - - uses: cachix/install-nix-action@v22 + - uses: cachix/install-nix-action@v27 with: extra_nix_config: | extra-trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= extra-substituters = https://cache.iog.io - - uses: cachix/cachix-action@v12 + - uses: cachix/cachix-action@v15 with: name: unison authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' diff --git a/.gitignore b/.gitignore index 8a2be67a4..e02fc7f2b 100644 --- a/.gitignore +++ b/.gitignore @@ -24,5 +24,7 @@ dist-newstyle # Mac developers **/.DS_Store - /libb2.dylib + +# Nix +result diff --git a/.mergify.yml b/.mergify.yml index 06be4d2a6..5b7829eff 100644 --- a/.mergify.yml +++ b/.mergify.yml @@ -11,9 +11,12 @@ pull_request_rules: - check-success=run interpreter tests (macOS-12) # - check-success=run interpreter tests (windows-2019) - check-success=generate jit source - - check-success=build jit binary (ubuntu-20.04) - - check-success=build jit binary (macOS-12) - - check-success=build jit binary (windows-2019) + - check-success=build jit binary / build jit binary (ubuntu-20.04) + - check-success=build jit binary / build jit binary (macOS-12) + - 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 - "#approved-reviews-by>=1" actions: diff --git a/README.md b/README.md index db40dc20a..3a857d380 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,8 @@ The Unison language =================== -[![Build Status](https://github.com/unisonweb/unison/actions/workflows/ci.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/ci.yaml?query=branch%3Atrunk) +[![CI Status](https://github.com/unisonweb/unison/actions/workflows/ci.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/ci.yaml?query=branch%3Atrunk) +[![Pre-Release Status](https://github.com/unisonweb/unison/actions/workflows/pre-release.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/pre-release.yaml) * [Overview](#overview) * [Building using Stack](#building-using-stack) diff --git a/codebase2/codebase/package.yaml b/codebase2/codebase/package.yaml index 30763303e..1608bed83 100644 --- a/codebase2/codebase/package.yaml +++ b/codebase2/codebase/package.yaml @@ -21,8 +21,33 @@ library: other-modules: Paths_unison_codebase default-extensions: + - BangPatterns - BlockArguments + - DeriveAnyClass + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - DuplicateRecordFields + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - ImportQualifiedPost - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedLabels + - OverloadedRecordDot + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - TypeFamilies + - ViewPatterns language: GHC2021 diff --git a/codebase2/codebase/unison-codebase.cabal b/codebase2/codebase/unison-codebase.cabal index 7617d5446..4fcd1abb4 100644 --- a/codebase2/codebase/unison-codebase.cabal +++ b/codebase2/codebase/unison-codebase.cabal @@ -1,6 +1,6 @@ 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 @@ -31,9 +31,34 @@ library hs-source-dirs: ./ default-extensions: + BangPatterns BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + ViewPatterns build-depends: base , containers diff --git a/development.markdown b/development.markdown index 22e9657c7..962a507c6 100644 --- a/development.markdown +++ b/development.markdown @@ -126,9 +126,9 @@ This is specified with the normal Some examples: ``` -nix build '.#haskell-nix.unison-cli:lib:unison-cli' -nix build '.#haskell-nix.unison-syntax:test:syntax-tests' -nix build '.#haskell-nix.unison-cli:exe:transcripts' +nix build '.#component-unison-cli:lib:unison-cli' +nix build '.#component-unison-syntax:test:syntax-tests' +nix build '.#component-unison-cli:exe:transcripts' ``` ### Development environments @@ -154,7 +154,7 @@ all non-local haskell dependencies (including profiling dependencies) are provided in the nix shell. ``` -nix develop '.#haskell-nix.local' +nix develop '.#cabal-local' ``` #### Get into a development environment for building a specific package @@ -164,17 +164,17 @@ all haskell dependencies of this package are provided by the nix shell (including profiling dependencies). ``` -nix develop '.#haskell-nix.' +nix develop '.#cabal-' ``` for example: ``` -nix develop '.#haskell-nix.unison-cli' +nix develop '.#cabal-unison-cli' ``` or ``` -nix develop '.#haskell-nix.unison-parser-typechecker' +nix develop '.#cabal-unison-parser-typechecker' ``` This is useful if you wanted to profile a package. For example, if you @@ -183,7 +183,7 @@ shells, cd into its directory, then run the program with profiling. ``` -nix develop '.#unison-parser-typechecker' +nix develop '.#cabal-unison-parser-typechecker' cd unison-cli cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p ``` diff --git a/flake.nix b/flake.nix index a9628dc4a..740109dd1 100644 --- a/flake.nix +++ b/flake.nix @@ -88,42 +88,50 @@ ''; }; }; + + renameAttrs = fn: nixpkgs.lib.mapAttrs' (name: value: { + inherit value; + name = fn name;}); in assert nixpkgs-packages.ormolu.version == versions.ormolu; assert nixpkgs-packages.hls.version == versions.hls; assert nixpkgs-packages.unwrapped-stack.version == versions.stack; assert nixpkgs-packages.hpack.version == versions.hpack; { - packages = nixpkgs-packages // { - default = haskell-nix-flake.defaultPackage; - haskell-nix = haskell-nix-flake.packages; - docker = import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; }; - build-tools = pkgs.symlinkJoin { - name = "build-tools"; - paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs; - }; - all = pkgs.symlinkJoin { - name = "all"; - paths = - let - all-other-packages = builtins.attrValues (builtins.removeAttrs self.packages."${system}" [ "all" "build-tools" ]); - devshell-inputs = builtins.concatMap - (devShell: devShell.buildInputs ++ devShell.nativeBuildInputs) - [ - self.devShells."${system}".only-tools-nixpkgs - ]; - in - all-other-packages ++ devshell-inputs; + packages = + nixpkgs-packages + // renameAttrs (name: "component-${name}") haskell-nix-flake.packages + // renameAttrs (name: "docker-${name}") (import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; }) + // { + default = haskell-nix-flake.defaultPackage; + build-tools = pkgs.symlinkJoin { + name = "build-tools"; + paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs; + }; + all = pkgs.symlinkJoin { + name = "all"; + paths = + let + all-other-packages = builtins.attrValues (builtins.removeAttrs self.packages."${system}" [ "all" "build-tools" ]); + devshell-inputs = builtins.concatMap + (devShell: devShell.buildInputs ++ devShell.nativeBuildInputs) + [ + self.devShells."${system}".only-tools-nixpkgs + ]; + in + all-other-packages ++ devshell-inputs; + }; }; + + apps = renameAttrs (name: "component-${name}") haskell-nix-flake.apps // { + default = self.apps."${system}"."component-unison-cli-main:exe:unison"; }; - apps = haskell-nix-flake.apps // { - default = self.apps."${system}"."unison-cli-main:exe:unison"; - }; - - devShells = nixpkgs-devShells // { - default = self.devShells."${system}".only-tools-nixpkgs; - haskell-nix = haskell-nix-flake.devShells; - }; + devShells = + nixpkgs-devShells + // renameAttrs (name: "cabal-${name}") haskell-nix-flake.devShells + // { + default = self.devShells."${system}".only-tools-nixpkgs; + }; }); } diff --git a/lib/unison-prelude/package.yaml b/lib/unison-prelude/package.yaml index c8d002857..2f2ee7d2e 100644 --- a/lib/unison-prelude/package.yaml +++ b/lib/unison-prelude/package.yaml @@ -12,6 +12,7 @@ dependencies: - base - bytestring - containers + - directory - generic-lens - either - extra diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index d940c1009..47fdb2ee7 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -25,7 +25,6 @@ import UnliftIO.Environment (lookupEnv) data DebugFlag = Auth | Codebase - | Git | Integrity | Merge | Migration @@ -59,7 +58,6 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of case Text.toUpper . Text.strip $ w of "AUTH" -> pure Auth "CODEBASE" -> pure Codebase - "GIT" -> pure Git "INTEGRITY" -> pure Integrity "MERGE" -> pure Merge "MIGRATION" -> pure Migration @@ -77,10 +75,6 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of _ -> empty {-# NOINLINE debugFlags #-} -debugGit :: Bool -debugGit = Git `Set.member` debugFlags -{-# NOINLINE debugGit #-} - debugSqlite :: Bool debugSqlite = Sqlite `Set.member` debugFlags {-# NOINLINE debugSqlite #-} @@ -146,11 +140,11 @@ debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.memb {-# NOINLINE debugPatternCoverageConstraintSolver #-} -- | Use for trace-style selective debugging. --- E.g. 1 + (debug Git "The second number" 2) +-- E.g. 1 + (debug Sync "The second number" 2) -- -- Or, use in pattern matching to view arguments. -- E.g. --- myFunc (debug Git "argA" -> argA) = ... +-- myFunc (debug Sync "argA" -> argA) = ... debug :: (Show a) => DebugFlag -> String -> a -> a debug flag msg a = if shouldDebug flag @@ -160,7 +154,7 @@ debug flag msg a = -- | Use for selective debug logging in monadic contexts. -- E.g. -- do --- debugM Git "source repo" srcRepo +-- debugM Sync "source repo" srcRepo -- ... debugM :: (Show a, Monad m) => DebugFlag -> String -> a -> m () debugM flag msg a = @@ -187,7 +181,6 @@ shouldDebug :: DebugFlag -> Bool shouldDebug = \case Auth -> debugAuth Codebase -> debugCodebase - Git -> debugGit Integrity -> debugIntegrity Merge -> debugMerge Migration -> debugMigration diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index dfc75d7cd..998df0dd4 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -82,6 +82,7 @@ import GHC.Generics as X (Generic, Generic1) import GHC.IO.Handle qualified as Handle import GHC.Stack as X (HasCallStack) import Safe as X (atMay, headMay, lastMay, readMay) +import System.Directory qualified as Directory import System.FilePath qualified as FilePath import System.IO qualified as IO import Text.Read as X (readMaybe) @@ -236,23 +237,28 @@ writeUtf8 fileName txt = do Handle.hSetEncoding handle IO.utf8 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 path txt = do - let withTempFile tmpFilePath tmpHandle = do - Text.hPutStrLn tmpHandle txt - IO.withFile path IO.ReadMode \currentScratchFile -> do - let copyLoop = do - chunk <- Text.hGetChunk currentScratchFile - case Text.length chunk == 0 of - True -> pure () - False -> do - Text.hPutStr tmpHandle chunk - copyLoop - copyLoop - IO.hClose tmpHandle - UnliftIO.renameFile tmpFilePath path - UnliftIO.withTempFile (FilePath.takeDirectory path) ".unison-scratch" withTempFile + Directory.doesFileExist path >>= \case + False -> writeUtf8 path txt + True -> do + let withTempFile tmpFilePath tmpHandle = do + Handle.hSetEncoding tmpHandle IO.utf8 + Text.hPutStrLn tmpHandle txt + IO.withFile path IO.ReadMode \currentScratchFile -> do + Handle.hSetEncoding currentScratchFile IO.utf8 + let copyLoop = do + chunk <- Text.hGetChunk currentScratchFile + case Text.length chunk == 0 of + True -> pure () + False -> do + Text.hPutStr tmpHandle chunk + copyLoop + copyLoop + IO.hClose tmpHandle + UnliftIO.renameFile tmpFilePath path + UnliftIO.withTempFile (FilePath.takeDirectory path) ".unison-scratch" withTempFile reportBug :: String -> String -> String reportBug bugId msg = diff --git a/lib/unison-prelude/src/Unison/Util/Map.hs b/lib/unison-prelude/src/Unison/Util/Map.hs index 49dd66329..be67d730b 100644 --- a/lib/unison-prelude/src/Unison/Util/Map.hs +++ b/lib/unison-prelude/src/Unison/Util/Map.hs @@ -5,6 +5,7 @@ module Unison.Util.Map bitraverse, bitraversed, deleteLookup, + deleteLookupJust, elemsSet, foldM, foldMapM, @@ -21,6 +22,7 @@ module Unison.Util.Map upsertF, upsertLookup, valuesVector, + asList_, ) 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 = 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 :: (Ord b) => Map a b -> Map b a swap = @@ -96,6 +107,11 @@ deleteLookup :: (Ord k) => k -> Map k v -> (Maybe v, Map k v) deleteLookup = Map.alterF (,Nothing) +-- | Like 'deleteLookup', but asserts the value is in the map prior to deletion. +deleteLookupJust :: (HasCallStack, Ord k) => k -> Map k v -> (v, Map k v) +deleteLookupJust = + Map.alterF (maybe (error (reportBug "E525283" "deleteLookupJust: element not found")) (,Nothing)) + -- | Like 'Map.elems', but return the values as a set. elemsSet :: Ord v => Map k v -> Set v elemsSet = diff --git a/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index 80768fa63..3fdff06ae 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -65,6 +65,7 @@ library base , bytestring , containers + , directory , either , extra , filepath diff --git a/nix/docker.nix b/nix/docker.nix index 4017a792d..bfd4751e4 100644 --- a/nix/docker.nix +++ b/nix/docker.nix @@ -5,6 +5,6 @@ name = "ucm"; tag = "latest"; contents = with pkgs; [ cacert fzf ]; - config.Cmd = [ "${haskell-nix."unison-cli:exe:unison"}/bin/unison" ]; + config.Cmd = [ "${haskell-nix."unison-cli-main:exe:unison"}/bin/unison" ]; }; } diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 9817a18b4..107b765c3 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -86,10 +86,6 @@ module Unison.Codebase syncFromDirectory, syncToDirectory, - -- ** Remote sync - viewRemoteBranch, - pushGitBranch, - -- * Codebase path getCodebaseDir, CodebasePath, @@ -124,13 +120,11 @@ import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) import Unison.Codebase.CodeLookup qualified as CL -import Unison.Codebase.Editor.Git qualified as Git -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace) import Unison.Codebase.Path import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations -import Unison.Codebase.Type (Codebase (..), GitError) +import Unison.Codebase.Type (Codebase (..)) import Unison.CodebasePath (CodebasePath, getCodebaseDir) import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.DataDeclaration (Decl) @@ -466,20 +460,6 @@ isType c r = case r of Reference.Builtin {} -> pure $ Builtin.isBuiltinType r Reference.DerivedId r -> isJust <$> getTypeDeclaration c r --- * Git stuff - --- | Pull a git branch and view it from the cache, without syncing into the --- local codebase. -viewRemoteBranch :: - (MonadIO m) => - Codebase m v a -> - ReadGitRemoteNamespace -> - Git.GitBranchBehavior -> - (Branch m -> m r) -> - m (Either GitError r) -viewRemoteBranch codebase ns gitBranchBehavior action = - viewRemoteBranch' codebase ns gitBranchBehavior (\(b, _dir) -> action b) - unsafeGetComponentLength :: (HasCallStack) => Hash -> Sqlite.Transaction Reference.CycleSize unsafeGetComponentLength h = Operations.getCycleLen h >>= \case diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 56ecaff30..b9a0e625a 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -476,13 +476,18 @@ cons :: (Applicative m) => Branch0 m -> Branch m -> Branch m cons = step . const -- | 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 = Branch (Causal.mergeNode child (Map.fromList [f parent1, f parent2])) where - f :: Branch m -> (CausalHash, m (Causal m (Branch0 m))) - f parent = - (headHash parent, pure (_history parent)) + f (hash, getBranch) = + (hash, _history <$> getBranch) isOne :: Branch m -> Bool 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`. modifyAtM :: forall n m. - (Functor n) => - (Applicative m) => -- because `Causal.cons` uses `pure` + (Functor n, Applicative m) => Path -> (Branch m -> n (Branch m)) -> Branch m -> n (Branch m) modifyAtM path f b = case Path.uncons path of Nothing -> f b - Just (seg, path) -> do - -- Functor + Just (seg, path) -> let child = getChildBranch seg (head b) - child' <- modifyAtM path f child - -- step the branch by updating its children according to fixup - pure $ step (setChildBranch seg child') b + in -- step the branch by updating its children according to fixup + (\child' -> step (setChildBranch seg child') b) <$> modifyAtM path f child -- | Perform updates over many locations within a branch by batching up operations on -- sub-branches as much as possible without affecting semantics. diff --git a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs index 8a3d1a622..37c714ed7 100644 --- a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs +++ b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs @@ -15,8 +15,6 @@ module Unison.Codebase.BranchUtil makeAddTermName, makeDeleteTermName, makeAnnihilateTermName, - makeDeletePatch, - makeReplacePatch, ) where @@ -24,7 +22,6 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Unison.Codebase.Branch (Branch, Branch0) import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.HashQualified' (HashQualified (HashQualified, NameOnly)) @@ -83,12 +80,6 @@ makeAnnihilateTermName (p, name) = (p, Branch.annihilateTermName name) makeAnnihilateTypeName :: Path.Split -> (Path, Branch0 m -> Branch0 m) makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name) -makeReplacePatch :: (Applicative m) => Path.Split -> Patch -> (Path, Branch0 m -> Branch0 m) -makeReplacePatch (p, name) patch = (p, Branch.replacePatch name patch) - -makeDeletePatch :: Path.Split -> (Path, Branch0 m -> Branch0 m) -makeDeletePatch (p, name) = (p, Branch.deletePatch name) - makeAddTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m) makeAddTypeName (p, name) r = (p, Branch.addTypeName r name) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs index 733c9fa1b..cc75bc31e 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs @@ -4,8 +4,19 @@ module Unison.Codebase.Editor.DisplayObject where import Data.Bifoldable 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.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 deriving (Eq, Ord, Show, Functor, Generic, Foldable, Traversable) @@ -27,3 +38,14 @@ toMaybe :: DisplayObject b a -> Maybe a toMaybe = \case UserObject a -> Just a _ -> 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) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs deleted file mode 100644 index e6c36626e..000000000 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ /dev/null @@ -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 diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 00e5ddc55..a3d5c63f5 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -2,22 +2,13 @@ module Unison.Codebase.Editor.RemoteRepo where import Control.Lens (Lens') import Control.Lens qualified as Lens -import Data.Text qualified as Text import Data.Void (absurd) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path -import Unison.Codebase.ShortCausalHash (ShortCausalHash) -import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Share.Types -import Unison.Util.Monoid qualified as Monoid - -data ReadRepo - = ReadRepoGit ReadGitRepo - | ReadRepoShare ShareCodeserver - deriving stock (Eq, Ord, Show) data ShareCodeserver = DefaultCodeserver @@ -44,58 +35,21 @@ displayShareCodeserver cs shareUser path = CustomCodeserver cu -> "share(" <> tShow cu <> ")." in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path -data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} - deriving stock (Eq, Ord, Show) - -data WriteRepo - = WriteRepoGit WriteGitRepo - | WriteRepoShare ShareCodeserver - deriving stock (Eq, Ord, Show) - -data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text} - deriving stock (Eq, Ord, Show) - -writeToRead :: WriteRepo -> ReadRepo -writeToRead = \case - WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo) - WriteRepoShare repo -> ReadRepoShare repo - -writeToReadGit :: WriteGitRepo -> ReadGitRepo -writeToReadGit = \case - WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch} - writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void writeNamespaceToRead = \case - WriteRemoteNamespaceGit WriteGitRemoteNamespace {repo, path} -> - ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sch = Nothing, path} WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} -> ReadShare'LooseCode ReadShareLooseCode {server, repo, path} WriteRemoteProjectBranch v -> absurd v -printReadGitRepo :: ReadGitRepo -> Text -printReadGitRepo ReadGitRepo {url, ref} = - "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) <> ")" - -printWriteGitRepo :: WriteGitRepo -> Text -printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")" - -- | print remote namespace printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text printReadRemoteNamespace printProject = \case - ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sch, path} -> - printReadGitRepo repo <> maybePrintSCH sch <> maybePrintPath path - where - maybePrintSCH = \case - Nothing -> mempty - Just sch -> "#" <> SCH.toText sch ReadShare'LooseCode ReadShareLooseCode {server, repo, path} -> displayShareCodeserver server repo path ReadShare'ProjectBranch project -> printProject project -- | Render a 'WriteRemoteNamespace' as text. printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text printWriteRemoteNamespace = \case - WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo, path}) -> - printWriteGitRepo repo <> maybePrintPath path WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) -> displayShareCodeserver server repo path WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch @@ -107,20 +61,12 @@ maybePrintPath path = else "." <> Path.toText path data ReadRemoteNamespace a - = ReadRemoteNamespaceGit !ReadGitRemoteNamespace - | ReadShare'LooseCode !ReadShareLooseCode + = ReadShare'LooseCode !ReadShareLooseCode | -- | A remote project+branch, specified by name (e.g. @unison/base/main). -- Currently assumed to be hosted on Share, though we could include a ShareCodeserver in here, too. ReadShare'ProjectBranch !a deriving stock (Eq, Functor, Show, Generic) -data ReadGitRemoteNamespace = ReadGitRemoteNamespace - { repo :: !ReadGitRepo, - sch :: !(Maybe ShortCausalHash), - path :: !Path - } - deriving stock (Eq, Show) - data ReadShareLooseCode = ReadShareLooseCode { server :: !ShareCodeserver, repo :: !ShareUserHandle, @@ -136,8 +82,7 @@ isPublic ReadShareLooseCode {path} = _ -> False data WriteRemoteNamespace a - = WriteRemoteNamespaceGit !WriteGitRemoteNamespace - | WriteRemoteNamespaceShare !WriteShareRemoteNamespace + = WriteRemoteNamespaceShare !WriteShareRemoteNamespace | WriteRemoteProjectBranch a deriving stock (Eq, Functor, Show) @@ -146,23 +91,14 @@ remotePath_ :: Lens' (WriteRemoteNamespace Void) Path remotePath_ = Lens.lens getter setter where getter = \case - WriteRemoteNamespaceGit (WriteGitRemoteNamespace _ path) -> path WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path WriteRemoteProjectBranch v -> absurd v setter remote path = case remote of - WriteRemoteNamespaceGit (WriteGitRemoteNamespace repo _) -> - WriteRemoteNamespaceGit $ WriteGitRemoteNamespace repo path WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) -> WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path WriteRemoteProjectBranch v -> absurd v -data WriteGitRemoteNamespace = WriteGitRemoteNamespace - { repo :: !WriteGitRepo, - path :: !Path - } - deriving stock (Eq, Generic, Show) - data WriteShareRemoteNamespace = WriteShareRemoteNamespace { server :: !ShareCodeserver, repo :: !ShareUserHandle, diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index 4d8a5317a..e7f1ef076 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -14,17 +14,19 @@ import Unison.Codebase.MainTerm (getMainTerm) import Unison.Codebase.MainTerm qualified as MainTerm import Unison.Codebase.Runtime (Runtime) import Unison.Codebase.Runtime qualified as Runtime +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) -import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.Symbol (Symbol) +import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Util.Pretty qualified as P execute :: Codebase.Codebase IO Symbol Ann -> Runtime Symbol -> - Text -> + HQ.HashQualified Name -> IO (Either Runtime.Error ()) execute codebase runtime mainName = (`finally` Runtime.terminate runtime) . runExceptT $ do @@ -34,9 +36,8 @@ execute codebase runtime mainName = let mainType = Runtime.mainType runtime mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType case mt of - MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.text s) - MainTerm.NotFound s -> throwError ("Not found: " <> P.text s) - MainTerm.BadType s _ -> throwError (P.text s <> " is not of type '{IO} ()") + MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s)) + MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()") MainTerm.Success _ tm _ -> do let codeLookup = Codebase.toCodeLookup codebase ppe = PPE.empty diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs deleted file mode 100644 index d6d3acc43..000000000 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ /dev/null @@ -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) diff --git a/parser-typechecker/src/Unison/Codebase/MainTerm.hs b/parser-typechecker/src/Unison/Codebase/MainTerm.hs index 159030aa7..9f99ae559 100644 --- a/parser-typechecker/src/Unison/Codebase/MainTerm.hs +++ b/parser-typechecker/src/Unison/Codebase/MainTerm.hs @@ -16,7 +16,6 @@ import Unison.Parser.Ann qualified as Parser.Ann import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent qualified as Referent -import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) @@ -26,37 +25,33 @@ import Unison.Var (Var) import Unison.Var qualified as Var data MainTerm v - = NotAFunctionName Text - | NotFound Text - | BadType Text (Maybe (Type v Ann)) + = NotFound (HQ.HashQualified Name) + | BadType (HQ.HashQualified Name) (Maybe (Type v Ann)) | Success (HQ.HashQualified Name) (Term v Ann) (Type v Ann) getMainTerm :: (Monad m, Var v) => (Reference -> m (Maybe (Type v Ann))) -> Names.Names -> - Text -> + HQ.HashQualified Name -> Type.Type v Ann -> m (MainTerm v) -getMainTerm loadTypeOfTerm parseNames mainName mainType = - case HQ.parseText mainName of - Nothing -> pure (NotAFunctionName mainName) - Just hq -> do - let refs = Names.lookupHQTerm Names.IncludeSuffixes hq parseNames - let a = Parser.Ann.External - case toList refs of - [] -> pure (NotFound mainName) - [Referent.Ref ref] -> do - typ <- loadTypeOfTerm ref - case typ of - Just typ -> - if Typechecker.fitsScheme typ mainType - then do - let tm = DD.forceTerm a a (Term.ref a ref) - return (Success hq tm typ) - else pure (BadType mainName $ Just typ) - _ -> pure (BadType mainName Nothing) - _ -> pure (error "multiple matching refs") -- TODO: make a real exception +getMainTerm loadTypeOfTerm parseNames mainName mainType = do + let refs = Names.lookupHQTerm Names.IncludeSuffixes mainName parseNames + let a = Parser.Ann.External + case toList refs of + [] -> pure (NotFound mainName) + [Referent.Ref ref] -> do + typ <- loadTypeOfTerm ref + case typ of + Just typ -> + if Typechecker.fitsScheme typ mainType + then do + let tm = DD.forceTerm a a (Term.ref a ref) + return (Success mainName tm typ) + else pure (BadType mainName $ Just typ) + _ -> pure (BadType mainName Nothing) + _ -> pure (error "multiple matching refs") -- TODO: make a real exception -- forall x. '{ io2.IO, Exception } x builtinMain :: (Var v) => a -> Type.Type v a diff --git a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs index 753351933..7e8b40e75 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs @@ -2,6 +2,7 @@ module Unison.Codebase.ShortCausalHash ( toString, toHash, fromHash, + fromFullHash, fromText, ShortCausalHash (..), ) @@ -27,6 +28,14 @@ fromHash :: (Coercible h Hash.Hash) => Int -> h -> ShortCausalHash fromHash len = ShortCausalHash . Text.take len . Hash.toBase32HexText . coerce +-- | This allows a full hash to be preserved as a `ShortCausalHash`. +-- +-- `ShortCausalHash` is used for input when we expect a user to enter a hash on the command line, so they aren’t +-- required to enter the full hash. However, these inputs may also come from an internal source, and in such cases, +-- there is no reason to truncate the hash. +fromFullHash :: (Coercible h Hash.Hash) => h -> ShortCausalHash +fromFullHash = ShortCausalHash . Hash.toBase32HexText . coerce + -- abc -> SCH abc -- #abc -> SCH abc fromText :: Text -> Maybe ShortCausalHash diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 18f0d8bd8..18f21330e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -14,17 +14,13 @@ where import Control.Monad.Except qualified as Except import Control.Monad.Extra qualified as Monad -import Data.Char qualified as Char import Data.Either.Extra () import Data.IORef import Data.Map qualified as Map import Data.Set qualified as Set -import Data.Text qualified as Text import Data.Time (getCurrentTime) import System.Console.ANSI qualified as ANSI import System.FileLock (SharedExclusive (Exclusive), withTryFileLock) -import System.FilePath qualified as FilePath -import System.FilePath.Posix qualified as FilePath.Posix import U.Codebase.HashTags (CausalHash, PatchHash (..)) import U.Codebase.Reflog qualified as Reflog import U.Codebase.Sqlite.Operations qualified as Ops @@ -36,15 +32,6 @@ import Unison.Codebase (Codebase, CodebasePath) import Unison.Codebase qualified as Codebase1 import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) -import Unison.Codebase.Editor.Git qualified as Git -import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace (..), - ReadGitRepo, - WriteGitRepo (..), - writeToReadGit, - ) -import Unison.Codebase.GitError qualified as GitError import Unison.Codebase.Init (BackupStrategy (..), CodebaseLockOption (..), MigrationStrategy (..), VacuumStrategy (..)) import Unison.Codebase.Init qualified as Codebase import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1 @@ -54,12 +41,11 @@ import Unison.Codebase.RootBranchCache import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.Codebase.SqliteCodebase.GitError qualified as GitError import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps import Unison.Codebase.SqliteCodebase.Paths import Unison.Codebase.SqliteCodebase.SyncEphemeral qualified as SyncEphemeral -import Unison.Codebase.Type (GitPushBehavior, LocalOrRemote (..)) +import Unison.Codebase.Type (LocalOrRemote (..)) import Unison.Codebase.Type qualified as C import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) @@ -75,9 +61,8 @@ import Unison.Term (Term) import Unison.Type (Type) import Unison.Util.Timing (time) import Unison.WatchKind qualified as UF -import UnliftIO (UnliftIO (..), finally, throwIO, try) +import UnliftIO (UnliftIO (..), finally) import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) -import UnliftIO.Exception (catch) import UnliftIO.STM debug, debugProcessBranches :: Bool @@ -103,30 +88,6 @@ initWithSetup onCreate = codebasePath = makeCodebaseDirPath } -data CodebaseStatus - = ExistingCodebase - | CreatedCodebase - deriving (Eq) - --- | Open the codebase at the given location, or create it if one doesn't already exist. -withOpenOrCreateCodebase :: - (MonadUnliftIO m) => - Sqlite.Transaction () -> - Codebase.DebugName -> - CodebasePath -> - LocalOrRemote -> - CodebaseLockOption -> - MigrationStrategy -> - ((CodebaseStatus, Codebase m Symbol Ann) -> m r) -> - m (Either Codebase1.OpenCodebaseError r) -withOpenOrCreateCodebase onCreate debugName codebasePath localOrRemote lockOption migrationStrategy action = do - createCodebaseOrError onCreate debugName codebasePath lockOption (action' CreatedCodebase) >>= \case - Left (Codebase1.CreateCodebaseAlreadyExists) -> do - sqliteCodebase debugName codebasePath localOrRemote lockOption migrationStrategy (action' ExistingCodebase) - Right r -> pure (Right r) - where - action' openOrCreate codebase = action (openOrCreate, codebase) - -- | Create a codebase at the given location. createCodebaseOrError :: (MonadUnliftIO m) => @@ -379,8 +340,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action putBranch, syncFromDirectory, syncToDirectory, - viewRemoteBranch', - pushGitBranch = \repo opts action -> withConn \conn -> pushGitBranch conn repo opts action, getWatch, termsOfTypeImpl, termsMentioningTypeImpl, @@ -571,214 +530,6 @@ syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (l where v = const () --- FIXME(mitchell) seems like this should have "git" in its name -viewRemoteBranch' :: - forall m r. - (MonadUnliftIO m) => - ReadGitRemoteNamespace -> - Git.GitBranchBehavior -> - ((Branch m, CodebasePath) -> m r) -> - m (Either C.GitError r) -viewRemoteBranch' ReadGitRemoteNamespace {repo, sch, path} gitBranchBehavior action = UnliftIO.try $ do - -- set up the cache dir - time "Git fetch" $ - throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do - let remotePath = Git.gitDirToPath remoteRepo - -- In modern UCM all new codebases are created in WAL mode, but it's possible old - -- codebases were pushed to git in DELETE mode, so when pulling remote branches we - -- ensure we're in WAL mode just to be safe. - ensureWALMode conn = Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL - -- Tickle the database before calling into `sqliteCodebase`; this covers the case that the database file either - -- doesn't exist at all or isn't a SQLite database file, but does not cover the case that the database file itself - -- is somehow corrupt, or not even a Unison database. - -- - -- FIXME it would probably make more sense to define some proper preconditions on `sqliteCodebase`, and perhaps - -- update its output type, which currently indicates the only way it can fail is with an `UnknownSchemaVersion` - -- error. - (withConnection "codebase exists check" remotePath ensureWALMode) `catch` \exception -> - if Sqlite.isCantOpenException exception - then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath)) - else throwIO exception - - result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote DoLock (MigrateAfterPrompt Codebase.Backup Codebase.Vacuum) \codebase -> do - -- try to load the requested branch from it - branch <- time "Git fetch (sch)" $ case sch of - -- no sub-branch was specified, so use the root. - Nothing -> time "Get remote root branch" $ Codebase1.getRootBranch codebase - -- load from a specific `ShortCausalHash` - Just sch -> do - branchCompletions <- Codebase1.runTransaction codebase (Codebase1.causalHashesByPrefix sch) - case toList branchCompletions of - [] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch - [h] -> - (Codebase1.getBranchForHash codebase h) >>= \case - Just b -> pure b - Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch - _ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sch branchCompletions - case Branch.getAt path branch of - Just b -> action (b, remotePath) - Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path - case result of - Left err -> throwIO . C.GitSqliteCodebaseError $ C.gitErrorFromOpenCodebaseError remotePath repo err - Right inner -> pure inner - --- | Push a branch to a repo. Optionally attempt to set the branch as the new root, which fails if the branch is not after --- the existing root. -pushGitBranch :: - forall m e. - (MonadUnliftIO m) => - Sqlite.Connection -> - WriteGitRepo -> - GitPushBehavior -> - -- An action which accepts the current root branch on the remote and computes a new branch. - (Branch m -> m (Either e (Branch m))) -> - m (Either C.GitError (Either e (Branch m))) -pushGitBranch srcConn repo behavior action = UnliftIO.try do - -- Pull the latest remote into our git cache - -- Use a local git clone to copy this git repo into a temp-dir - -- Delete the codebase in our temp-dir - -- Use sqlite's VACUUM INTO command to make a copy of the remote codebase into our temp-dir - -- Connect to the copied codebase and sync whatever it is we want to push. - -- sync the branch to the staging codebase using `syncInternal`, which probably needs to be passed in instead of `syncToDirectory` - -- if setting the remote root, - -- do a `before` check on the staging codebase - -- if it passes, proceed (see below) - -- if it fails, throw an exception (which will rollback) and clean up. - -- push from the temp-dir to the remote. - -- Delete the temp-dir. - -- - -- set up the cache dir - throwEitherMWith C.GitProtocolError . withRepo readRepo Git.CreateBranchIfMissing $ \pushStaging -> do - newBranchOrErr <- throwEitherMWith (C.GitSqliteCodebaseError . C.gitErrorFromOpenCodebaseError (Git.gitDirToPath pushStaging) readRepo) - . withOpenOrCreateCodebase (pure ()) "push.dest" (Git.gitDirToPath pushStaging) Remote DoLock (MigrateAfterPrompt Codebase.Backup Codebase.Vacuum) - $ \(codebaseStatus, destCodebase) -> do - currentRootBranch <- - Codebase1.runTransaction destCodebase CodebaseOps.getRootBranchExists >>= \case - False -> pure Branch.empty - True -> C.getRootBranch destCodebase - action currentRootBranch >>= \case - Left e -> pure $ Left e - Right newBranch -> do - C.withConnection destCodebase \destConn -> - doSync codebaseStatus destConn newBranch - pure (Right newBranch) - for newBranchOrErr $ push pushStaging repo - pure newBranchOrErr - where - readRepo :: ReadGitRepo - readRepo = writeToReadGit repo - doSync :: CodebaseStatus -> Sqlite.Connection -> Branch m -> m () - doSync codebaseStatus destConn newBranch = do - progressStateRef <- liftIO (newIORef emptySyncProgressState) - Sqlite.runReadOnlyTransaction srcConn \runSrc -> do - Sqlite.runWriteTransaction destConn \runDest -> do - _ <- syncInternal (syncProgress progressStateRef) runSrc runDest newBranch - let overwriteRoot forcePush = do - let newBranchHash = Branch.headHash newBranch - case codebaseStatus of - ExistingCodebase -> do - when (not forcePush) do - -- the call to runDB "handles" the possible DB error by bombing - runDest Ops.loadRootCausalHash >>= \case - Nothing -> pure () - Just oldRootHash -> do - runDest (CodebaseOps.before oldRootHash newBranchHash) >>= \case - False -> throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo - True -> pure () - CreatedCodebase -> pure () - runDest (setRepoRoot newBranchHash) - case behavior of - C.GitPushBehaviorGist -> pure () - C.GitPushBehaviorFf -> overwriteRoot False - C.GitPushBehaviorForce -> overwriteRoot True - setRepoRoot :: CausalHash -> Sqlite.Transaction () - setRepoRoot h = do - let err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h - chId <- fromMaybe err <$> Q.loadCausalHashIdByCausalHash h - Q.setNamespaceRoot chId - - -- This function makes sure that the result of git status is valid. - -- Valid lines are any of: - -- - -- ?? .unison/v2/unison.sqlite3 (initial commit to an empty repo) - -- M .unison/v2/unison.sqlite3 (updating an existing repo) - -- D .unison/v2/unison.sqlite3-wal (cleaning up the WAL from before bugfix) - -- D .unison/v2/unison.sqlite3-shm (ditto) - -- - -- Invalid lines are like: - -- - -- ?? .unison/v2/unison.sqlite3-wal - -- - -- Which will only happen if the write-ahead log hasn't been - -- fully folded into the unison.sqlite3 file. - -- - -- Returns `Just (hasDeleteWal, hasDeleteShm)` on success, - -- `Nothing` otherwise. hasDeleteWal means there's the line: - -- D .unison/v2/unison.sqlite3-wal - -- and hasDeleteShm is `True` if there's the line: - -- D .unison/v2/unison.sqlite3-shm - -- - parseStatus :: Text -> Maybe (Bool, Bool) - parseStatus status = - if all okLine statusLines - then Just (hasDeleteWal, hasDeleteShm) - else Nothing - where - -- `git status` always displays paths using posix forward-slashes, - -- so we have to convert our expected path to test. - posixCodebasePath = - FilePath.Posix.joinPath (FilePath.splitDirectories codebasePath) - posixLockfilePath = FilePath.replaceExtension posixCodebasePath "lockfile" - statusLines = Text.unpack <$> Text.lines status - t = dropWhile Char.isSpace - okLine (t -> '?' : '?' : (t -> p)) | p == posixCodebasePath || p == posixLockfilePath = True - okLine (t -> 'M' : (t -> p)) | p == posixCodebasePath = True - okLine line = isWalDelete line || isShmDelete line - isWalDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True - isWalDelete _ = False - isShmDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True - isShmDelete _ = False - hasDeleteWal = any isWalDelete statusLines - hasDeleteShm = any isShmDelete statusLines - - -- Commit our changes - push :: forall n. (MonadIO n) => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO - push remotePath repo@(WriteGitRepo {url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do - -- has anything changed? - -- note: -uall recursively shows status for all files in untracked directories - -- we want this so that we see - -- `?? .unison/v2/unison.sqlite3` and not - -- `?? .unison/` - status <- gitTextIn remotePath ["status", "--short", "-uall"] - if Text.null status - then pure False - else case parseStatus status of - Nothing -> - error $ - "An error occurred during push.\n" - <> "I was expecting only to see " - <> codebasePath - <> " modified, but saw:\n\n" - <> Text.unpack status - <> "\n\n" - <> "Please visit https://github.com/unisonweb/unison/issues/2063\n" - <> "and add any more details about how you encountered this!\n" - Just (hasDeleteWal, hasDeleteShm) -> do - -- Only stage files we're expecting; don't `git add --all .` - -- which could accidentally commit some garbage - gitIn remotePath ["add", Text.pack codebasePath] - when hasDeleteWal $ gitIn remotePath ["rm", Text.pack $ codebasePath <> "-wal"] - when hasDeleteShm $ gitIn remotePath ["rm", Text.pack $ codebasePath <> "-shm"] - gitIn - remotePath - ["commit", "-q", "-m", "Sync branch " <> Text.pack (show $ Branch.headHash newRootBranch)] - -- Push our changes to the repo, silencing all output. - -- Even with quiet, the remote (Github) can still send output through, - -- so we capture stdout and stderr. - (successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", url] ++ Git.gitVerbosity ++ maybe [] (pure @[]) mayGitBranch - when (not successful) . throwIO $ GitError.PushException repo (Text.unpack stderr) - pure True - -- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase -- at the source to the destination. -- Note: this does not copy the .unisonConfig file. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs deleted file mode 100644 index f60581214..000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs +++ /dev/null @@ -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) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs index 6e0b3d855..b62708f70 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs @@ -6,6 +6,7 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchem import Control.Monad.Except 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.Operations qualified as Ops @@ -50,7 +51,7 @@ addStatsForBranch :: DB.BranchObjectId -> Sqlite.Transaction (Sync.TrySyncResult addStatsForBranch boId = do bhId <- Db.BranchHashId <$> Q.expectPrimaryHashIdForObject (Db.unBranchObjectId boId) -- "expectNamespaceStatsByHashId" computes stats if they are missing. - Ops.expectNamespaceStatsByHashId bhId + _ :: NamespaceStats <- Ops.expectNamespaceStatsByHashId bhId pure Sync.Done debugLog :: String -> Sqlite.Transaction () diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index d9da1aa2a..0b803dd73 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -4,21 +4,13 @@ module Unison.Codebase.Type ( Codebase (..), CodebasePath, - GitPushBehavior (..), - GitError (..), LocalOrRemote (..), - gitErrorFromOpenCodebaseError, ) where import U.Codebase.HashTags (CausalHash) import U.Codebase.Reference qualified as V2 import Unison.Codebase.Branch (Branch) -import Unison.Codebase.Editor.Git qualified as Git -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo) -import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError) -import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) -import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..)) import Unison.CodebasePath (CodebasePath) import Unison.ConstructorType qualified as CT import Unison.DataDeclaration (Decl) @@ -80,9 +72,6 @@ data Codebase m v a = Codebase syncFromDirectory :: CodebasePath -> Branch m -> m (), -- | Copy a branch and all of its dependencies from this codebase into the given codebase. syncToDirectory :: CodebasePath -> Branch m -> m (), - viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r), - -- | Push the given branch to the given repo, and optionally set it as the root branch. - pushGitBranch :: forall e. WriteGitRepo -> GitPushBehavior -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))), -- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@. getWatch :: WK.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a)), -- | Get the set of user-defined terms-or-constructors that have the given type. @@ -106,28 +95,3 @@ data LocalOrRemote = Local | Remote deriving (Show, Eq, Ord) - -data GitPushBehavior - = -- | Don't set root, just sync entities. - GitPushBehaviorGist - | -- | After syncing entities, do a fast-forward check, then set the root. - GitPushBehaviorFf - | -- | After syncing entities, just set the root (force-pushy). - GitPushBehaviorForce - -data GitError - = GitProtocolError GitProtocolError - | GitCodebaseError (GitCodebaseError CausalHash) - | GitSqliteCodebaseError GitSqliteCodebaseError - deriving (Show) - -instance Exception GitError - -gitErrorFromOpenCodebaseError :: CodebasePath -> ReadGitRepo -> OpenCodebaseError -> GitSqliteCodebaseError -gitErrorFromOpenCodebaseError path repo = \case - OpenCodebaseDoesntExist -> NoDatabaseFile repo path - OpenCodebaseUnknownSchemaVersion v -> - UnrecognizedSchemaVersion repo path (fromIntegral v) - OpenCodebaseRequiresMigration fromSv toSv -> - CodebaseRequiresMigration fromSv toSv - OpenCodebaseFileLockFailed -> CodebaseFileLockFailed diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 4ae186aa7..3b74b59e8 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -929,7 +929,7 @@ nativeCompileCodes executable codes base path = do BS.hPut pin . runPutS . putWord32be . fromIntegral $ BS.length bytes BS.hPut pin bytes UnliftIO.hClose pin - waitForProcess ph + _ <- waitForProcess ph pure () callout _ _ _ _ = fail "withCreateProcess didn't provide handles" ucrError (e :: IOException) = diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index 9a89624e6..8c9163370 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -142,11 +142,11 @@ link :: (Monad m, Var v) => TermP v m link = termLink <|> typeLink where 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' pure $ Term.typeLink (ann tok) (L.payload tok) termLink = do - P.try (reserved "termLink") + _ <- P.try (reserved "termLink") tok <- termLink' pure $ Term.termLink (ann tok) (L.payload tok) @@ -201,7 +201,7 @@ matchCase = do unit ann = Pattern.Constructor ann (ConstructorReference DD.unitRef 0) [] pair p1 p2 = Pattern.Constructor (ann p1 <> ann p2) (ConstructorReference DD.pairRef 0) [p1, p2] let guardedBlocks = label "pattern guard" . some $ do - reserved "|" + _ <- reserved "|" guard <- asum [ Nothing <$ P.try (quasikeyword "otherwise"), @@ -290,7 +290,7 @@ parsePattern = label "pattern" root | Set.null s -> die tok s | Set.size s > 1 -> die tok s | otherwise -> -- matched ctor name, consume the token - do anyToken; pure (Set.findMin s <$ tok) + do _ <- anyToken; pure (Set.findMin s <$ tok) where isLower = Text.all Char.isLower . Text.take 1 . Name.toText die hq s = case L.payload hq of @@ -1058,7 +1058,7 @@ destructuringBind = do (p, boundVars) <- P.try do (p, boundVars) <- parsePattern let boundVars' = snd <$> boundVars - P.lookAhead (openBlockWith "=") + _ <- P.lookAhead (openBlockWith "=") pure (p, boundVars') (_spanAnn, scrute) <- block "=" -- Dwight K. Scrute ("The People's Scrutinee") let guard = Nothing diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 208478e66..f249c0abd 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -2197,7 +2197,7 @@ coalesceWanted' keep ((loc, n) : new) old if keep u then pure (new, (loc, n) : old) else do - defaultAbility n + _ <- defaultAbility n pure (new, old) coalesceWanted new old | otherwise = coalesceWanted' keep new ((loc, n) : old) diff --git a/parser-typechecker/src/Unison/Util/Convert.hs b/parser-typechecker/src/Unison/Util/Convert.hs deleted file mode 100644 index 7962a9851..000000000 --- a/parser-typechecker/src/Unison/Util/Convert.hs +++ /dev/null @@ -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 diff --git a/parser-typechecker/src/Unison/Util/PinBoard.hs b/parser-typechecker/src/Unison/Util/PinBoard.hs deleted file mode 100644 index 79c10589b..000000000 --- a/parser-typechecker/src/Unison/Util/PinBoard.hs +++ /dev/null @@ -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 diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index be845c166..a3f0d89d6 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -26,7 +26,6 @@ import Unison.Test.Typechecker qualified as Typechecker import Unison.Test.Typechecker.Context qualified as Context import Unison.Test.Typechecker.TypeError qualified as TypeError 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.Text qualified as Text import Unison.Test.Var qualified as Var @@ -54,7 +53,6 @@ test = Typechecker.test, Context.test, Name.test, - PinBoard.test, CodebaseInit.test, Branch.test ] diff --git a/parser-typechecker/tests/Unison/Test/MCode.hs b/parser-typechecker/tests/Unison/Test/MCode.hs index 8d28b0765..8224914d6 100644 --- a/parser-typechecker/tests/Unison/Test/MCode.hs +++ b/parser-typechecker/tests/Unison/Test/MCode.hs @@ -44,7 +44,7 @@ testEval0 :: [(Reference, SuperGroup Symbol)] -> SuperGroup Symbol -> Test () testEval0 env main = ok << io do cc <- baseCCache False - cacheAdd ((mainRef, main) : env) cc + _ <- cacheAdd ((mainRef, main) : env) cc rtm <- readTVarIO (refTm cc) apply0 Nothing cc Nothing (rtm Map.! mainRef) where diff --git a/parser-typechecker/tests/Unison/Test/Util/PinBoard.hs b/parser-typechecker/tests/Unison/Test/Util/PinBoard.hs deleted file mode 100644 index fe114c039..000000000 --- a/parser-typechecker/tests/Unison/Test/Util/PinBoard.hs +++ /dev/null @@ -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, () #)) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 8b4afac91..7a9a46709 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack @@ -47,11 +47,9 @@ library Unison.Codebase.CodeLookup Unison.Codebase.CodeLookup.Util Unison.Codebase.Editor.DisplayObject - Unison.Codebase.Editor.Git Unison.Codebase.Editor.RemoteRepo Unison.Codebase.Execute Unison.Codebase.FileCodebase - Unison.Codebase.GitError Unison.Codebase.Init Unison.Codebase.Init.CreateCodebaseError Unison.Codebase.Init.OpenCodebaseError @@ -71,7 +69,6 @@ library Unison.Codebase.SqliteCodebase.Branch.Cache Unison.Codebase.SqliteCodebase.Branch.Dependencies Unison.Codebase.SqliteCodebase.Conversions - Unison.Codebase.SqliteCodebase.GitError Unison.Codebase.SqliteCodebase.Migrations Unison.Codebase.SqliteCodebase.Migrations.Helpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 @@ -178,14 +175,12 @@ library Unison.UnisonFile.Names Unison.UnisonFile.Summary Unison.UnisonFile.Type - Unison.Util.Convert Unison.Util.CycleTable Unison.Util.CyclicEq Unison.Util.CyclicOrd Unison.Util.EnumContainers Unison.Util.Exception Unison.Util.Logger - Unison.Util.PinBoard Unison.Util.Pretty.MegaParsec Unison.Util.RefPromise Unison.Util.Star2 @@ -385,7 +380,6 @@ test-suite parser-typechecker-tests Unison.Test.Typechecker.Context Unison.Test.Typechecker.TypeError Unison.Test.UnisonSources - Unison.Test.Util.PinBoard Unison.Test.Util.Pretty Unison.Test.Util.Relation Unison.Test.Util.Text diff --git a/unison-cli/src/ArgParse.hs b/unison-cli/src/ArgParse.hs index 84f2ae538..5e7032942 100644 --- a/unison-cli/src/ArgParse.hs +++ b/unison-cli/src/ArgParse.hs @@ -17,6 +17,7 @@ import Options.Applicative ParserPrefs, ReadM, action, + argument, auto, columns, command, @@ -32,6 +33,7 @@ import Options.Applicative info, infoOption, long, + maybeReader, metavar, option, parserFailure, @@ -53,21 +55,21 @@ import System.Environment (lookupEnv) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.CommandLine.Types (ShouldWatchFiles (..)) +import Unison.HashQualified (HashQualified) import Unison.LSP (LspFormattingConfig (..)) +import Unison.Name (Name) import Unison.Prelude import Unison.PrettyTerminal qualified as PT import Unison.Server.CodebaseServer (CodebaseServerOpts (..)) import Unison.Server.CodebaseServer qualified as Server +import Unison.Syntax.HashQualified qualified as HQ import Unison.Util.Pretty (Width (..)) --- The name of a symbol to execute. -type SymbolName = Text - -- | Valid ways to provide source code to the run command data RunSource - = RunFromPipe SymbolName - | RunFromSymbol SymbolName - | RunFromFile FilePath SymbolName + = RunFromPipe (HashQualified Name) + | RunFromSymbol (HashQualified Name) + | RunFromFile FilePath (HashQualified Name) | RunCompiled FilePath deriving (Show, Eq) @@ -368,22 +370,26 @@ versionParser = pure PrintVersion runArgumentParser :: Parser [String] runArgumentParser = many (strArgument (metavar "RUN-ARGS")) +runHQParser :: Parser (HashQualified Name) +runHQParser = + argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL") + runSymbolParser :: Parser Command runSymbolParser = - Run . RunFromSymbol <$> strArgument (metavar "SYMBOL") <*> runArgumentParser + Run . RunFromSymbol <$> runHQParser <*> runArgumentParser runFileParser :: Parser Command runFileParser = Run <$> ( RunFromFile <$> fileArgument "path/to/file" - <*> strArgument (metavar "SYMBOL") + <*> runHQParser ) <*> runArgumentParser runPipeParser :: Parser Command runPipeParser = - Run . RunFromPipe <$> strArgument (metavar "SYMBOL") <*> runArgumentParser + Run . RunFromPipe <$> runHQParser <*> runArgumentParser runCompiledParser :: Parser Command runCompiledParser = diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 41e633d04..bb8ca7904 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -4,8 +4,6 @@ module Unison.Cli.DownloadUtils ( downloadProjectBranchFromShare, downloadLooseCodeFromShare, - GitNamespaceHistoryTreatment (..), - downloadLooseCodeFromGitRepo, ) where @@ -18,27 +16,19 @@ import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.Share.Projects qualified as Share -import Unison.Codebase (Codebase) -import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Editor.Git qualified as Git import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver) import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadShareLooseCode, shareUserHandleToText) +import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode, shareUserHandleToText) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Path qualified as Path -import Unison.Codebase.Type (GitError) -import Unison.Codebase.Type qualified as Codebase (viewRemoteBranch') import Unison.Core.Project (ProjectAndBranch (..)) import Unison.NameSegment.Internal qualified as NameSegment -import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Share.API.Hash qualified as Share import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Sync qualified as Share import Unison.Share.Sync.Types qualified as Share import Unison.Share.Types (codeserverBaseURL) -import Unison.Symbol (Symbol) import Unison.Sync.Common qualified as Sync.Common import Unison.Sync.Types qualified as Share @@ -113,26 +103,3 @@ withEntitiesDownloadedProgressCallback action = do <> tShow entitiesDownloaded <> " entities...\n\n" action ((\n -> atomically (modifyTVar' entitiesDownloadedVar (+ n))), readTVarIO entitiesDownloadedVar) - -data GitNamespaceHistoryTreatment - = -- | Don't touch the history - GitNamespaceHistoryTreatment'LetAlone - | -- | Throw away all history at all levels - GitNamespaceHistoryTreatment'DiscardAllHistory - --- | Download loose code that's in a SQLite codebase in a Git repo. -downloadLooseCodeFromGitRepo :: - MonadIO m => - Codebase IO Symbol Ann -> - GitNamespaceHistoryTreatment -> - ReadGitRemoteNamespace -> - m (Either GitError CausalHash) -downloadLooseCodeFromGitRepo codebase historyTreatment namespace = liftIO do - Codebase.viewRemoteBranch' codebase namespace Git.RequireExistingBranch \(branch0, cacheDir) -> do - let branch = - case historyTreatment of - GitNamespaceHistoryTreatment'LetAlone -> branch0 - GitNamespaceHistoryTreatment'DiscardAllHistory -> Branch.discardHistory branch0 - - Codebase.syncFromDirectory codebase cacheDir branch - pure (Branch.headHash branch) diff --git a/unison-cli/src/Unison/Cli/MergeTypes.hs b/unison-cli/src/Unison/Cli/MergeTypes.hs new file mode 100644 index 000000000..b44870ad6 --- /dev/null +++ b/unison-cli/src/Unison/Cli/MergeTypes.hs @@ -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 diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index ddccf48a2..c9f40cf10 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -67,9 +67,6 @@ module Unison.Cli.MonadUtils -- ** Getting patches getPatchAt, - getMaybePatchAt, - expectPatchAt, - assertNoPatchAt, -- * Latest touched Unison file getLatestFile, @@ -514,16 +511,6 @@ getMaybePatchAt path0 = do branch <- getBranch0At path liftIO (Branch.getMaybePatch name branch) --- | Get the patch at a path, or return early if there's no such patch. -expectPatchAt :: Path.Split' -> Cli Patch -expectPatchAt path = - getMaybePatchAt path & onNothingM (Cli.returnEarly (Output.PatchNotFound path)) - --- | Assert that there's no patch at a path, or return early if there is one. -assertNoPatchAt :: Path.Split' -> Cli () -assertNoPatchAt path = do - whenJustM (getMaybePatchAt path) \_ -> Cli.returnEarly (Output.PatchAlreadyExists path) - ------------------------------------------------------------------------------------------------------------------------ -- Latest (typechecked) unison file utils diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 3e2607c3d..9cf941287 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -19,13 +19,14 @@ module Unison.Cli.Pretty prettyLabeledDependencies, prettyPath, prettyPath', + prettyMergeSource, + prettyMergeSourceOrTarget, prettyProjectAndBranchName, prettyBranchName, prettyProjectBranchName, prettyProjectName, prettyProjectNameSlash, prettyNamespaceKey, - prettyReadGitRepo, prettyReadRemoteNamespace, prettyReadRemoteNamespaceWith, prettyRelative, @@ -35,6 +36,7 @@ module Unison.Cli.Pretty prettySemver, prettyShareLink, prettySharePath, + prettyShareURI, prettySlashProjectBranchName, prettyTermName, prettyTypeName, @@ -43,7 +45,6 @@ module Unison.Cli.Pretty prettyURI, prettyUnisonFile, prettyWhichBranchEmpty, - prettyWriteGitRepo, prettyWriteRemoteNamespace, shareOrigin, unsafePrettyTermResultSigFull', @@ -69,16 +70,15 @@ import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Util.Base32Hex (Base32Hex) import U.Util.Base32Hex qualified as Base32Hex +import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..)) import Unison.Cli.ProjectUtils (projectBranchPathPrism) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject)) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRepo, - ReadRemoteNamespace, + ( ReadRemoteNamespace (..), ShareUserHandle (..), - WriteGitRepo, WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), shareUserHandleToText, @@ -137,6 +137,11 @@ type Pretty = P.Pretty P.ColorText prettyURI :: URI -> Pretty prettyURI = P.bold . P.blue . P.shown +prettyShareURI :: URI -> Pretty +prettyShareURI host + | URI.uriToString id host "" == "https://api.unison-lang.org" = P.bold (P.blue "Unison Share") + | otherwise = P.bold (P.blue (P.shown host)) + prettyReadRemoteNamespace :: ReadRemoteNamespace Share.RemoteProjectBranch -> Pretty prettyReadRemoteNamespace = prettyReadRemoteNamespaceWith \remoteProjectBranch -> @@ -225,6 +230,17 @@ prettyHash = prettyBase32Hex# . Hash.toBase32Hex prettyHash32 :: (IsString s) => Hash32 -> P.Pretty s 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 = P.green . P.text . into @Text @@ -327,18 +343,6 @@ prettyTypeName ppe r = P.syntaxToColor $ prettyHashQualified (PPE.typeName ppe r) -prettyReadGitRepo :: ReadGitRepo -> Pretty -prettyReadGitRepo = \case - RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url) - -prettyWriteGitRepo :: WriteGitRepo -> Pretty -prettyWriteGitRepo RemoteRepo.WriteGitRepo {url} = P.blue (P.text url) - --- prettyWriteRepo :: WriteRepo -> Pretty --- prettyWriteRepo = \case --- RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url) --- RemoteRepo.WriteRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) - -- | Pretty-print a 'WhichBranchEmpty'. prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty prettyWhichBranchEmpty = \case @@ -346,8 +350,8 @@ prettyWhichBranchEmpty = \case WhichBranchEmptyPath path -> prettyPath' path -- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef -displayBranchHash :: CausalHash -> String -displayBranchHash = ("#" <>) . Text.unpack . Hash.toBase32HexText . unCausalHash +displayBranchHash :: CausalHash -> Text +displayBranchHash = ("#" <>) . Hash.toBase32HexText . unCausalHash prettyHumanReadableTime :: UTCTime -> UTCTime -> Pretty prettyHumanReadableTime now time = @@ -379,15 +383,15 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) = -- Special-case Unison Share since we know its project branch URLs if URI.uriToString id host "" == "https://api.unison-lang.org" then - P.hiBlack . P.text $ + P.group $ "https://share.unison-lang.org/" - <> into @Text remoteProject + <> prettyProjectName remoteProject <> "/code/" - <> into @Text remoteBranch + <> prettyProjectBranchName remoteBranch else prettyProjectAndBranchName (ProjectAndBranch remoteProject remoteBranch) <> " on " - <> P.hiBlack (P.shown host) + <> P.shown host stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 9010be1c7..66eb87414 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -25,6 +25,7 @@ module Unison.Cli.ProjectUtils getProjectAndBranchByTheseNames, expectProjectAndBranchByTheseNames, expectLooseCodeOrProjectBranch, + getProjectBranchCausalHash, -- * Loading remote project info expectRemoteProjectById, @@ -36,9 +37,17 @@ module Unison.Cli.ProjectUtils expectRemoteProjectBranchByNames, expectRemoteProjectBranchByTheseNames, + -- * Projecting out common things + justTheIds, + justTheIds', + justTheNames, + -- * Other helpers findTemporaryBranchName, expectLatestReleaseBranchName, + + -- * Upgrade branch utils + getUpgradeBranchParent, ) where @@ -46,7 +55,10 @@ import Control.Lens import Data.List qualified as List import Data.Maybe (fromJust) import Data.Set qualified as Set +import Data.Text qualified as Text import Data.These (These (..)) +import U.Codebase.Causal qualified +import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Project 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.Share.Projects (IncludeSquashedHead) import Unison.Cli.Share.Projects qualified as Share +import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Input (LooseCodeOrProject) import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist)) import Unison.Codebase.Editor.Output qualified as Output @@ -104,6 +117,18 @@ resolveBranchRelativePath = \case Left branchName -> That 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 -- like @preferred@. findTemporaryBranchName :: ProjectId -> ProjectBranchName -> Transaction ProjectBranchName @@ -264,6 +289,13 @@ expectLooseCodeOrProjectBranch = That (ProjectAndBranch (Just project) branch) -> Right (These project branch) 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 @@ -374,3 +406,14 @@ expectLatestReleaseBranchName remoteProject = case remoteProject.latestRelease of Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases remoteProject.projectName) 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--to-`. 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 diff --git a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs index f4d2e870e..c062c7b47 100644 --- a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs +++ b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs @@ -1,7 +1,6 @@ -- | @.unisonConfig@ file utilities module Unison.Cli.UnisonConfigUtils - ( gitUrlKey, - remoteMappingKey, + ( remoteMappingKey, resolveConfiguredUrl, ) where @@ -33,9 +32,6 @@ configKey k p = NameSegment.toEscapedText (Path.toSeq $ Path.unabsolute p) -gitUrlKey :: Path.Absolute -> Text -gitUrlKey = configKey "GitUrl" - remoteMappingKey :: Path.Absolute -> Text remoteMappingKey = configKey "RemoteMapping" @@ -46,13 +42,7 @@ resolveConfiguredUrl :: PushPull -> Path' -> Cli (WriteRemoteNamespace Void) resolveConfiguredUrl pushPull destPath' = do destPath <- Cli.resolvePath' destPath' whenNothingM (remoteMappingForPath pushPull destPath) do - let gitUrlConfigKey = gitUrlKey destPath - -- Fall back to deprecated GitUrl key - Cli.getConfig gitUrlConfigKey >>= \case - Just url -> - (WriteRemoteNamespaceGit <$> P.parse UriParser.deprecatedWriteGitRemoteNamespace (Text.unpack gitUrlConfigKey) url) & onLeft \err -> - Cli.returnEarly (ConfiguredRemoteMappingParseError pushPull destPath url (show err)) - Nothing -> Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath) + Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath) -- | Tries to look up a remote mapping for a given path. -- Will also resolve paths relative to any mapping which is configured for a parent of that diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index ae34404e1..76218eba9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -5,6 +5,7 @@ module Unison.Codebase.Editor.HandleInput (loop) where -- TODO: Don't import backend +import Control.Arrow ((&&&)) import Control.Error.Util qualified as ErrorUtil import Control.Lens hiding (from) import Control.Monad.Reader (ask) @@ -27,7 +28,6 @@ import Text.Megaparsec qualified as Megaparsec import U.Codebase.Branch.Diff qualified as V2Branch.Diff import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) -import U.Codebase.Reference qualified as V2 (Reference) import U.Codebase.Reflog qualified as Reflog import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite @@ -57,6 +57,7 @@ import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) import Unison.Codebase.Editor.HandleInput.Branch (handleBranch) import Unison.Codebase.Editor.HandleInput.BranchRename (handleBranchRename) 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.DebugFoldRanges qualified as DebugFoldRanges 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.ProjectSwitch (projectSwitch) import Unison.Codebase.Editor.HandleInput.Projects (handleProjects) -import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch, propagatePatch) -import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch) +import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch) +import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch) import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft) import Unison.Codebase.Editor.HandleInput.Run (handleRun) import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils @@ -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.Slurp qualified as Slurp import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase) import Unison.Codebase.Metadata qualified as Metadata @@ -106,15 +108,8 @@ import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as HQSplit' import Unison.Codebase.Path qualified as Path -import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions -import Unison.Codebase.TermEdit (TermEdit (..)) -import Unison.Codebase.TermEdit qualified as TermEdit -import Unison.Codebase.TermEdit.Typing qualified as TermEdit -import Unison.Codebase.TypeEdit (TypeEdit) -import Unison.Codebase.TypeEdit qualified as TypeEdit import Unison.CommandLine.BranchRelativePath (BranchRelativePath) import Unison.CommandLine.Completion qualified as Completion import Unison.CommandLine.DisplayValues qualified as DisplayValues @@ -132,7 +127,6 @@ import Unison.LabeledDependency qualified as LD import Unison.LabeledDependency qualified as LabeledDependency import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment import Unison.Names (Names (Names)) import Unison.Names qualified as Names @@ -148,18 +142,16 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Project (ProjectAndBranch (..)) import Unison.Project.Util (projectContextFromPath) -import Unison.Reference (Reference, TermReference) +import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Runtime.IOSource qualified as IOSource -import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.Backend qualified as Backend import Unison.Server.CodebaseServer qualified as Server import Unison.Server.Doc.Markdown.Render qualified as Md import Unison.Server.Doc.Markdown.Types qualified as Md import Unison.Server.NameSearch.FromNames qualified as NameSearch -import Unison.Server.QueryResult import Unison.Server.SearchResult (SearchResult) import Unison.Server.SearchResult qualified as SR import Unison.Share.Codeserver qualified as Codeserver @@ -201,73 +193,13 @@ import UnliftIO.Directory qualified as Directory loop :: Either Event Input -> Cli () loop e = do case e of - Left (IncomingRootBranch hashes) -> Cli.time "IncomingRootBranch" do - schLength <- Cli.runTransaction Codebase.branchHashLength - rootBranch <- Cli.getRootBranch - Cli.respond $ - WarnIncomingRootBranch - (SCH.fromHash schLength $ Branch.headHash rootBranch) - (Set.map (SCH.fromHash schLength) hashes) Left (UnisonFileChanged sourceName text) -> Cli.time "UnisonFileChanged" do -- We skip this update if it was programmatically generated Cli.getLatestFile >>= \case Just (_, True) -> (#latestFile . _Just . _2) .= False _ -> loadUnisonFile sourceName text Right input -> - let typeReferences :: [SearchResult] -> [Reference] - typeReferences rs = - [r | SR.Tp (SR.TypeResult _ r _) <- rs] - termReferences :: [SearchResult] -> [Reference] - termReferences rs = - [r | SR.Tm (SR.TermResult _ (Referent.Ref r) _) <- rs] - termResults rs = [r | SR.Tm r <- rs] - typeResults rs = [r | SR.Tp r <- rs] - doRemoveReplacement :: HQ.HashQualified Name -> Maybe PatchPath -> Bool -> Cli () - doRemoveReplacement from patchPath isTerm = do - let patchPath' = fromMaybe Cli.defaultPatchPath patchPath - patch <- Cli.getPatchAt patchPath' - QueryResult misses allHits <- hqNameQuery Names.IncludeSuffixes [from] - let tpRefs = Set.fromList $ typeReferences allHits - tmRefs = Set.fromList $ termReferences allHits - (hits, opHits) = - let tmResults = Set.fromList $ SR.termName <$> termResults allHits - tpResults = Set.fromList $ SR.typeName <$> typeResults allHits - in case isTerm of - True -> (tmResults, tpResults) - False -> (tpResults, tmResults) - go :: Text -> Reference -> Cli () - go description fr = do - let termPatch = over Patch.termEdits (R.deleteDom fr) patch - typePatch = over Patch.typeEdits (R.deleteDom fr) patch - (patchPath'', patchName) <- Cli.resolveSplit' patchPath' - -- Save the modified patch - Cli.stepAtM - description - ( Path.unabsolute patchPath'', - Branch.modifyPatches - patchName - (const (if isTerm then termPatch else typePatch)) - ) - -- Say something - Cli.respond Success - when (Set.null hits) do - Cli.respond (SearchTermsNotFoundDetailed isTerm misses (Set.toList opHits)) - description <- inputDescription input - traverse_ (go description) (if isTerm then tmRefs else tpRefs) - saveAndApplyPatch :: Path -> NameSegment -> Patch -> Cli () - saveAndApplyPatch patchPath'' patchName patch' = do - description <- inputDescription input - Cli.stepAtM - (description <> " (1/2)") - ( patchPath'', - Branch.modifyPatches patchName (const patch') - ) - -- Apply the modified patch to the current path - -- since we might be able to propagate further. - currentPath <- Cli.getCurrentPath - void $ propagatePatch description patch' currentPath - Cli.respond Success - previewResponse sourceName sr uf = do + let previewResponse sourceName sr uf = do names <- Cli.currentNames let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf names filePPED <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile @@ -290,19 +222,22 @@ loop e = do Cli.respond $ PrintMessage pretty ShowReflogI -> do let numEntriesToShow = 500 - entries <- - Cli.runTransaction do - schLength <- Codebase.branchHashLength - Codebase.getReflog numEntriesToShow <&> fmap (first $ SCH.fromHash schLength) + (schLength, entries) <- + Cli.runTransaction $ + (,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow let moreEntriesToLoad = length entries == numEntriesToShow let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad) - let numberedEntries = expandedEntries <&> \(_time, hash, _reason) -> "#" <> SCH.toString hash + let (shortEntries, numberedEntries) = + unzip $ + expandedEntries <&> \(time, hash, reason) -> + let (exp, sa) = (SCH.fromHash schLength &&& SA.Namespace) hash + in ((time, exp, reason), sa) Cli.setNumberedArgs numberedEntries - Cli.respond $ ShowReflog expandedEntries + Cli.respond $ ShowReflog shortEntries where expandEntries :: - ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool) -> - Maybe ((Maybe UTCTime, SCH.ShortCausalHash, Text), ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool)) + ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool) -> + Maybe ((Maybe UTCTime, CausalHash, Text), ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool)) expandEntries ([], Just expectedHash, moreEntriesToLoad) = if moreEntriesToLoad then Nothing @@ -435,8 +370,11 @@ loop e = do let destp = looseCodeOrProjectToPath dest0 srcb <- Cli.expectBranchAtPath' srcp dest <- Cli.resolvePath' destp - -- todo: fixme: use project and branch names - let err = Just $ MergeAlreadyUpToDate src0 dest0 + let err = + 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 PreviewMergeLocalBranchI src0 dest0 -> do Cli.Env {codebase} <- ask @@ -467,27 +405,6 @@ loop e = do hasConfirmed <- confirmedCommand input description <- inputDescription input doMoveBranch description hasConfirmed src' dest' - MovePatchI src' dest' -> do - description <- inputDescription input - p <- Cli.expectPatchAt src' - Cli.assertNoPatchAt dest' - src <- Cli.resolveSplit' src' - dest <- Cli.resolveSplit' dest' - Cli.stepManyAt - description - [ BranchUtil.makeDeletePatch (Path.convert src), - BranchUtil.makeReplacePatch (Path.convert dest) p - ] - Cli.respond Success - CopyPatchI src dest' -> do - description <- inputDescription input - p <- Cli.expectPatchAt src - Cli.assertNoPatchAt dest' - dest <- Cli.resolveSplit' dest' - Cli.stepAt - description - (BranchUtil.makeReplacePatch (Path.convert dest) p) - Cli.respond Success SwitchBranchI path' -> do path <- Cli.resolvePath' path' branchExists <- Cli.branchExistsAtPath' path' @@ -539,11 +456,12 @@ loop e = do DocToMarkdownI docName -> do names <- Cli.currentNames pped <- Cli.prettyPrintEnvDeclFromNames names - hqLength <- Cli.runTransaction Codebase.hashLength - let nameSearch = NameSearch.makeNameSearch hqLength names 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 - docRefs <- Backend.docsForDefinitionName codebase nameSearch Names.IncludeSuffixes docName for docRefs \docRef -> do Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef) 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'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs - DeleteTarget'Patch src' -> do - _ <- Cli.expectPatchAt src' - description <- inputDescription input - src <- Cli.resolveSplit' src' - Cli.stepAt - description - (BranchUtil.makeDeletePatch (Path.convert src)) - Cli.respond Success DeleteTarget'Namespace insistence Nothing -> do hasConfirmed <- confirmedCommand input if hasConfirmed || insistence == Force @@ -747,16 +657,15 @@ loop e = do Cli.respond DeletedEverything else Cli.respond DeleteEverythingConfirmation DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do - branch <- Cli.expectBranchAtPath' (Path.unsplit' p) + branch <- Cli.expectBranchAtPath (Path.unsplit p) description <- inputDescription input - absPath <- Cli.resolveSplit' p let toDelete = Names.prefix0 - (Path.unsafeToName (Path.unsplit (Path.convert absPath))) + (Path.unsafeToName (Path.unsplit (p))) (Branch.toNames (Branch.head branch)) afterDelete <- do - rootNames <- Branch.toNames <$> Cli.getRootBranch0 - endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty rootNames) + names <- Cli.currentNames + endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names) case (null endangerments, insistence) of (True, _) -> pure (Cli.respond Success) (False, Force) -> do @@ -768,7 +677,7 @@ loop e = do ppeDecl <- Cli.currentPrettyPrintEnvDecl Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments Cli.returnEarlyWithoutOutput - parentPathAbs <- Cli.resolvePath' parentPath + parentPathAbs <- Cli.resolvePath parentPath -- We have to modify the parent in order to also wipe out the history at the -- child. Cli.updateAt description parentPathAbs \parentBranch -> @@ -781,21 +690,12 @@ loop e = do traverse_ (displayI outputLoc) namesToDisplay ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query EditNamespaceI paths -> handleEditNamespace LatestFileLocation paths - FindPatchI -> do - branch <- Cli.getCurrentBranch0 - let patches = - [ Path.unsafeToName $ Path.snoc p seg - | (p, b) <- Branch.toList0 branch, - (seg, _) <- Map.toList (Branch._edits b) - ] - Cli.respond $ ListOfPatches $ Set.fromList patches - Cli.setNumberedArgs $ fmap (Text.unpack . Name.toText) patches FindShallowI pathArg -> do Cli.Env {codebase} <- ask pathArgAbs <- Cli.resolvePath' pathArg entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs) - Cli.setNumberedArgs $ fmap entryToHQString entries + Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries pped <- Cli.currentPrettyPrintEnvDecl let suffixifiedPPE = PPED.suffixifiedPPE pped -- This used to be a delayed action which only forced the loading of the root @@ -805,115 +705,9 @@ loop e = do -- in an improvement, so perhaps it's not worth the effort. let buildPPE = pure suffixifiedPPE Cli.respond $ ListShallow buildPPE entries - where - entryToHQString :: ShallowListEntry v Ann -> String - entryToHQString e = - fixup $ Text.unpack case e of - ShallowTypeEntry te -> Backend.typeEntryDisplayName te - ShallowTermEntry te -> Backend.termEntryDisplayName te - ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns - ShallowPatchEntry ns -> NameSegment.toEscapedText ns - where - fixup s = case pathArgStr of - "" -> s - p | last p == '.' -> p ++ s - p -> p ++ "." ++ s - pathArgStr = show pathArg FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input StructuredFindI _fscope ws -> handleStructuredFindI ws StructuredFindReplaceI ws -> handleStructuredFindReplaceI ws - ReplaceI from to patchPath -> do - Cli.Env {codebase} <- ask - hqLength <- Cli.runTransaction Codebase.hashLength - - let patchPath' = fromMaybe Cli.defaultPatchPath patchPath - patch <- Cli.getPatchAt patchPath' - QueryResult fromMisses' fromHits <- hqNameQuery Names.IncludeSuffixes [from] - QueryResult toMisses' toHits <- hqNameQuery Names.IncludeSuffixes [to] - let termsFromRefs = termReferences fromHits - termsToRefs = termReferences toHits - typesFromRefs = typeReferences fromHits - typesToRefs = typeReferences toHits - --- Here are all the kinds of misses - --- [X] [X] - --- [Type] [Term] - --- [Term] [Type] - --- [Type] [X] - --- [Term] [X] - --- [X] [Type] - --- [X] [Term] - -- Type hits are term misses - termFromMisses = fromMisses' <> (SR.typeName <$> typeResults fromHits) - termToMisses = toMisses' <> (SR.typeName <$> typeResults toHits) - -- Term hits are type misses - typeFromMisses = fromMisses' <> (SR.termName <$> termResults fromHits) - typeToMisses = toMisses' <> (SR.termName <$> termResults toHits) - - termMisses = termFromMisses <> termToMisses - typeMisses = typeFromMisses <> typeToMisses - - replaceTerms :: Reference -> Reference -> Cli () - replaceTerms fr tr = do - (mft, mtt) <- - Cli.runTransaction do - mft <- Codebase.getTypeOfTerm codebase fr - mtt <- Codebase.getTypeOfTerm codebase tr - pure (mft, mtt) - let termNotFound = - Cli.returnEarly - . TermNotFound' - . SH.shortenTo hqLength - . Reference.toShortHash - ft <- mft & onNothing (termNotFound fr) - tt <- mtt & onNothing (termNotFound tr) - let patch' = - -- The modified patch - over - Patch.termEdits - ( R.insert fr (Replace tr (TermEdit.typing tt ft)) - . R.deleteDom fr - ) - patch - (patchPath'', patchName) <- Cli.resolveSplit' patchPath' - saveAndApplyPatch (Path.convert patchPath'') patchName patch' - - replaceTypes :: Reference -> Reference -> Cli () - replaceTypes fr tr = do - let patch' = - -- The modified patch - over - Patch.typeEdits - (R.insert fr (TypeEdit.Replace tr) . R.deleteDom fr) - patch - (patchPath'', patchName) <- Cli.resolveSplit' patchPath' - saveAndApplyPatch (Path.convert patchPath'') patchName patch' - - ambiguous :: HQ.HashQualified Name -> [TermReference] -> Cli a - ambiguous t rs = - Cli.returnEarly case t of - HQ.HashOnly h -> HashAmbiguous h rs' - (Path.parseHQSplit' . Text.unpack . HQ.toText -> Right n) -> DeleteNameAmbiguous hqLength n rs' Set.empty - _ -> BadName (HQ.toText t) - where - rs' = Set.map Referent.Ref $ Set.fromList rs - - mismatch typeName termName = Cli.respond $ TypeTermMismatch typeName termName - - case (termsFromRefs, termsToRefs, typesFromRefs, typesToRefs) of - ([], [], [], []) -> Cli.respond $ SearchTermsNotFound termMisses - ([_], [], [], [_]) -> mismatch to from - ([], [_], [_], []) -> mismatch from to - ([_], [], _, _) -> Cli.respond $ SearchTermsNotFound termMisses - ([], [_], _, _) -> Cli.respond $ SearchTermsNotFound termMisses - (_, _, [_], []) -> Cli.respond $ SearchTermsNotFound typeMisses - (_, _, [], [_]) -> Cli.respond $ SearchTermsNotFound typeMisses - ([fr], [tr], [], []) -> replaceTerms fr tr - ([], [], [fr], [tr]) -> replaceTypes fr tr - (froms, [_], [], []) -> ambiguous from froms - ([], [], froms, [_]) -> ambiguous from froms - ([_], tos, [], []) -> ambiguous to tos - ([], [], [_], tos) -> ambiguous to tos - (_, _, _, _) -> error "unpossible" LoadI maybePath -> handleLoad maybePath ClearI -> Cli.respond ClearScreen AddI requestedNames -> do @@ -953,12 +747,6 @@ loop e = do branchPath <- Cli.resolvePath' branchPath' doShowTodoOutput patch branchPath TestI testInput -> Tests.handleTest testInput - PropagatePatchI patchPath scopePath' -> do - description <- inputDescription input - patch <- Cli.getPatchAt patchPath - scopePath <- Cli.resolvePath' scopePath' - updated <- propagatePatch description patch scopePath - when (not updated) (Cli.respond $ NothingToPatch patchPath scopePath') ExecuteI main args -> handleRun False main args MakeStandaloneI output main -> doCompile False output main CompileSchemeI output main -> @@ -1019,19 +807,15 @@ loop e = do _ <- Cli.updateAtM description destPath \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success - ListEditsI maybePath -> do - patch <- Cli.getPatchAt (fromMaybe Cli.defaultPatchPath maybePath) - pped <- Cli.currentPrettyPrintEnvDecl - let suffixifiedPPE = PPED.suffixifiedPPE pped - Cli.respondNumbered $ ListEdits patch suffixifiedPPE - PullRemoteBranchI sourceTarget pMode verbosity -> handlePull sourceTarget pMode verbosity + PullI sourceTarget pullMode -> handlePull sourceTarget pullMode PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput ListDependentsI hq -> handleDependents hq ListDependenciesI hq -> handleDependencies hq NamespaceDependenciesI path -> handleNamespaceDependencies path DebugNumberedArgsI -> do + schLength <- Cli.runTransaction Codebase.branchHashLength numArgs <- use #numberedArgs - Cli.respond (DumpNumberedArgs numArgs) + Cli.respond (DumpNumberedArgs schLength numArgs) DebugTypecheckedUnisonFileI -> do hqLength <- Cli.runTransaction Codebase.hashLength uf <- Cli.expectLatestTypecheckedFile @@ -1164,21 +948,12 @@ loop e = do nameChanges <- V2Branch.Diff.allNameChanges Nothing treeDiff pure (DisplayDebugNameDiff nameChanges) Cli.respond output - DeprecateTermI {} -> Cli.respond NotImplemented - DeprecateTypeI {} -> Cli.respond NotImplemented - RemoveTermReplacementI from patchPath -> doRemoveReplacement from patchPath True - RemoveTypeReplacementI from patchPath -> doRemoveReplacement from patchPath False - ShowDefinitionByPrefixI {} -> Cli.respond NotImplemented UpdateBuiltinsI -> Cli.respond NotImplemented QuitI -> Cli.haltRepl - GistI input -> handleGist input AuthLoginI -> void $ authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver) VersionI -> do Cli.Env {ucmVersion} <- ask Cli.respond $ PrintVersion ucmVersion - DiffNamespaceToPatchI diffNamespaceToPatchInput -> do - description <- inputDescription input - handleDiffNamespaceToPatch description diffNamespaceToPatchInput ProjectRenameI name -> handleProjectRename name ProjectSwitchI name -> projectSwitch name ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name @@ -1189,6 +964,7 @@ loop e = do CloneI remoteNames localNames -> handleClone remoteNames localNames ReleaseDraftI semver -> handleReleaseDraft semver UpgradeI old new -> handleUpgrade old new + UpgradeCommitI -> handleCommitUpgrade LibInstallI libdep -> handleInstallLib libdep inputDescription :: Input -> Cli Text @@ -1249,14 +1025,6 @@ inputDescription input = src <- p' src0 dest <- p' dest0 pure ("move " <> src <> " " <> dest) - MovePatchI src0 dest0 -> do - src <- ps' src0 - dest <- ps' dest0 - pure ("move.patch " <> src <> " " <> dest) - CopyPatchI src0 dest0 -> do - src <- ps' src0 - dest <- ps' dest0 - pure ("copy.patch " <> src <> " " <> dest) DeleteI dtarget -> do case dtarget of DeleteTarget'TermOrType DeleteOutput'NoDiff things0 -> do @@ -1278,25 +1046,13 @@ inputDescription input = thing <- traverse hqs' thing0 pure ("delete.type.verbose " <> Text.intercalate " " thing) DeleteTarget'Namespace Try opath0 -> do - opath <- ops' opath0 + opath <- ops opath0 pure ("delete.namespace " <> opath) DeleteTarget'Namespace Force opath0 -> do - opath <- ops' opath0 + opath <- ops opath0 pure ("delete.namespace.force " <> opath) - DeleteTarget'Patch path0 -> do - path <- ps' path0 - pure ("delete.patch " <> path) DeleteTarget'ProjectBranch _ -> wat DeleteTarget'Project _ -> wat - ReplaceI src target p0 -> do - p <- opatch p0 - pure $ - "replace " - <> HQ.toText src - <> " " - <> HQ.toText target - <> " " - <> p AddI _selection -> pure "add" UpdateI p0 _selection -> do p <- @@ -1306,12 +1062,8 @@ inputDescription input = UsePatch p0 -> (" " <>) <$> ps' p0 pure ("update.old" <> p) Update2I -> pure ("update") - PropagatePatchI p0 scope0 -> do - p <- ps' p0 - scope <- p' scope0 - pure ("patch " <> p <> " " <> scope) UndoI {} -> pure "undo" - ExecuteI s args -> pure ("execute " <> Text.unwords (s : fmap Text.pack args)) + ExecuteI s args -> pure ("execute " <> Text.unwords (HQ.toText s : fmap Text.pack args)) IOTestI hq -> pure ("io.test " <> HQ.toText hq) IOTestAllI -> pure "io.test.all" UpdateBuiltinsI -> pure "builtins.update" @@ -1321,20 +1073,9 @@ inputDescription input = MergeIOBuiltinsI (Just path) -> ("builtins.mergeio " <>) <$> p path MakeStandaloneI out nm -> pure ("compile " <> Text.pack out <> " " <> HQ.toText nm) ExecuteSchemeI nm args -> - pure $ "run.native " <> Text.unwords (nm : fmap Text.pack args) + pure $ "run.native " <> Text.unwords (HQ.toText nm : fmap Text.pack args) CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi) CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name) - RemoveTermReplacementI src p0 -> do - p <- opatch p0 - pure ("delete.term-replacement" <> HQ.toText src <> " " <> p) - RemoveTypeReplacementI src p0 -> do - p <- opatch p0 - pure ("delete.type-replacement" <> HQ.toText src <> " " <> p) - DiffNamespaceToPatchI input -> do - branchId1 <- hp' (input ^. #branchId1) - branchId2 <- hp' (input ^. #branchId2) - patch <- ps' (input ^. #patch) - pure (Text.unwords ["diff.namespace.to-patch", branchId1, branchId2, patch]) ClearI {} -> pure "clear" DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name) -- @@ -1361,23 +1102,18 @@ inputDescription input = DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input) DebugFormatI -> pure "debug.format" DebugTypecheckedUnisonFileI {} -> wat - DeprecateTermI {} -> wat - DeprecateTypeI {} -> wat DiffNamespaceI {} -> wat DisplayI {} -> wat DocsI {} -> wat DocsToHtmlI {} -> wat FindI {} -> wat - FindPatchI {} -> wat FindShallowI {} -> wat StructuredFindI {} -> wat StructuredFindReplaceI {} -> wat - GistI {} -> wat HistoryI {} -> wat LibInstallI {} -> wat ListDependenciesI {} -> wat ListDependentsI {} -> wat - ListEditsI {} -> wat LoadI {} -> wat MergeI {} -> wat NamesI {} -> wat @@ -1390,11 +1126,10 @@ inputDescription input = ProjectRenameI {} -> wat ProjectSwitchI {} -> wat ProjectsI -> wat - PullRemoteBranchI {} -> wat + PullI {} -> wat PushRemoteBranchI {} -> wat QuitI {} -> wat ReleaseDraftI {} -> wat - ShowDefinitionByPrefixI {} -> wat ShowDefinitionI {} -> wat EditNamespaceI paths -> pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths)) @@ -1405,6 +1140,7 @@ inputDescription input = UiI {} -> wat UpI {} -> wat UpgradeI {} -> wat + UpgradeCommitI {} -> wat VersionI -> wat where hp' :: Either SCH.ShortCausalHash Path' -> Cli Text @@ -1415,10 +1151,8 @@ inputDescription input = p' = fmap tShow . Cli.resolvePath' brp :: BranchRelativePath -> Cli Text brp = fmap from . ProjectUtils.resolveBranchRelativePath - ops' :: Maybe Path.Split' -> Cli Text - ops' = maybe (pure ".") ps' - opatch :: Maybe Path.Split' -> Cli Text - opatch = ps' . fromMaybe Cli.defaultPatchPath + ops :: Maybe Path.Split -> Cli Text + ops = maybe (pure ".") ps wat = error $ show input ++ " is not expected to alter the branch" hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text hhqs' = \case @@ -1430,6 +1164,7 @@ inputDescription input = pure (p <> "." <> HQ'.toTextWith NameSegment.toEscapedText hq) hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq) ps' = p' . Path.unsplit' + ps = p . Path.unsplit looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text looseCodeOrProjectToText = \case This path -> p' path @@ -1501,7 +1236,7 @@ handleFindI isVerbose fscope ws input = do (mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs) pure $ uniqueBy SR.toReferent srs let respondResults results = do - Cli.setNumberedArgs $ fmap (searchResultToHQString searchRoot) results + Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results' results <- getResults names @@ -1553,12 +1288,10 @@ handleDependencies hq = do let types = [(PPE.typeName suffixifiedPPE r, r) | LabeledDependency.TypeReference r <- toList dependencies] let terms = [(PPE.termName suffixifiedPPE r, r) | LabeledDependency.TermReferent r <- toList dependencies] pure (types, terms) - let types = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ fst <$> results) - let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results) - Cli.setNumberedArgs $ - map (Text.unpack . Reference.toText . snd) types - <> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms - Cli.respond $ ListDependencies suffixifiedPPE lds (fst <$> types) (fst <$> terms) + let types = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) . join $ fst <$> results + let terms = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) . join $ snd <$> results + Cli.setNumberedArgs . map SA.HashQualified $ types <> terms + Cli.respond $ ListDependencies suffixifiedPPE lds types terms handleDependents :: HQ.HashQualified Name -> Cli () handleDependents hq = do @@ -1575,7 +1308,7 @@ handleDependents hq = do results <- for (toList lds) \ld -> do -- The full set of dependent references, any number of which may not have names in the current namespace. dependents <- - let tp r = Codebase.dependents Queries.ExcludeOwnComponent r + let tp = Codebase.dependents Queries.ExcludeOwnComponent tm = \case Referent.Ref r -> Codebase.dependents Queries.ExcludeOwnComponent r Referent.Con (ConstructorReference r _cid) _ct -> @@ -1591,78 +1324,11 @@ handleDependents hq = do Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r pure (isTerm, HQ'.toHQ shortName, r) pure results - let sort = nubOrdOn snd . Name.sortByText (HQ.toText . fst) + let sort = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) let types = sort [(n, r) | (False, n, r) <- join results] let terms = sort [(n, r) | (True, n, r) <- join results] - Cli.setNumberedArgs $ map (Text.unpack . Reference.toText . view _2) (types <> terms) - Cli.respond (ListDependents ppe lds (fst <$> types) (fst <$> terms)) - -handleDiffNamespaceToPatch :: Text -> DiffNamespaceToPatchInput -> Cli () -handleDiffNamespaceToPatch description input = do - Cli.Env {codebase} <- ask - - absBranchId1 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId1) - absBranchId2 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId2) - - patch <- do - Cli.runTransactionWithRollback \rollback -> do - branch1 <- Cli.resolveAbsBranchIdV2 rollback absBranchId1 - branch2 <- Cli.resolveAbsBranchIdV2 rollback absBranchId2 - branchDiff <- V2Branch.Diff.diffBranches branch1 branch2 >>= V2Branch.Diff.nameBasedDiff - termEdits <- - (branchDiff ^. #terms) - & Relation.domain - & Map.toList - & traverse \(oldRef, newRefs) -> makeTermEdit codebase oldRef newRefs - pure - Patch - { _termEdits = - termEdits - & catMaybes - & Relation.fromList, - _typeEdits = - (branchDiff ^. #types) - & Relation.domain - & Map.toList - & mapMaybe (\(oldRef, newRefs) -> makeTypeEdit oldRef newRefs) - & Relation.fromList - } - - -- Display the patch that we are about to create. - suffixifiedPPE <- PPED.suffixifiedPPE <$> Cli.currentPrettyPrintEnvDecl - Cli.respondNumbered (ListEdits patch suffixifiedPPE) - - (patchPath, patchName) <- Cli.resolveSplit' (input ^. #patch) - - -- Add the patch to the in-memory root branch and flush it all to SQLite. - -- If there's already a patch at the given path, overwrite it. - Cli.stepAtM - description - (Path.unabsolute patchPath, Branch.modifyPatches patchName (const patch)) - where - -- Given {old reference} and {new references}, create term edit patch entries as follows: - -- - -- * If the {new references} is a singleton set {new reference}, proceed. (Otherwise, the patch we might create - -- would not be a function, which is a bogus/conflicted patch). - -- * Look up {old reference} and {new reference} types in the codebase (which can technically fail, due to - -- non-transactionality of this command, though we don't typically delete anything from SQLite), and create a - -- patch entry that maps {old reference} to {new reference} with the typing relationship. - makeTermEdit :: - Codebase m Symbol Ann -> - V2.Reference -> - Set V2.Reference -> - Sqlite.Transaction (Maybe (Reference, TermEdit)) - makeTermEdit codebase (Conversions.reference2to1 -> oldRef) newRefs = - runMaybeT do - newRef <- Conversions.reference2to1 <$> MaybeT (pure (Set.asSingleton newRefs)) - oldRefType <- MaybeT (Codebase.getTypeOfTerm codebase oldRef) - newRefType <- MaybeT (Codebase.getTypeOfTerm codebase newRef) - pure (oldRef, TermEdit.Replace newRef (TermEdit.typing oldRefType newRefType)) - - -- Same idea as 'makeTermEdit', but simpler, because there's nothing to look up in the database. - makeTypeEdit :: V2.Reference -> Set V2.Reference -> Maybe (Reference, TypeEdit) - makeTypeEdit (Conversions.reference2to1 -> oldRef) newRefs = - Set.asSingleton newRefs <&> \newRef -> (oldRef, TypeEdit.Replace (Conversions.reference2to1 newRef)) + Cli.setNumberedArgs . map SA.HashQualified $ types <> terms + Cli.respond (ListDependents ppe lds types terms) -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: OutputLocation -> ShowDefinitionScope -> NonEmpty (HQ.HashQualified Name) -> Cli () @@ -1774,10 +1440,9 @@ doShowTodoOutput patch scopePath = do if TO.noConflicts todo && TO.noEdits todo then Cli.respond NoConflictsOrEdits else do - Cli.setNumberedArgs - ( Text.unpack . Reference.toText . view _2 - <$> fst (TO.todoFrontierDependents todo) - ) + Cli.setNumberedArgs $ + SA.HashQualified . HQ.HashOnly . Reference.toShortHash . view _2 + <$> fst (TO.todoFrontierDependents todo) pped <- Cli.currentPrettyPrintEnvDecl Cli.respondNumbered $ TodoOutput pped todo @@ -1823,16 +1488,6 @@ confirmedCommand i = do loopState <- State.get pure $ Just i == (loopState ^. #lastInput) --- | restores the full hash to these search results, for _numberedArgs purposes -searchResultToHQString :: Maybe Path -> SearchResult -> String -searchResultToHQString oprefix = \case - SR.Tm' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify (addPrefix <$> n) r - SR.Tp' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify (addPrefix <$> n) (Referent.Ref r) - _ -> error "impossible match failure" - where - addPrefix :: Name -> Name - addPrefix = maybe id Path.prefixName2 oprefix - -- return `name` and `name....` _searchBranchPrefix :: Branch m -> Name -> [SearchResult] _searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of @@ -2105,7 +1760,7 @@ displayI outputLoc hq = do let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names doDisplay outputLoc ns tm -docsI :: Path.HQSplit' -> Cli () +docsI :: Name -> Cli () docsI src = do findInScratchfileByName where @@ -2113,14 +1768,8 @@ docsI src = do (fileByName) First check the file for `foo.doc`, and if found do `display foo.doc` (codebaseByName) Lastly check for `foo.doc` in the codebase and if found do `display foo.doc` -} - hq :: HQ.HashQualified Name - hq = - let hq' :: HQ'.HashQualified Name - hq' = Path.unsafeToName' <$> Name.convert src - in Name.convert hq' - dotDoc :: HQ.HashQualified Name - dotDoc = hq <&> \n -> Name.joinDot n (Name.fromSegment NameSegment.docSegment) + dotDoc = Name.convert . Name.joinDot src $ Name.fromSegment NameSegment.docSegment findInScratchfileByName :: Cli () findInScratchfileByName = do @@ -2210,15 +1859,6 @@ addWatch watchName (Just uf) = do ) _ -> addWatch watchName Nothing -hqNameQuery :: Names.SearchType -> [HQ.HashQualified Name] -> Cli QueryResult -hqNameQuery searchType query = do - Cli.Env {codebase} <- ask - names <- Cli.currentNames - Cli.runTransaction do - hqLength <- Codebase.hashLength - let nameSearch = NameSearch.makeNameSearch hqLength names - Backend.hqNameQuery codebase nameSearch searchType query - looseCodeOrProjectToPath :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path' looseCodeOrProjectToPath = \case Left pth -> pth diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 4e740830c..3ce5d167b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -120,11 +120,10 @@ doCreateBranch createFrom project newBranchName description = do Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId)) CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath CreateFrom'Nothingness -> pure Branch.empty - let projectId = project ^. #projectId let parentBranchId = case createFrom of CreateFrom'Branch (ProjectAndBranch _ sourceBranch) - | (sourceBranch ^. #projectId) == projectId -> Just (sourceBranch ^. #branchId) + | sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId _ -> Nothing doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs new file mode 100644 index 000000000..76229b8bf --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs @@ -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 diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs index b6865748f..0fa4291c6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs @@ -1,19 +1,21 @@ -- | @delete.branch@ input handler module Unison.Codebase.Editor.HandleInput.DeleteBranch ( handleDeleteBranch, + doDeleteProjectBranch, ) where -import Control.Lens (over, (^.)) +import Control.Lens (over) import Data.Map.Strict qualified as Map 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 Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path import Unison.Prelude 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 -- project. handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () -handleDeleteBranch projectAndBranchNames0 = do - projectAndBranchNames <- - ProjectUtils.hydrateNames - case projectAndBranchNames0 of +handleDeleteBranch projectAndBranchNamesToDelete = do + projectAndBranchToDelete <- + ProjectUtils.expectProjectAndBranchByTheseNames + case projectAndBranchNamesToDelete of ProjectAndBranch Nothing branch -> That branch ProjectAndBranch (Just project) branch -> These project branch maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch - deletedBranch <- - 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))) - ) + doDeleteProjectBranch projectAndBranchToDelete -- 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 -- 2. cd to "main", if it exists -- 3. cd to loose code path `.` - whenJust maybeCurrentBranch \(ProjectAndBranch _currentProject currentBranch, _restPath) -> - when (deletedBranch == currentBranch) do + whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) -> + when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do newPath <- - case deletedBranch ^. #parentBranchId of + case projectAndBranchToDelete.branch.parentBranchId of Nothing -> - Cli.runTransaction (Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main")) <&> \case - Nothing -> Path.Absolute Path.empty - Just mainBranch -> ProjectUtils.projectBranchPath (ProjectAndBranch projectId (mainBranch ^. #branchId)) - Just parentBranchId -> pure (ProjectUtils.projectBranchPath (ProjectAndBranch projectId parentBranchId)) + let loadMain = + Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main") + in Cli.runTransaction loadMain <&> \case + Nothing -> Path.Absolute Path.empty + Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch) + Just parentBranchId -> + pure $ + ProjectUtils.projectBranchPath + (ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId) Cli.cd newPath + +-- | 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)) + ) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs index 83cc5486e..45fb100a4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs @@ -18,6 +18,7 @@ import Unison.Cli.Pretty qualified as P import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Editor.Output +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) @@ -81,15 +82,14 @@ handleStructuredFindI rule = do Referent.Ref _ <- pure r Just shortName <- [PPE.terms (PPED.suffixifiedPPE ppe) r] pure (HQ'.toHQ shortName, r) - let ok t@(_, Referent.Ref (Reference.DerivedId r)) = do + let ok (hq, Referent.Ref (Reference.DerivedId r)) = do oe <- Cli.runTransaction (Codebase.getTerm codebase r) - pure $ (t, maybe False (\e -> any ($ e) rules) oe) - ok t = pure (t, False) + pure $ (hq, maybe False (\e -> any ($ e) rules) oe) + ok (hq, _) = pure (hq, False) results0 <- traverse ok results - let results = Alphabetical.sortAlphabeticallyOn fst [(hq, r) | ((hq, r), True) <- results0] - let toNumArgs = Text.unpack . Reference.toText . Referent.toReference . view _2 - Cli.setNumberedArgs $ map toNumArgs results - Cli.respond (ListStructuredFind (fst <$> results)) + let results = Alphabetical.sortAlphabetically [hq | (hq, True) <- results0] + Cli.setNumberedArgs $ map SA.HashQualified results + Cli.respond (ListStructuredFind results) lookupRewrite :: (HQ.HashQualified Name -> Output) -> diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index ee586d127..f43ffbb41 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs @@ -118,25 +118,22 @@ fresh bump taken x = makeDependencyName :: ProjectName -> ProjectBranchName -> NameSegment makeDependencyName projectName branchName = NameSegment.unsafeParseText $ - Text.intercalate "_" $ - fold - [ case projectNameToUserProjectSlugs projectName of - (user, project) -> - fold - [ if Text.null user then [] else [user], - [project] - ], - case classifyProjectBranchName branchName of - ProjectBranchNameKind'Contributor user branch -> [user, underscorify branch] - ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"] - ProjectBranchNameKind'Release ver -> semverSegments ver - ProjectBranchNameKind'NothingSpecial -> [underscorify branchName] - ] + Text.replace "-" "_" $ + Text.intercalate "_" $ + fold + [ case projectNameToUserProjectSlugs projectName of + (user, project) -> + fold + [ if Text.null user then [] else [user], + [project] + ], + case classifyProjectBranchName branchName of + ProjectBranchNameKind'Contributor user branch -> [user, into @Text branch] + ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"] + ProjectBranchNameKind'Release ver -> semverSegments ver + ProjectBranchNameKind'NothingSpecial -> [into @Text branchName] + ] where semverSegments :: Semver -> [Text] semverSegments (Semver x y z) = [tShow x, tShow y, tShow z] - - underscorify :: ProjectBranchName -> Text - underscorify = - Text.replace "-" "_" . into @Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index b15329c60..27108c191 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -1,5 +1,13 @@ module Unison.Codebase.Editor.HandleInput.Merge2 ( handleMerge, + + -- * API exported for @pull@ + MergeInfo (..), + AliceMergeInfo (..), + BobMergeInfo (..), + LcaMergeInfo (..), + doMerge, + doMergeLocalBranch, ) where @@ -12,9 +20,12 @@ import Data.Bitraversable (bitraverse) import Data.Foldable qualified as Foldable import Data.List qualified as List import Data.List.NonEmpty (pattern (:|)) +import Data.List.NonEmpty qualified as List.NonEmpty import Data.Map.Strict qualified as Map import Data.Semialign (align, unzip) 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.IO qualified as Text 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 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.Referent qualified as V2 (Referent) +import U.Codebase.Sqlite.DbId (ProjectId) import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Builtin.Decls qualified as Builtin.Decls +import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli -import Unison.Cli.ProjectUtils qualified as Cli +import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) @@ -47,8 +61,9 @@ import Unison.Codebase.Editor.HandleInput.Update2 prettyParseTypecheck2, typecheckedUnisonFileToBranchAdds, ) -import Unison.Codebase.Editor.Output (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.SqliteCodebase.Branch.Cache (newBranchCache) 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.Merge.CombineDiffs (CombinedDiffOp (..), combineDiffs) import Unison.Merge.Database (MergeDatabase (..), makeMergeDatabase, referent2to1) -import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency) +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency, lenientCheckDeclCoherency) import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames) import Unison.Merge.Diff qualified as Merge import Unison.Merge.DiffOp (DiffOp (..)) @@ -71,7 +86,6 @@ import Unison.Merge.EitherWayI (EitherWayI (..)) import Unison.Merge.EitherWayI qualified as EitherWayI import Unison.Merge.Libdeps qualified as Merge import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs) -import Unison.Merge.PreconditionViolation qualified as Merge import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.Synhashed qualified as Synhashed import Unison.Merge.ThreeWay (ThreeWay (..)) @@ -112,12 +126,12 @@ import Unison.Typechecker qualified as Typechecker import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap 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.Pretty (ColorText, Pretty) import Unison.Util.Pretty qualified as Pretty import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as Relation -import Unison.Util.Set qualified as Set import Unison.Util.Star2 (Star2) import Unison.Util.Star2 qualified as Star2 import Unison.Util.SyntaxText (SyntaxText') @@ -126,246 +140,329 @@ import Witch (unsafeFrom) import Prelude hiding (unzip, zip, zipWith) 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 = if Debug.shouldDebug Debug.Merge then realDebugFunctions 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 - -- Create a bunch of cached database lookup functions - db <- makeMergeDatabase codebase + 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 () - -- 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 + -- 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 () - -- Load Alice/Bob/LCA causals - causals <- + -- Create a bunch of cached database lookup functions + db <- makeMergeDatabase codebase + + -- Load Alice/Bob/LCA causals + causals <- Cli.runTransaction do + traverse + Operations.expectCausalBranchByCausalHash + TwoOrThreeWay + { alice = info.alice.causalHash, + bob = info.bob.causalHash, + lca = info.lca.causalHash + } + + liftIO (debugFunctions.debugCausals causals) + + -- Load Alice/Bob/LCA branches + branches <- + Cli.runTransaction do + alice <- causals.alice.value + bob <- causals.bob.value + lca <- for causals.lca \causal -> causal.value + pure TwoOrThreeWay {lca, alice, bob} + + -- Assert that neither Alice nor Bob have defns in lib + for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do + libdeps <- + case Map.lookup NameSegment.libSegment branch.children of + Nothing -> pure V2.Branch.empty + Just libdeps -> Cli.runTransaction libdeps.value + when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do + Cli.returnEarly (Output.MergeDefnsInLib who) + + -- Load Alice/Bob/LCA definitions and decl name lookups + (defns3, declNameLookups, lcaDeclToConstructors) <- do + let emptyNametree = Nametree {value = Defns Map.empty Map.empty, children = Map.empty} + let loadDefns branch = + Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName -> + Cli.returnEarly case conflictedName of + ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs + ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs + let load = \case + Nothing -> pure (emptyNametree, DeclNameLookup Map.empty Map.empty) + Just (who, branch) -> do + defns <- loadDefns branch + declNameLookup <- + Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> + Cli.returnEarly case err of + IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 -> + Output.MergeConstructorAlias who typeName conName1 conName2 + IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name + IncoherentDeclReason'NestedDeclAlias shorterName longerName -> + Output.MergeNestedDeclAlias who shorterName longerName + IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name + pure (defns, declNameLookup) + + (aliceDefns0, aliceDeclNameLookup) <- load (Just (mergeTarget, branches.alice)) + (bobDefns0, bobDeclNameLookup) <- load (Just (mergeSource, branches.bob)) + lcaDefns0 <- maybe (pure emptyNametree) loadDefns branches.lca + lcaDeclToConstructors <- Cli.runTransaction (lenientCheckDeclCoherency db.loadDeclNumConstructors lcaDefns0) + + let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) + let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} + let declNameLookups = TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup} + + pure (defns3, declNameLookups, lcaDeclToConstructors) + + let defns = ThreeWay.forgetLca defns3 + + liftIO (debugFunctions.debugDefns defns3 declNameLookups lcaDeclToConstructors) + + -- Diff LCA->Alice and LCA->Bob + diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns3) + + liftIO (debugFunctions.debugDiffs diffs) + + -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias + for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) -> + whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) -> + Cli.returnEarly (Output.MergeConflictedAliases who name1 name2) + + -- Combine the LCA->Alice and LCA->Bob diffs together + let diff = combineDiffs diffs + + liftIO (debugFunctions.debugCombinedDiff diff) + + -- Partition the combined diff into the conflicted things and the unconflicted things + (conflicts, unconflicts) <- + partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> + Cli.returnEarly (Output.MergeConflictInvolvingBuiltin name) + + liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) + + -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there + -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) + dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) + + liftIO (debugFunctions.debugDependents dependents) + + let stageOne :: DefnsF (Map Name) Referent TypeReference + stageOne = + makeStageOne + declNameLookups + conflicts + unconflicts + dependents + (bimap BiMultimap.range BiMultimap.range defns3.lca) + + liftIO (debugFunctions.debugStageOne stageOne) + + -- Load and merge Alice's and Bob's libdeps + mergedLibdeps <- + Cli.runTransaction do + libdeps <- loadLibdeps branches + libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) + + -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names + let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl + mkPpes defnsNames libdepsNames = + defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier + where + suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) + let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) + + hydratedThings <- do + Cli.runTransaction do + for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> + let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent + in (,) <$> hydrate conflicts1 <*> hydrate dependents1 + + let (renderedConflicts, renderedDependents) = + let honk declNameLookup ppe defns = + let (types, accessorNames) = + Writer.runWriter $ + defns.types & Map.traverseWithKey \name (ref, typ) -> + renderTypeBinding + -- Sort of a hack; since the decl printer looks in the PPE for names of constructors, + -- we just delete all term names out and add back the constructors... + -- probably no need to wipe out the suffixified side but we do it anyway + (setPpedToConstructorNames declNameLookup name ref ppe) + name + ref + typ + terms = + defns.terms & Map.mapMaybeWithKey \name (term, typ) -> + if Set.member name accessorNames + then Nothing + else Just (renderTermBinding ppe.suffixifiedPPE name term typ) + in Defns {terms, types} + in unzip $ + ( \declNameLookup (conflicts, dependents) ppe -> + let honk1 = honk declNameLookup ppe + in (honk1 conflicts, honk1 dependents) + ) + <$> declNameLookups + <*> hydratedThings + <*> ppes + + let prettyUnisonFile = + makePrettyUnisonFile + TwoWay + { alice = into @Text aliceBranchNames, + bob = + case info.bob.source of + MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames + MergeSource'RemoteProjectBranch bobBranchNames + | aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames + | otherwise -> into @Text bobBranchNames + MergeSource'RemoteLooseCode info -> + case Path.toName info.path of + Nothing -> "" + Just name -> Name.toText name + } + renderedConflicts + renderedDependents + + let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps + + maybeTypecheckedUnisonFile <- + let thisMergeHasConflicts = + -- Eh, they'd either both be null, or neither, but just check both maps anyway + not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) + in if thisMergeHasConflicts + then pure Nothing + else do + currentPath <- Cli.getCurrentPath + parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) + prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe + + let parents = + (\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals + + case maybeTypecheckedUnisonFile of + Nothing -> do + Cli.Env {writeSource} <- ask + _temporaryBranchId <- + HandleInput.Branch.doCreateBranch' + (Branch.mergeNode stageOneBranch parents.alice parents.bob) + Nothing + info.alice.projectAndBranch.project + (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) + info.description + scratchFilePath <- + Cli.getLatestFile <&> \case + Nothing -> "scratch.u" + Just (file, _) -> file + liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) + Cli.respond (Output.MergeFailure scratchFilePath mergeSourceAndTarget) + Just tuf -> do + Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) + let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch + _ <- + Cli.updateAt + info.description + alicePath + (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) + Cli.respond (Output.MergeSuccess mergeSourceAndTarget) + +doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli () +doMergeLocalBranch branches = do + (aliceCausalHash, bobCausalHash, lcaCausalHash) <- Cli.runTransaction do - alice <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute info.paths.alice) - bob <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute info.paths.bob) - lca <- - Operations.lca alice.causalHash bob.causalHash >>= \case - Nothing -> pure Nothing - Just lcaCausalHash -> Just <$> db.loadCausal lcaCausalHash - pure TwoOrThreeWay {lca, alice, bob} + 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) - -- 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) - - -- Load Alice/Bob/LCA branches - branches <- - Cli.runTransaction do - alice <- causals.alice.value - bob <- causals.bob.value - lca <- for causals.lca \causal -> causal.value - pure TwoOrThreeWay {lca, alice, bob} - - -- Load Alice/Bob/LCA definitions and decl name lookups - (defns3, declNameLookups3) <- - Cli.runTransactionWithRollback \abort -> do - loadDefns abort db (view #branch <$> info.branches) branches - let defns = ThreeWay.forgetLca defns3 - let declNameLookups = ThreeWay.forgetLca declNameLookups3 - - liftIO (debugFunctions.debugDefns defns3 declNameLookups3) - - -- Diff LCA->Alice and LCA->Bob - diffs <- - Cli.runTransaction do - Merge.nameBasedNamespaceDiff db declNameLookups3 defns3 - - liftIO (debugFunctions.debugDiffs diffs) - - -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias - whenJust (findOneConflictedAlias (view #branch <$> info.branches) defns3.lca diffs) \violation -> - Cli.returnEarly (mergePreconditionViolationToOutput violation) - - -- Combine the LCA->Alice and LCA->Bob diffs together - let diff = combineDiffs diffs - - liftIO (debugFunctions.debugCombinedDiff diff) - - -- Partition the combined diff into the conflicted things and the unconflicted things - (conflicts, unconflicts) <- - partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> - Cli.returnEarly (mergePreconditionViolationToOutput (Merge.ConflictInvolvingBuiltin name)) - - liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) - - -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there - -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) - dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) - - liftIO (debugFunctions.debugDependents dependents) - - let stageOne :: DefnsF (Map Name) Referent TypeReference - stageOne = - makeStageOne - declNameLookups - conflicts - unconflicts - dependents - (bimap BiMultimap.range BiMultimap.range defns3.lca) - - liftIO (debugFunctions.debugStageOne stageOne) - - -- Load and merge Alice's and Bob's libdeps - mergedLibdeps <- - Cli.runTransaction do - libdeps <- loadLibdeps branches - libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) - - -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names - let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl - mkPpes defnsNames libdepsNames = - defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier - where - suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) - let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) - - hydratedThings <- do - Cli.runTransaction do - for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> - let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent - in (,) <$> hydrate conflicts1 <*> hydrate dependents1 - - let (renderedConflicts, renderedDependents) = - let honk declNameLookup ppe defns = - let (types, accessorNames) = - Writer.runWriter $ - defns.types & Map.traverseWithKey \name (ref, typ) -> - renderTypeBinding - -- Sort of a hack; since the decl printer looks in the PPE for names of constructors, - -- we just delete all term names out and add back the constructors... - -- probably no need to wipe out the suffixified side but we do it anyway - (setPpedToConstructorNames declNameLookup name ref ppe) - name - ref - typ - terms = - defns.terms & Map.mapMaybeWithKey \name (term, typ) -> - if Set.member name accessorNames - then Nothing - else Just (renderTermBinding ppe.suffixifiedPPE name term typ) - in Defns {terms, types} - in unzip $ - ( \declNameLookup (conflicts, dependents) ppe -> - let honk1 = honk declNameLookup ppe - in (honk1 conflicts, honk1 dependents) - ) - <$> declNameLookups - <*> hydratedThings - <*> ppes - - let prettyUnisonFile = makePrettyUnisonFile (into @Text <$> projectAndBranchNames) renderedConflicts renderedDependents - - let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps - - maybeTypecheckedUnisonFile <- - let thisMergeHasConflicts = - -- Eh, they'd either both be null, or neither, but just check both maps anyway - not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) - in if thisMergeHasConflicts - then pure Nothing - else do - currentPath <- Cli.getCurrentPath - parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) - prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe - - case maybeTypecheckedUnisonFile of - Nothing -> do - Cli.Env {writeSource} <- ask - aliceBranch <- Cli.getBranchAt info.paths.alice - bobBranch <- Cli.getBranchAt info.paths.bob - _temporaryBranchId <- - HandleInput.Branch.doCreateBranch' - (Branch.mergeNode stageOneBranch aliceBranch bobBranch) - Nothing - info.branches.alice.project - (findTemporaryBranchName info) - (textualDescriptionOfMerge info) - scratchFilePath <- - Cli.getLatestFile <&> \case - Nothing -> "scratch.u" - Just (file, _) -> file - liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) - Cli.respond $ - Output.MergeFailure - scratchFilePath - projectAndBranchNames.alice - projectAndBranchNames.bob - Just tuf -> do - Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) - bobBranch <- Cli.getBranchAt info.paths.bob - let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch - _ <- - Cli.updateAt - (textualDescriptionOfMerge info) - info.paths.alice - (\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch) - Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob) + -- 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 -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 :: TwoOrThreeWay (V2.Branch Transaction) -> Transaction (ThreeWay (Map NameSegment (V2.CausalBranch Transaction))) @@ -502,13 +599,16 @@ makePrettyUnisonFile authors conflicts dependents = bob = prettyBinding (Just (Pretty.text authors.bob)) in bifoldMap f f ), - if TwoWay.or (not . defnsAreEmpty <$> dependents) - then - fold - [ "-- The definitions below are not conflicted, but they each depend on one or more\n", - "-- conflicted definitions above.\n\n" - ] - else mempty, + -- 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 + fold + [ "-- The definitions below are not conflicted, but they each depend on one or more\n", + "-- conflicted definitions above.\n\n" + ] + else mempty, dependents -- Merge dependents together into one map (they are disjoint) & TwoWay.twoWay (zipDefnsWith Map.union Map.union) @@ -622,17 +722,6 @@ nametreeToBranch0 nametree = rel2star rel = 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 identifyDependents :: TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> @@ -750,30 +839,39 @@ defnsToNames defns = types = Relation.fromMap (BiMultimap.range defns.types) } -findTemporaryBranchName :: MergeInfo -> Transaction ProjectBranchName -findTemporaryBranchName info = do - Cli.findTemporaryBranchName info.branches.alice.project.projectId preferred +findTemporaryBranchName :: ProjectId -> MergeSourceAndTarget -> Transaction ProjectBranchName +findTemporaryBranchName projectId mergeSourceAndTarget = do + ProjectUtils.findTemporaryBranchName projectId preferred where preferred :: ProjectBranchName preferred = unsafeFrom @Text $ - "merge-" - <> mangle info.branches.bob.branch.name - <> "-into-" - <> mangle info.branches.alice.branch.name + Text.Builder.run $ + "merge-" + <> mangleMergeSource mergeSourceAndTarget.bob + <> "-into-" + <> mangleBranchName mergeSourceAndTarget.alice.branch - mangle :: ProjectBranchName -> Text - mangle = - Text.Builder.run . mangleB - - mangleB :: ProjectBranchName -> Text.Builder - mangleB name = + mangleMergeSource :: MergeSource -> Text.Builder + mangleMergeSource = \case + MergeSource'LocalProjectBranch (ProjectAndBranch _project branch) -> mangleBranchName branch + MergeSource'RemoteProjectBranch (ProjectAndBranch _project branch) -> "remote-" <> mangleBranchName branch + MergeSource'RemoteLooseCode info -> manglePath info.path + mangleBranchName :: ProjectBranchName -> Text.Builder + mangleBranchName name = 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'Release semver -> "releases-" <> mangleSemver semver 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 x y z) = Text.Builder.decimal x @@ -782,141 +880,54 @@ findTemporaryBranchName info = do <> Text.Builder.char '.' <> Text.Builder.decimal z --- Load namespace info into memory. --- --- 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 +-- Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined -- in the "lib" namespace. -loadNamespaceInfo0 :: - (Monad m) => +-- +-- Fails if there is a conflicted name. +loadNamespaceDefinitions :: + forall m. + Monad m => (V2.Referent -> m Referent) -> 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 (Map.delete NameSegment.libSegment branch.children) \childCausal -> do - childBranch <- childCausal.value - loadNamespaceInfo0_ referent2to1 childBranch - pure Nametree {value = Defns {terms, types}, children} + m (Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference))) +loadNamespaceDefinitions referent2to1 = + fmap assertNamespaceHasNoConflictedNames . go (Map.delete NameSegment.libSegment) + where + go :: + (forall x. Map NameSegment x -> Map NameSegment x) -> + 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 <- + for (f branch.children) \childCausal -> do + child <- childCausal.value + go id child + pure Nametree {value = Defns {terms, types}, children} -loadNamespaceInfo0_ :: - (Monad m) => - (V2.Referent -> m Referent) -> - 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} +data ConflictedName + = ConflictedName'Term !Name !(NESet Referent) + | ConflictedName'Type !Name !(NESet TypeReference) -- | Assert that there are no unconflicted names in a namespace. assertNamespaceHasNoConflictedNames :: - Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference) -> - Either Merge.PreconditionViolation (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) + Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) -> + Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) assertNamespaceHasNoConflictedNames = traverseNametreeWithName \names defns -> do terms <- defns.terms & Map.traverseWithKey \name -> - assertUnconflicted (Merge.ConflictedTermName (Name.fromReverseSegments (name :| names))) + assertUnconflicted (ConflictedName'Term (Name.fromReverseSegments (name :| names))) types <- defns.types & Map.traverseWithKey \name -> - assertUnconflicted (Merge.ConflictedTypeName (Name.fromReverseSegments (name :| names))) + assertUnconflicted (ConflictedName'Type (Name.fromReverseSegments (name :| names))) pure Defns {terms, types} where - assertUnconflicted :: (Set ref -> Merge.PreconditionViolation) -> Set ref -> Either Merge.PreconditionViolation ref - assertUnconflicted conflicted refs = - case Set.asSingleton refs of - Nothing -> 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 + assertUnconflicted :: (NESet ref -> ConflictedName) -> NESet ref -> Either ConflictedName ref + assertUnconflicted conflicted refs + | Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs) + | otherwise = Left (conflicted refs) -- @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 @@ -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. findConflictedAlias :: - Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> - DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference -> + (Ord term, Ord typ) => + Defns (BiMultimap term Name) (BiMultimap typ Name) -> + DefnsF3 (Map Name) DiffOp Synhashed term typ -> Maybe (Name, Name) findConflictedAlias defns diff = asum [go defns.terms diff.terms, go defns.types diff.types] @@ -1022,7 +1034,8 @@ data DebugFunctions = DebugFunctions { debugCausals :: TwoOrThreeWay (V2.CausalBranch Transaction) -> IO (), debugDefns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - ThreeWay DeclNameLookup -> + TwoWay DeclNameLookup -> + Map Name [Maybe Name] -> IO (), debugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO (), debugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO (), @@ -1063,9 +1076,10 @@ realDebugCausals causals = do realDebugDefns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - ThreeWay DeclNameLookup -> + TwoWay DeclNameLookup -> + Map Name [Maybe Name] -> IO () -realDebugDefns defns declNameLookups = do +realDebugDefns defns declNameLookups _lcaDeclNameLookup = do Text.putStrLn (Text.bold "\n=== Alice definitions ===") debugDefns1 (bimap BiMultimap.range BiMultimap.range defns.alice) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs index 87329e00d..688ba5836 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs @@ -1,11 +1,13 @@ -- | @switch@ input handler module Unison.Codebase.Editor.HandleInput.ProjectSwitch ( projectSwitch, + switchToProjectBranch, ) where -import Control.Lens ((^.)) 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 Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -31,52 +33,47 @@ projectSwitch projectNames = do ProjectUtils.getCurrentProjectBranch >>= \case Nothing -> switchToProjectAndBranchByTheseNames (This projectName) Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do - let currentProjectName = currentProject ^. #name (projectExists, branchExists) <- Cli.runTransaction do (,) <$> Queries.projectExistsByName projectName - <*> Queries.projectBranchExistsByName (currentProject ^. #projectId) branchName + <*> Queries.projectBranchExistsByName currentProject.projectId branchName case (projectExists, branchExists) of (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, True) -> Cli.respondNumbered $ Output.AmbiguousSwitch projectName - (ProjectAndBranch currentProjectName branchName) + (ProjectAndBranch currentProject.name branchName) ProjectAndBranchNames'Unambiguous projectAndBranchNames0 -> switchToProjectAndBranchByTheseNames projectAndBranchNames0 switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli () switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do - branch <- case projectAndBranchNames0 of - This projectName -> - Cli.runTransactionWithRollback \rollback -> do - project <- - Queries.loadProjectByName projectName & onNothingM do - rollback (Output.LocalProjectDoesntExist projectName) - Queries.loadMostRecentBranch (project ^. #projectId) >>= \case - Nothing -> do - let branchName = unsafeFrom @Text "main" - branch <- - Queries.loadProjectBranchByName (project ^. #projectId) branchName & onNothingM do - rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) - setMostRecentBranch branch - Just branchId -> - Queries.loadProjectBranch (project ^. #projectId) branchId >>= \case - Nothing -> error "impossible" - Just branch -> pure branch - _ -> do - projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0 - Cli.runTransactionWithRollback \rollback -> do - branch <- + branch <- + case projectAndBranchNames0 of + This projectName -> + Cli.runTransactionWithRollback \rollback -> do + project <- + Queries.loadProjectByName projectName & onNothingM do + rollback (Output.LocalProjectDoesntExist projectName) + let branchName = unsafeFrom @Text "main" + Queries.loadProjectBranchByName project.projectId branchName & onNothingM do + rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) + _ -> do + projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0 + Cli.runTransactionWithRollback \rollback -> do Queries.loadProjectBranchByNames projectName branchName & onNothingM do rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) - setMostRecentBranch branch - Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId))) - where - setMostRecentBranch branch = do - Queries.setMostRecentBranch (branch ^. #projectId) (branch ^. #branchId) - pure branch + switchToProjectBranch (ProjectUtils.justTheIds' branch) + +-- | Switch to a branch: +-- +-- * Record it as the most-recent branch (so it's restored when ucm starts). +-- * 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) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index b67a03cf9..baaad634b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -7,14 +7,17 @@ module Unison.Codebase.Editor.HandleInput.Pull ) where -import Control.Lens ((^.)) import Control.Monad.Reader (ask) import Data.Text qualified as Text import Data.These -import U.Codebase.Sqlite.Project qualified as Sqlite (Project) -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch) +import U.Codebase.Branch qualified as V2.Branch +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 Unison.Cli.DownloadUtils +import Unison.Cli.MergeTypes (MergeSource (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad 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 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.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.Path (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.InputPatterns qualified as InputPatterns import Unison.NameSegment qualified as NameSegment @@ -45,75 +48,100 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName) import Witch (unsafeFrom) -handlePull :: PullSourceTarget -> PullMode -> Verbosity.Verbosity -> Cli () -handlePull unresolvedSourceAndTarget pullMode verbosity = do +handlePull :: PullSourceTarget -> PullMode -> Cli () +handlePull unresolvedSourceAndTarget pullMode = do let includeSquashed = case pullMode of Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead + (source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget - remoteBranchObject <- do - Cli.Env {codebase} <- ask - causalHash <- - case source of - ReadRemoteNamespaceGit repo -> do - downloadLooseCodeFromGitRepo - codebase - ( case pullMode of - Input.PullWithHistory -> GitNamespaceHistoryTreatment'LetAlone - Input.PullWithoutHistory -> GitNamespaceHistoryTreatment'DiscardAllHistory - ) - repo - & onLeftM (Cli.returnEarly . Output.GitError) - ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError) - ReadShare'ProjectBranch remoteBranch -> - downloadProjectBranchFromShare - ( case pullMode of - Input.PullWithHistory -> Share.NoSquashedHead - Input.PullWithoutHistory -> Share.IncludeSquashedHead - ) - remoteBranch - & onLeftM (Cli.returnEarly . Output.ShareError) - liftIO (Codebase.expectBranchForHash codebase causalHash) - when (Branch.isEmpty0 (Branch.head remoteBranchObject)) do - Cli.respond (PulledEmptyBranch source) - targetAbsolutePath <- - case target of - Left path -> Cli.resolvePath' path - Right (ProjectAndBranch project branch) -> - pure $ ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)) + + remoteCausalHash <- do + case source of + ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError) + ReadShare'ProjectBranch remoteBranch -> + downloadProjectBranchFromShare + ( case pullMode of + Input.PullWithHistory -> Share.NoSquashedHead + Input.PullWithoutHistory -> Share.IncludeSquashedHead + ) + remoteBranch + & onLeftM (Cli.returnEarly . Output.ShareError) + + remoteBranchIsEmpty <- + Cli.runTransaction do + causal <- Operations.expectCausalBranchByCausalHash remoteCausalHash + branch <- causal.value + V2.Branch.isEmpty branch + + when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source)) + + let targetAbsolutePath = + ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.branch.branchId) + let description = Text.unwords [ Text.pack . InputPattern.patternName $ case pullMode of PullWithoutHistory -> InputPatterns.pullWithoutHistory 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 - Left path -> Path.toText' path - Right (ProjectAndBranch project branch) -> into @Text (ProjectAndBranch (project ^. #name) (branch ^. #name)) + ProjectAndBranch project branch -> into @Text (ProjectAndBranch project.name branch.name) ] + case pullMode of Input.PullWithHistory -> do targetBranchObject <- Cli.getBranch0At targetAbsolutePath + if Branch.isEmpty0 targetBranchObject then do + Cli.Env {codebase} <- ask + remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject) Cli.respond $ MergeOverEmpty target else do Cli.respond AboutToMerge - mergeBranchAndPropagateDefaultPatch - Branch.RegularMerge - description - (Just (PullAlreadyUpToDate source target)) - remoteBranchObject - (if Verbosity.isSilent verbosity then Nothing else Just target) - targetAbsolutePath + + 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 + } Input.PullWithoutHistory -> do + Cli.Env {codebase} <- ask + remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) + didUpdate <- Cli.updateAtM description targetAbsolutePath (\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject) + Cli.respond if didUpdate then PullSuccessful source target @@ -124,13 +152,19 @@ resolveSourceAndTarget :: PullSourceTarget -> Cli ( ReadRemoteNamespace Share.RemoteProjectBranch, - Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) + ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch ) resolveSourceAndTarget includeSquashed = \case Input.PullSourceTarget0 -> liftA2 (,) (resolveImplicitSource includeSquashed) resolveImplicitTarget Input.PullSourceTarget1 source -> liftA2 (,) (resolveExplicitSource includeSquashed source) resolveImplicitTarget 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 includeSquashed = @@ -139,8 +173,8 @@ resolveImplicitSource includeSquashed = Just (localProjectAndBranch, _restPath) -> do (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <- Cli.runTransactionWithRollback \rollback -> do - let localProjectId = localProjectAndBranch ^. #project . #projectId - let localBranchId = localProjectAndBranch ^. #branch . #branchId + let localProjectId = localProjectAndBranch.project.projectId + let localBranchId = localProjectAndBranch.branch.branchId Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case Just (remoteProjectId, Just remoteBranchId) -> do remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri @@ -163,11 +197,10 @@ resolveExplicitSource :: ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) resolveExplicitSource includeSquashed = \case - ReadRemoteNamespaceGit namespace -> pure (ReadRemoteNamespaceGit namespace) ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace) ReadShare'ProjectBranch (This remoteProjectName) -> do remoteProject <- ProjectUtils.expectRemoteProjectByName remoteProjectName - let remoteProjectId = remoteProject ^. #projectId + let remoteProjectId = remoteProject.projectId let remoteBranchName = unsafeFrom @Text "main" remoteProjectBranch <- ProjectUtils.expectRemoteProjectBranchByName @@ -175,9 +208,9 @@ resolveExplicitSource includeSquashed = \case (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) pure (ReadShare'ProjectBranch remoteProjectBranch) ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do - (ProjectAndBranch localProject localBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch - let localProjectId = localProject ^. #projectId - let localBranchId = localBranch ^. #branchId + (localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch + let localProjectId = localProjectAndBranch.project.projectId + let localBranchId = localProjectAndBranch.branch.branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case Just (remoteProjectId, _maybeProjectBranchId) -> do remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri) @@ -194,12 +227,10 @@ resolveExplicitSource includeSquashed = \case pure (ReadShare'ProjectBranch remoteProjectBranch) Nothing -> do Cli.returnEarly $ - Output.NoAssociatedRemoteProject - Share.hardCodedUri - (ProjectAndBranch (localProject ^. #name) (localBranch ^. #name)) + Output.NoAssociatedRemoteProject Share.hardCodedUri (ProjectUtils.justTheNames localProjectAndBranch) ReadShare'ProjectBranch (These projectName branchNameOrLatestRelease) -> do remoteProject <- ProjectUtils.expectRemoteProjectByName projectName - let remoteProjectId = remoteProject ^. #projectId + let remoteProjectId = remoteProject.projectId branchName <- case branchNameOrLatestRelease of ProjectBranchNameOrLatestRelease'Name name -> pure name @@ -210,11 +241,10 @@ resolveExplicitSource includeSquashed = \case (ProjectAndBranch (remoteProjectId, projectName) branchName) pure (ReadShare'ProjectBranch remoteProjectBranch) -resolveImplicitTarget :: Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -resolveImplicitTarget = - ProjectUtils.getCurrentProjectBranch <&> \case - Nothing -> Left Path.currentPath - Just (projectAndBranch, _restPath) -> Right projectAndBranch +resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveImplicitTarget = do + (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + pure projectAndBranch -- | supply `dest0` if you want to print diff messages -- supply unchangedMessage if you want to display it if merge had no effect diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index 99e1fce08..efd747451 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs @@ -1,13 +1,11 @@ -- | @push@ input handler module Unison.Codebase.Editor.HandleInput.Push - ( handleGist, - handlePushRemoteBranch, + ( handlePushRemoteBranch, ) where import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO) import Control.Lens (over, view, (.~), (^.), _1, _2) -import Control.Monad.Reader (ask) import Data.Set.NonEmpty qualified as Set.NonEmpty import Data.Text as Text import Data.These (These (..)) @@ -26,13 +24,9 @@ import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.Share.Projects qualified as Share import Unison.Cli.UnisonConfigUtils qualified as UnisonConfigUtils -import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch (Branch (..)) -import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.HandleInput.AuthLogin qualified as AuthLogin import Unison.Codebase.Editor.Input - ( GistInput (..), - PushRemoteBranchInput (..), + ( PushRemoteBranchInput (..), PushSource (..), PushSourceTarget (..), ) @@ -40,20 +34,13 @@ import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Output.PushPull (PushPull (Push)) import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace (..), - ReadRemoteNamespace (..), - WriteGitRemoteNamespace (..), - WriteRemoteNamespace (..), + ( WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), - writeToReadGit, ) import Unison.Codebase.Path qualified as Path import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.PushBehavior qualified as PushBehavior -import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.Codebase.Type (GitPushBehavior (..)) import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName)) -import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) import Unison.Hash32 qualified as Hash32 import Unison.Prelude @@ -75,25 +62,6 @@ import Unison.Sqlite qualified as Sqlite import Unison.Sync.Types qualified as Share import Witch (unsafeFrom) --- | Handle a @gist@ command. -handleGist :: GistInput -> Cli () -handleGist (GistInput repo) = do - Cli.Env {codebase} <- ask - sourceBranch <- Cli.getCurrentBranch - result <- - Cli.ioE (Codebase.pushGitBranch codebase repo GitPushBehaviorGist (\_remoteRoot -> pure (Right sourceBranch))) \err -> - Cli.returnEarly (Output.GitError err) - _branch <- result & onLeft Cli.returnEarly - schLength <- Cli.runTransaction Codebase.branchHashLength - Cli.respond $ - GistCreated $ - ReadRemoteNamespaceGit - ReadGitRemoteNamespace - { repo = writeToReadGit repo, - sch = Just (SCH.fromHash schLength (Branch.headHash sourceBranch)), - path = Path.empty - } - -- | Handle a @push@ command. handlePushRemoteBranch :: PushRemoteBranchInput -> Cli () handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do @@ -104,7 +72,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do Nothing -> do localPath <- Cli.getCurrentPath UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case - WriteRemoteNamespaceGit namespace -> pushLooseCodeToGitLooseCode localPath namespace pushBehavior WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior WriteRemoteProjectBranch v -> absurd v Just (localProjectAndBranch, _restPath) -> @@ -112,10 +79,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do force localProjectAndBranch Nothing - -- push to .some.path (git) - PushSourceTarget1 (WriteRemoteNamespaceGit namespace) -> do - localPath <- Cli.getCurrentPath - pushLooseCodeToGitLooseCode localPath namespace pushBehavior -- push to .some.path (share) PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do localPath <- Cli.getCurrentPath @@ -129,10 +92,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch Just (localProjectAndBranch, _restPath) -> pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) - -- push .some.path to .some.path (git) - PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceGit namespace) -> do - localPath <- Cli.resolvePath' localPath0 - pushLooseCodeToGitLooseCode localPath namespace pushBehavior -- push .some.path to .some.path (share) PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do localPath <- Cli.resolvePath' localPath0 @@ -142,13 +101,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do localPath <- Cli.resolvePath' localPath0 remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0 pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch - -- push @some/project to .some.path (git) - PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceGit namespace) -> do - ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 - pushLooseCodeToGitLooseCode - (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) - namespace - pushBehavior -- push @some/project to .some.path (share) PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 @@ -167,49 +119,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do PushBehavior.RequireEmpty -> False PushBehavior.RequireNonEmpty -> False --- Push a local namespace ("loose code") to a Git-hosted remote namespace ("loose code"). -pushLooseCodeToGitLooseCode :: Path.Absolute -> WriteGitRemoteNamespace -> PushBehavior -> Cli () -pushLooseCodeToGitLooseCode localPath gitRemotePath pushBehavior = do - sourceBranch <- Cli.getBranchAt localPath - let withRemoteRoot :: Branch IO -> Either Output (Branch IO) - withRemoteRoot remoteRoot = do - let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if - -- this rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` - -- already. - f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing - case Branch.modifyAtM (gitRemotePath ^. #path) f remoteRoot of - Nothing -> Left (RefusedToPush pushBehavior (WriteRemoteNamespaceGit gitRemotePath)) - Just newRemoteRoot -> Right newRemoteRoot - let behavior = - case pushBehavior of - PushBehavior.ForcePush -> GitPushBehaviorForce - PushBehavior.RequireEmpty -> GitPushBehaviorFf - PushBehavior.RequireNonEmpty -> GitPushBehaviorFf - Cli.Env {codebase} <- ask - let push = - Codebase.pushGitBranch - codebase - (gitRemotePath ^. #repo) - behavior - (\remoteRoot -> pure (withRemoteRoot remoteRoot)) - result <- - liftIO push & onLeftM \err -> - Cli.returnEarly (Output.GitError err) - _branch <- result & onLeft Cli.returnEarly - Cli.respond Success - where - -- Per `pushBehavior`, we are either: - -- - -- (1) force-pushing, in which case the remote branch state doesn't matter - -- (2) updating an empty branch, which fails if the branch isn't empty (`push.create`) - -- (3) updating a non-empty branch, which fails if the branch is empty (`push`) - shouldPushTo :: PushBehavior -> Branch m -> Bool - shouldPushTo pushBehavior remoteBranch = - case pushBehavior of - PushBehavior.ForcePush -> True - PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) - PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) - -- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code"). pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli () pushLooseCodeToShareLooseCode _ _ _ = do @@ -649,10 +558,11 @@ makeSetHeadAfterUploadAction :: Share.RemoteProjectBranch -> Cli AfterUploadAction makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do - let remoteProjectAndBranchNames = ProjectAndBranch (remoteBranch ^. #projectName) (remoteBranch ^. #branchName) + let remoteProjectAndBranchNames = ProjectAndBranch remoteBranch.projectName remoteBranch.branchName - when (localBranchHead == Share.API.hashJWTHash (remoteBranch ^. #branchHead)) do - Cli.returnEarly (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames) + when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do + Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames) + Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName))) when (not force) do whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs index 5bbc11907..d2c6ed7aa 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs @@ -20,6 +20,8 @@ import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.MainTerm qualified as MainTerm import Unison.Codebase.Runtime qualified as Runtime import Unison.Hash qualified as Hash +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) import Unison.Parser.Ann (Ann (External)) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE @@ -40,7 +42,7 @@ import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF import Unison.Var qualified as Var -handleRun :: Bool -> Text -> [String] -> Cli () +handleRun :: Bool -> HQ.HashQualified Name -> [String] -> Cli () handleRun native main args = do (unisonFile, mainResType) <- do (sym, term, typ, otyp) <- getTerm main @@ -75,7 +77,7 @@ data GetTermResult -- | Look up runnable term with the given name in the codebase or -- latest typechecked unison file. Return its symbol, term, type, and -- the type of the evaluated term. -getTerm :: Text -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann) +getTerm :: HQ.HashQualified Name -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann) getTerm main = getTerm' main >>= \case NoTermWithThatName -> do @@ -90,7 +92,7 @@ getTerm main = Cli.returnEarly $ Output.BadMainFunction "run" main ty suffixifiedPPE [mainType] GetTermSuccess x -> pure x -getTerm' :: Text -> Cli GetTermResult +getTerm' :: HQ.HashQualified Name -> Cli GetTermResult getTerm' mainName = let getFromCodebase = do Cli.Env {codebase, runtime} <- ask @@ -99,7 +101,6 @@ getTerm' mainName = mainToFile =<< MainTerm.getMainTerm loadTypeOfTerm names mainName (Runtime.mainType runtime) where - mainToFile (MainTerm.NotAFunctionName _) = pure NoTermWithThatName mainToFile (MainTerm.NotFound _) = pure NoTermWithThatName mainToFile (MainTerm.BadType _ ty) = pure $ maybe NoTermWithThatName TermHasBadType ty mainToFile (MainTerm.Success hq tm typ) = @@ -108,7 +109,8 @@ getTerm' mainName = pure (GetTermSuccess (v, tm, typ, otyp)) getFromFile uf = do let components = join $ UF.topLevelComponents uf - let mainComponent = filter ((\v -> Var.name v == mainName) . view _1) components + -- __TODO__: We shouldn’t need to serialize mainName` for this check + let mainComponent = filter ((\v -> Var.name v == HQ.toText mainName) . view _1) components case mainComponent of [(v, _, tm, ty)] -> checkType ty \otyp -> diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs index 7e12e623e..bb6dddabd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs @@ -31,7 +31,6 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference (Reference) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Type (Type) import Unison.Typechecker qualified as Typechecker @@ -118,9 +117,8 @@ resolveMainRef main = do pped <- Cli.prettyPrintEnvDeclFromNames names let suffixifiedPPE = PPED.suffixifiedPPE pped let mainType = Runtime.mainType runtime - smain = HQ.toText main lookupTermRefWithType codebase main >>= \case [(rf, ty)] | Typechecker.fitsScheme ty mainType -> pure (rf, suffixifiedPPE) - | otherwise -> Cli.returnEarly (BadMainFunction "main" smain ty suffixifiedPPE [mainType]) - _ -> Cli.returnEarly (NoMainFunction smain suffixifiedPPE [mainType]) + | otherwise -> Cli.returnEarly (BadMainFunction "main" main ty suffixifiedPPE [mainType]) + _ -> Cli.returnEarly (NoMainFunction main suffixifiedPPE [mainType]) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs index 901a0b3e2..3eb365800 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs @@ -28,6 +28,8 @@ import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils import Unison.Codebase.Editor.Input (TestInput (..)) import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output +import Unison.Codebase.Path (Path) +import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime qualified as Runtime import Unison.ConstructorReference (GConstructorReference (..)) import Unison.HashQualified qualified as HQ @@ -38,6 +40,7 @@ import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.Reference (TermReferenceId) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.ShortHash qualified as SH @@ -53,9 +56,6 @@ import Unison.Util.Monoid (foldMapM) import Unison.Util.Relation qualified as R import Unison.Util.Set qualified as Set import Unison.WatchKind qualified as WK -import Unison.Codebase.Path (Path) -import Unison.Reference (TermReferenceId) -import qualified Unison.Codebase.Path as Path -- | Handle a @test@ command. -- Run pure tests in the current subnamespace. @@ -137,7 +137,7 @@ handleIOTest main = do (fails, oks) <- refs & foldMapM \(ref, typ) -> do when (not $ isIOTest typ) do - Cli.returnEarly (BadMainFunction "io.test" (HQ.toText main) typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime)) + Cli.returnEarly (BadMainFunction "io.test" main typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime)) runIOTest suffixifiedPPE ref Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index 4ea023456..aab5144e1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -10,6 +10,7 @@ import Data.List.NonEmpty (pattern (:|)) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text +import Text.Builder qualified import U.Codebase.Sqlite.DbId (ProjectId) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -169,8 +170,7 @@ handleUpgrade oldName newName = do Nothing -> "scratch.u" Just (file, _) -> file liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) - Cli.respond (Output.UpgradeFailure scratchFilePath oldName newName) - Cli.returnEarlyWithoutOutput + Cli.returnEarly (Output.UpgradeFailure scratchFilePath oldName newName) branchUpdates <- Cli.runTransactionWithRollback \abort -> do @@ -267,12 +267,25 @@ makeOldDepPPE oldName newName currentDeepNamesSansOld oldDeepNames oldLocalNames -- like "upgrade--to-". findTemporaryBranchName :: ProjectId -> NameSegment -> NameSegment -> Transaction ProjectBranchName 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 - preferred :: ProjectBranchName - preferred = - unsafeFrom @Text $ - "upgrade-" - <> Text.filter Char.isAlpha (NameSegment.toEscapedText oldDepName) - <> "-to-" - <> Text.filter Char.isAlpha (NameSegment.toEscapedText newDepName) + mk :: Text -> Text -> Text + mk old new = + Text.Builder.run ("upgrade-" <> Text.Builder.text old <> "-to-" <> Text.Builder.text new) + + scrub :: Text -> Text + scrub = + Text.filter Char.isAlphaNum + + oldDepText = NameSegment.toEscapedText oldDepName + newDepText = NameSegment.toEscapedText newDepName diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 715444fa4..36fc59a03 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -1,8 +1,6 @@ module Unison.Codebase.Editor.Input ( Input (..), BranchSourceI (..), - DiffNamespaceToPatchInput (..), - GistInput (..), PullSourceTarget (..), PushRemoteBranchInput (..), PushSourceTarget (..), @@ -32,16 +30,14 @@ where import Data.List.NonEmpty (NonEmpty) import Data.Text qualified as Text import Data.These (These) -import U.Codebase.HashTags (CausalHash) import Unison.Codebase.Branch.Merge qualified as Branch -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace) import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.Codebase.Verbosity (Verbosity) import Unison.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath) import Unison.HashQualified qualified as HQ import Unison.Name (Name) @@ -53,7 +49,6 @@ import Unison.Util.Pretty qualified as P data Event = UnisonFileChanged SourceName Source - | IncomingRootBranch (Set CausalHash) deriving stock (Show) type Source = Text -- "id x = x\nconst a b = a" @@ -114,7 +109,7 @@ data Input MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode | PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject | DiffNamespaceI BranchId BranchId -- old new - | PullRemoteBranchI PullSourceTarget PullMode Verbosity + | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput | ResetRootI (Either ShortCausalHash Path') | ResetI @@ -145,8 +140,6 @@ data Input MoveTermI Path.HQSplit' Path.Split' | MoveTypeI Path.HQSplit' Path.Split' | MoveBranchI Path.Path' Path.Path' - | MovePatchI Path.Split' Path.Split' - | CopyPatchI Path.Split' Path.Split' | -- delete = unname DeleteI DeleteTarget | -- edits stuff: @@ -158,20 +151,12 @@ data Input | Update2I | PreviewUpdateI (Set Name) | TodoI (Maybe PatchPath) Path' - | PropagatePatchI PatchPath Path' - | ListEditsI (Maybe PatchPath) - | -- -- create and remove update directives - DeprecateTermI PatchPath Path.HQSplit' - | DeprecateTypeI PatchPath Path.HQSplit' - | ReplaceI (HQ.HashQualified Name) (HQ.HashQualified Name) (Maybe PatchPath) - | RemoveTermReplacementI (HQ.HashQualified Name) (Maybe PatchPath) - | RemoveTypeReplacementI (HQ.HashQualified Name) (Maybe PatchPath) | UndoI | -- First `Maybe Int` is cap on number of results, if any -- Second `Maybe Int` is cap on diff elements shown, if any HistoryI (Maybe Int) (Maybe Int) BranchId | -- execute an IO thunk with args - ExecuteI Text [String] + ExecuteI (HQ.HashQualified Name) [String] | -- save the result of a previous Execute SaveExecuteResultI Name | -- execute an IO [Result] @@ -181,7 +166,7 @@ data Input | -- make a standalone binary file MakeStandaloneI String (HQ.HashQualified Name) | -- execute an IO thunk using scheme - ExecuteSchemeI Text [String] + ExecuteSchemeI (HQ.HashQualified Name) [String] | -- compile to a scheme file CompileSchemeI Text (HQ.HashQualified Name) | TestI TestInput @@ -189,16 +174,14 @@ data Input | -- Display provided definitions. DisplayI OutputLocation (NonEmpty (HQ.HashQualified Name)) | -- Display docs for provided terms. - DocsI (NonEmpty Path.HQSplit') + DocsI (NonEmpty Name) | -- other FindI Bool FindScope [String] -- FindI isVerbose findScope query | FindShallowI Path' - | FindPatchI | StructuredFindI FindScope (HQ.HashQualified Name) -- sfind findScope query | StructuredFindReplaceI (HQ.HashQualified Name) -- sfind.replace rewriteQuery | -- Show provided definitions. ShowDefinitionI OutputLocation ShowDefinitionScope (NonEmpty (HQ.HashQualified Name)) - | ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified Name] | ShowReflogI | UpdateBuiltinsI | MergeBuiltinsI (Maybe Path) @@ -226,10 +209,8 @@ data Input | UiI Path' | DocToMarkdownI Name | DocsToHtmlI Path' FilePath - | GistI GistInput | AuthLoginI | VersionI - | DiffNamespaceToPatchI DiffNamespaceToPatchInput | ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName) | ProjectRenameI ProjectName | ProjectSwitchI ProjectAndBranchNames @@ -244,6 +225,7 @@ data Input | -- New merge algorithm: merge the given project branch into the current one. MergeI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | LibInstallI !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) + | UpgradeCommitI deriving (Eq, Show) -- | The source of a `branch` command: what to make the new branch from. @@ -256,27 +238,11 @@ data BranchSourceI BranchSourceI'LooseCodeOrProject LooseCodeOrProject deriving stock (Eq, Show) -data DiffNamespaceToPatchInput = DiffNamespaceToPatchInput - { -- The first/earlier namespace. - branchId1 :: BranchId, - -- The second/later namespace. - branchId2 :: BranchId, - -- Where to store the patch that corresponds to the diff between the namespaces. - patch :: Path.Split' - } - deriving stock (Eq, Generic, Show) - --- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@. -data GistInput = GistInput - { repo :: WriteGitRepo - } - deriving stock (Eq, Show) - -- | Pull source and target: either neither is specified, or only a source, or both. data PullSourceTarget = PullSourceTarget0 | PullSourceTarget1 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) - | PullSourceTarget2 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) LooseCodeOrProject + | PullSourceTarget2 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) deriving stock (Eq, Show) data PushSource @@ -335,8 +301,7 @@ data DeleteTarget = DeleteTarget'TermOrType DeleteOutput [Path.HQSplit'] | DeleteTarget'Term DeleteOutput [Path.HQSplit'] | DeleteTarget'Type DeleteOutput [Path.HQSplit'] - | DeleteTarget'Namespace Insistence (Maybe Path.Split') - | DeleteTarget'Patch Path.Split' + | DeleteTarget'Namespace Insistence (Maybe Path.Split) | DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | DeleteTarget'Project ProjectName deriving stock (Eq, Show) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index baeca055e..397813e83 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -17,7 +17,6 @@ module Unison.Codebase.Editor.Output where import Data.List.NonEmpty (NonEmpty) -import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Time (UTCTime) import Network.URI (URI) @@ -28,6 +27,7 @@ import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import Unison.Auth.Types (CredentialFailure) +import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.Input 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.SlurpResult (SlurpResult (..)) import Unison.Codebase.Editor.SlurpResult qualified as SR +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) -import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.Codebase.Type (GitError) import Unison.CommandLine.InputPattern qualified as Input import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.ConstructorId (ConstructorId) @@ -62,7 +61,7 @@ import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE 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.Referent (Referent) import Unison.Server.Backend (ShallowListEntry (..)) @@ -84,7 +83,12 @@ type ListDetailed = Bool type SourceName = Text -type NumberedArgs = [String] +-- | +-- +-- __NB__: This only temporarily holds `Text`. Until all of the inputs are +-- updated to handle `StructuredArgument`s, we need to ensure that the +-- serialization remains unchanged. +type NumberedArgs = [StructuredArgument] type HashLength = Int @@ -127,7 +131,6 @@ data NumberedOutput HashLength [(CausalHash, Names.Diff)] HistoryTail -- 'origin point' of this view of history. - | ListEdits Patch PPE.PrettyPrintEnv | ListProjects [Sqlite.Project] | ListBranches ProjectName [(ProjectBranchName, [(URI, ProjectName, ProjectBranchName)])] | AmbiguousSwitch ProjectName (ProjectAndBranch ProjectName ProjectBranchName) @@ -154,13 +157,13 @@ data Output | InvalidSourceName String | SourceLoadFailed String | -- No main function, the [Type v Ann] are the allowed types - NoMainFunction Text PPE.PrettyPrintEnv [Type Symbol Ann] + NoMainFunction (HQ.HashQualified Name) PPE.PrettyPrintEnv [Type Symbol Ann] | -- | Function found, but has improper type -- Note: the constructor name is misleading here; we weren't necessarily looking for a "main". BadMainFunction Text -- ^ what we were trying to do (e.g. "run", "io.test") - Text + (HQ.HashQualified Name) -- ^ name of function (Type Symbol Ann) -- ^ bad type of function @@ -172,7 +175,6 @@ data Output | CreatedNewBranch Path.Absolute | BranchAlreadyExists Path' | FindNoLocalMatches - | PatchAlreadyExists Path.Split' | NoExactTypeMatches | TypeAlreadyExists Path.Split' (Set Reference) | TypeParseError String (Parser.Err Symbol) @@ -191,13 +193,11 @@ data Output | EmptyProjectBranchPush (ProjectAndBranch ProjectName ProjectBranchName) | NameNotFound Path.HQSplit' | NamesNotFound [Name] - | PatchNotFound Path.Split' | TypeNotFound Path.HQSplit' | TermNotFound Path.HQSplit' | MoveNothingFound Path' | TypeNotFound' ShortHash | TermNotFound' ShortHash - | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name) | NoLastRunResult | SaveTermNameConflict Name | SearchTermsNotFound [HQ.HashQualified Name] @@ -230,7 +230,6 @@ data Output -- list of all the definitions within this branch | ListOfDefinitions FindScope PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann] | ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann] - | ListOfPatches (Set Name) | ListStructuredFind [HQ.HashQualified Name] | -- ListStructuredFind patternMatchingUsages termBodyUsages -- show the result of add/update @@ -267,32 +266,30 @@ data Output -- todo: eventually replace these sets with [SearchResult' v Ann] -- and a nicer render. BustedBuiltins (Set Reference) (Set Reference) - | GitError GitError | ShareError ShareError | ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName)) | NoConfiguredRemoteMapping PushPull Path.Absolute | ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String | TermMissingType Reference | AboutToPropagatePatch - | -- todo: tell the user to run `todo` on the same patch they just used - NothingToPatch PatchPath Path' | PatchNeedsToBeConflictFree | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) - | WarnIncomingRootBranch ShortCausalHash (Set ShortCausalHash) | StartOfCurrentPathHistory | ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)] | PullAlreadyUpToDate (ReadRemoteNamespace Share.RemoteProjectBranch) - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) | PullSuccessful (ReadRemoteNamespace Share.RemoteProjectBranch) - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) | AboutToMerge | -- | 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 - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) + (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) + | -- This will replace the above once `merge.old` is deleted + MergeAlreadyUpToDate2 !MergeSourceAndTarget | PreviewMergeAlreadyUpToDate (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 | -- | List dependents of a type or term. ListDependents PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms - | DumpNumberedArgs NumberedArgs + | DumpNumberedArgs HashLength NumberedArgs | DumpBitBooster CausalHash (Map CausalHash [CausalHash]) | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] | BadName Text @@ -395,20 +392,20 @@ data Output | UpgradeFailure !FilePath !NameSegment !NameSegment | UpgradeSuccess !NameSegment !NameSegment | LooseCodePushDeprecated - | MergeFailure !FilePath !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) - | MergeSuccess !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) - | MergeSuccessFastForward !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) - | -- These are all merge precondition violations. See PreconditionViolation for more docs. - MergeConflictedAliases !ProjectBranchName !Name !Name - | MergeConflictedTermName !Name !(Set Referent) - | MergeConflictedTypeName !Name !(Set Reference.TypeReference) + | MergeFailure !FilePath !MergeSourceAndTarget + | MergeSuccess !MergeSourceAndTarget + | MergeSuccessFastForward !MergeSourceAndTarget + | MergeConflictedAliases !MergeSourceOrTarget !Name !Name + | MergeConflictedTermName !Name !(NESet Referent) + | MergeConflictedTypeName !Name !(NESet TypeReference) | MergeConflictInvolvingBuiltin !Name - | MergeConstructorAlias !(Maybe ProjectBranchName) !Name !Name - | MergeDefnsInLib - | MergeMissingConstructorName !Name - | MergeNestedDeclAlias !Name !Name - | MergeStrayConstructor !Name + | MergeConstructorAlias !MergeSourceOrTarget !Name !Name !Name + | MergeDefnsInLib !MergeSourceOrTarget + | MergeMissingConstructorName !MergeSourceOrTarget !Name + | MergeNestedDeclAlias !MergeSourceOrTarget !Name !Name + | MergeStrayConstructor !MergeSourceOrTarget !Name | InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment + | NoUpgradeInProgress data UpdateOrUpgrade = UOUUpdate | UOUUpgrade @@ -487,7 +484,6 @@ isFailure o = case o of BranchAlreadyExists {} -> True -- we do a global search after finding no local matches, so let's not call this a failure yet FindNoLocalMatches {} -> False - PatchAlreadyExists {} -> True NoExactTypeMatches -> True BranchEmpty {} -> True EmptyLooseCodePush {} -> True @@ -507,13 +503,11 @@ isFailure o = case o of BranchNotFound {} -> True NameNotFound {} -> True NamesNotFound _ -> True - PatchNotFound {} -> True TypeNotFound {} -> True TypeNotFound' {} -> True TermNotFound {} -> True MoveNothingFound {} -> True TermNotFound' {} -> True - TypeTermMismatch {} -> True SearchTermsNotFound ts -> not (null ts) SearchTermsNotFoundDetailed _ misses otherHits -> not (null misses && null otherHits) DeleteBranchConfirmation {} -> False @@ -523,7 +517,6 @@ isFailure o = case o of DeletedEverything -> False ListNames _ _ tys tms -> null tms && null tys ListOfDefinitions _ _ _ ds -> null ds - ListOfPatches s -> Set.null s ListStructuredFind tms -> null tms SlurpOutput _ _ sr -> not $ SR.isOk sr ParseErrors {} -> True @@ -541,15 +534,12 @@ isFailure o = case o of TestIncrementalOutputEnd {} -> False TestResults _ _ _ _ _ fails -> not (null fails) CantUndo {} -> True - GitError {} -> True BustedBuiltins {} -> True NoConfiguredRemoteMapping {} -> True ConfiguredRemoteMappingParseError {} -> True PatchNeedsToBeConflictFree {} -> True PatchInvolvesExternalDependents {} -> True AboutToPropagatePatch {} -> False - NothingToPatch {} -> False - WarnIncomingRootBranch {} -> False StartOfCurrentPathHistory -> True NotImplemented -> True DumpNumberedArgs {} -> False @@ -560,6 +550,7 @@ isFailure o = case o of AboutToMerge {} -> False MergeOverEmpty {} -> False MergeAlreadyUpToDate {} -> False + MergeAlreadyUpToDate2 {} -> False PreviewMergeAlreadyUpToDate {} -> False NoConflictsOrEdits {} -> False ListShallow _ es -> null es @@ -646,11 +637,12 @@ isFailure o = case o of MergeConflictedTypeName {} -> True MergeConflictInvolvingBuiltin {} -> True MergeConstructorAlias {} -> True - MergeDefnsInLib -> True + MergeDefnsInLib {} -> True MergeMissingConstructorName {} -> True MergeNestedDeclAlias {} -> True MergeStrayConstructor {} -> True InstalledLibdep {} -> False + NoUpgradeInProgress {} -> True isNumberedFailure :: NumberedOutput -> Bool isNumberedFailure = \case @@ -661,7 +653,6 @@ isNumberedFailure = \case DeletedDespiteDependents {} -> False History {} -> False ListBranches {} -> False - ListEdits {} -> False ListProjects {} -> False ShowDiffAfterCreateAuthor {} -> False ShowDiffAfterDeleteBranch {} -> False diff --git a/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs new file mode 100644 index 000000000..eda42c610 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs @@ -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) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 8a3800468..cf7a99a8f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,36 +1,26 @@ module Unison.Codebase.Editor.UriParser ( readRemoteNamespaceParser, - writeGitRepo, - deprecatedWriteGitRemoteNamespace, writeRemoteNamespace, writeRemoteNamespaceWith, parseReadShareLooseCode, ) where -import Data.Char (isAlphaNum, isDigit, isSpace) -import Data.Sequence as Seq +import Data.Char (isAlphaNum) import Data.Text qualified as Text import Data.These (These) import Data.Void import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as C -import U.Util.Base32Hex qualified as Base32Hex import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace (..), - ReadGitRepo (..), - ReadRemoteNamespace (..), + ( ReadRemoteNamespace (..), ReadShareLooseCode (..), ShareCodeserver (DefaultCodeserver), ShareUserHandle (..), - WriteGitRemoteNamespace (..), - WriteGitRepo (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), ) -import Unison.Codebase.Path (Path (..)) import Unison.Codebase.Path qualified as Path -import Unison.Codebase.ShortCausalHash (ShortCausalHash (..)) import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) @@ -41,30 +31,10 @@ import Unison.Util.Pretty.MegaParsec qualified as P type P = P.Parsec Void Text.Text --- Here are the git protocols that we know how to parse --- Local Protocol - --- $ git clone /srv/git/project.git - --- $ git clone /srv/git/project.git[:treeish][:[#hash][.path]] --- File Protocol - --- $ git clone file:///srv/git/project.git[:treeish][:[#hash][.path]] --- Smart / Dumb HTTP protocol - --- $ git clone https://example.com/gitproject.git[:treeish][:[#hash][.path]] --- SSH Protocol - --- $ git clone ssh://[user@]server/project.git[:treeish][:[#hash][.path]] - --- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]] - readRemoteNamespaceParser :: ProjectBranchSpecifier branch -> P (ReadRemoteNamespace (These ProjectName branch)) readRemoteNamespaceParser specifier = - P.label "generic repo" $ - ReadRemoteNamespaceGit <$> readGitRemoteNamespace - <|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier - <|> ReadShare'LooseCode <$> readShareLooseCode + ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier + <|> ReadShare'LooseCode <$> readShareLooseCode projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths :: ProjectBranchSpecifier branch -> @@ -82,9 +52,7 @@ parseReadShareLooseCode label input = in first printError (P.parse readShareLooseCode label (Text.pack input)) -- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4" --- >>> P.parseMaybe writeRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3" -- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})) --- Just (WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "git@github.com:unisonweb/base", branch = Just "v3"}, path = _releases.M3})) writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName)) writeRemoteNamespace = writeRemoteNamespaceWith @@ -92,8 +60,7 @@ writeRemoteNamespace = writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a) writeRemoteNamespaceWith projectBranchParser = - WriteRemoteNamespaceGit <$> writeGitRemoteNamespace - <|> WriteRemoteProjectBranch <$> projectBranchParser + WriteRemoteProjectBranch <$> projectBranchParser <|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace -- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4" @@ -109,7 +76,7 @@ writeShareRemoteNamespace = -- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4" -- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4" -- 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 = do P.label "read share loose code" $ @@ -131,252 +98,15 @@ shareUserHandle :: P ShareUserHandle shareUserHandle = do ShareUserHandle . Text.pack <$> P.some (P.satisfy \c -> isAlphaNum c || c == '-' || c == '_') --- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf" --- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf." --- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)" --- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3" --- >>> P.parseMaybe readGitRemoteNamespace "git( user@server:project.git:branch )#asdf.foo.bar" --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = }) --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = }) --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Nothing, path = }) --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sch = Nothing, path = _releases.M3}) --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = foo.bar}) -readGitRemoteNamespace :: P ReadGitRemoteNamespace -readGitRemoteNamespace = P.label "generic git repo" $ do - C.string "git(" - protocol <- parseGitProtocol - treeish <- P.optional gitTreeishSuffix - let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish} - C.string ")" - nshashPath <- P.optional namespaceHashPath - pure case nshashPath of - Nothing -> ReadGitRemoteNamespace {repo, sch = Nothing, path = Path.empty} - Just (sch, path) -> ReadGitRemoteNamespace {repo, sch, path} - --- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)" --- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)" --- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}) --- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}) --- --- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git)" --- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git:branch)" --- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}) --- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}) --- --- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git)" --- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git:base)" --- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}) --- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}) --- --- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git)" --- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git:branch)" --- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git)" --- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git:branch)" --- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}) --- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}) --- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}) --- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}) --- --- >>> P.parseMaybe writeGitRepo "git(server:project)" --- >>> P.parseMaybe writeGitRepo "git(user@server:project.git:branch)" --- Just (WriteGitRepo {url = "server:project", branch = Nothing}) --- Just (WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}) -writeGitRepo :: P WriteGitRepo -writeGitRepo = P.label "repo root for writing" $ do - C.string "git(" - uri <- parseGitProtocol - treeish <- P.optional gitTreeishSuffix - C.string ")" - pure WriteGitRepo {url = printProtocol uri, branch = treeish} - --- | A parser for the deprecated format of git URLs, which may still exist in old GitURL --- unisonConfigs. --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "/srv/git/project.git:.namespace" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "/srv/git/project.git:branch:.namespace" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}, path = namespace}) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}, path = namespace}) --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "file:///srv/git/project.git" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "file:///srv/git/project.git:branch" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}, path = }) --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "https://example.com/gitproject.git" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "https://example.com/gitproject.git:base" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}, path = }) --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://user@server/project.git" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://user@server/project.git:branch" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://server/project.git" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://server/project.git:branch" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}, path = }) --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "server:project" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "user@server:project.git:branch" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "server:project", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}, path = }) -deprecatedWriteGitRemoteNamespace :: P WriteGitRemoteNamespace -deprecatedWriteGitRemoteNamespace = P.label "generic write repo" $ do - repo <- deprecatedWriteGitRepo - path <- P.optional (C.char ':' *> absolutePath) - pure WriteGitRemoteNamespace {repo, path = fromMaybe Path.empty path} - where - deprecatedWriteGitRepo :: P WriteGitRepo - deprecatedWriteGitRepo = do - P.label "repo root for writing" $ do - uri <- parseGitProtocol - treeish <- P.optional deprecatedTreeishSuffix - pure WriteGitRepo {url = printProtocol uri, branch = treeish} - deprecatedTreeishSuffix :: P Text - deprecatedTreeishSuffix = P.label "git treeish" . P.try $ do - void $ C.char ':' - notdothash <- P.noneOf @[] ".#:" - rest <- P.takeWhileP (Just "not colon") (/= ':') - pure $ Text.cons notdothash rest - --- git(myrepo@git.com).foo.bar -writeGitRemoteNamespace :: P WriteGitRemoteNamespace -writeGitRemoteNamespace = P.label "generic write repo" $ do - repo <- writeGitRepo - path <- P.optional absolutePath - pure WriteGitRemoteNamespace {repo, path = fromMaybe Path.empty path} - -data GitProtocol - = HttpsProtocol (Maybe User) HostInfo UrlPath - | SshProtocol (Maybe User) HostInfo UrlPath - | ScpProtocol (Maybe User) Host UrlPath - | FileProtocol UrlPath - | LocalProtocol UrlPath - deriving (Eq, Ord, Show) - -printProtocol :: GitProtocol -> Text --- printProtocol x | traceShow x False = undefined -printProtocol x = case x of - HttpsProtocol muser hostInfo path -> - "https://" - <> printUser muser - <> printHostInfo hostInfo - <> path - SshProtocol muser hostInfo path -> - "ssh://" - <> printUser muser - <> printHostInfo hostInfo - <> path - ScpProtocol muser host path -> printUser muser <> host <> ":" <> path - FileProtocol path -> "file://" <> path - LocalProtocol path -> path - where - printUser = maybe mempty (\(User u) -> u <> "@") - printHostInfo :: HostInfo -> Text - printHostInfo (HostInfo hostname mport) = - hostname <> maybe mempty (Text.cons ':') mport - data Scheme = Ssh | Https deriving (Eq, Ord, Show) data User = User Text deriving (Eq, Ord, Show) -type UrlPath = Text - data HostInfo = HostInfo Text (Maybe Text) deriving (Eq, Ord, Show) -type Host = Text -- no port - --- doesn't yet handle basic authentication like https://user:pass@server.com --- (does anyone even want that?) --- or handle ipv6 addresses (https://en.wikipedia.org/wiki/IPv6#Addressing) -parseGitProtocol :: P GitProtocol -parseGitProtocol = - P.label "parseGitProtocol" $ - fileRepo <|> httpsRepo <|> sshRepo <|> scpRepo <|> localRepo - where - localRepo, fileRepo, httpsRepo, sshRepo, scpRepo :: P GitProtocol - parsePath = - P.takeWhile1P - (Just "repo path character") - (\c -> not (isSpace c || c == ':' || c == ')')) - localRepo = LocalProtocol <$> parsePath - fileRepo = P.label "fileRepo" $ do - void $ C.string "file://" - FileProtocol <$> parsePath - httpsRepo = P.label "httpsRepo" $ do - void $ C.string "https://" - HttpsProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath - sshRepo = P.label "sshRepo" $ do - void $ C.string "ssh://" - SshProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath - scpRepo = - P.label "scpRepo" . P.try $ - ScpProtocol <$> P.optional userInfo <*> parseHost <* C.string ":" <*> parsePath - userInfo :: P User - userInfo = P.label "userInfo" . P.try $ do - username <- P.takeWhile1P (Just "username character") (/= '@') - void $ C.char '@' - pure $ User username - parseHostInfo :: P HostInfo - parseHostInfo = - P.label "parseHostInfo" $ - HostInfo - <$> parseHost - <*> ( P.optional $ do - void $ C.char ':' - P.takeWhile1P (Just "digits") isDigit - ) - - parseHost = P.label "parseHost" $ hostname <|> ipv4 -- <|> ipv6 - where - hostname = - P.takeWhile1P - (Just "hostname character") - (\c -> isAlphaNum c || c == '.' || c == '-') - ipv4 = P.label "ipv4 address" $ do - o1 <- decOctet - void $ C.char '.' - o2 <- decOctet - void $ C.char '.' - o3 <- decOctet - void $ C.char '.' - o4 <- decOctet - pure $ Text.pack $ o1 <> "." <> o2 <> "." <> o3 <> "." <> o4 - decOctet = P.count' 1 3 C.digitChar - --- >>> P.parseMaybe namespaceHashPath "#nshashabc.path.foo.bar" --- Just (Just #nshashabc,path.foo.bar) --- --- >>> P.parseMaybe namespaceHashPath ".path.foo.bar" --- Just (Nothing,path.foo.bar) --- --- >>> P.parseMaybe namespaceHashPath "#nshashabc" --- Just (Just #nshashabc,) --- --- >>> P.parseMaybe namespaceHashPath "#nshashabc." --- Just (Just #nshashabc,) --- --- >>> P.parseMaybe namespaceHashPath "." --- Just (Nothing,) -namespaceHashPath :: P (Maybe ShortCausalHash, Path) -namespaceHashPath = do - sch <- P.optional shortCausalHash - p <- P.optional absolutePath - pure (sch, fromMaybe Path.empty p) - --- >>> P.parseMaybe absolutePath "." --- Just --- --- >>> P.parseMaybe absolutePath ".path.foo.bar" --- Just path.foo.bar -absolutePath :: P Path -absolutePath = do - void $ C.char '.' - Path . Seq.fromList <$> P.sepBy nameSegment (C.char '.') - nameSegment :: P NameSegment nameSegment = NameSegment.unsafeParseText . Text.pack @@ -384,14 +114,3 @@ nameSegment = <$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar <*> P.many (P.satisfy Unison.Syntax.Lexer.wordyIdChar) ) - -gitTreeishSuffix :: P Text -gitTreeishSuffix = P.label "git treeish" . P.try $ do - void $ C.char ':' - P.takeWhile1P (Just "not close paren") (/= ')') - -shortCausalHash :: P ShortCausalHash -shortCausalHash = P.label "short causal hash" $ do - void $ C.char '#' - ShortCausalHash - <$> P.takeWhile1P (Just "base32hex chars") (`elem` Base32Hex.validChars) diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index f97a25e33..2c8be9bf4 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -46,6 +46,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Input (Event (..), Input (..)) +import Unison.Codebase.Editor.Output (NumberedArgs) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Watch qualified as Watch import Unison.CommandLine.FZFResolvers qualified as FZFResolvers @@ -123,14 +124,14 @@ parseInput :: -- | Current path from root Path.Absolute -> -- | Numbered arguments - [String] -> + NumberedArgs -> -- | Input Pattern Map Map String InputPattern -> -- | command:arguments [String] -> -- Returns either an error message or the fully expanded arguments list and parsed input. -- If the output is `Nothing`, the user cancelled the input (e.g. ctrl-c) - IO (Either (P.Pretty CT.ColorText) (Maybe ([String], Input))) + IO (Either (P.Pretty CT.ColorText) (Maybe (InputPattern.Arguments, Input))) parseInput codebase currentPath numberedArgs patterns segments = runExceptT do let getCurrentBranch0 :: IO (Branch0 IO) getCurrentBranch0 = Branch.head <$> Codebase.getBranchAtPath codebase currentPath @@ -140,16 +141,16 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do [] -> throwE "" command : args -> case Map.lookup command patterns of Just pat@(InputPattern {parse, help}) -> do - let expandedNumbers :: [String] + let expandedNumbers :: InputPattern.Arguments expandedNumbers = - foldMap (expandNumber numberedArgs) args + foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args lift (fzfResolve codebase projCtx getCurrentBranch0 pat expandedNumbers) >>= \case Left (NoFZFResolverForArgumentType _argDesc) -> throwError help Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc) Left FZFCancelled -> pure Nothing Right resolvedArgs -> do parsedInput <- except . parse $ resolvedArgs - pure $ Just (command : resolvedArgs, parsedInput) + pure $ Just (Left command : resolvedArgs, parsedInput) Nothing -> throwE . warn @@ -168,11 +169,9 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do ] -- Expand a numeric argument like `1` or a range like `3-9` -expandNumber :: [String] -> String -> [String] -expandNumber numberedArgs s = case expandedNumber of - Nothing -> [s] - Just nums -> - [s | i <- nums, Just s <- [vargs Vector.!? (i - 1)]] +expandNumber :: NumberedArgs -> String -> Maybe NumberedArgs +expandNumber numberedArgs s = + (\nums -> [arg | i <- nums, Just arg <- [vargs Vector.!? (i - 1)]]) <$> expandedNumber where vargs = Vector.fromList numberedArgs rangeRegex = "([0-9]+)-([0-9]+)" :: String @@ -193,13 +192,13 @@ data FZFResolveFailure | NoFZFOptions Text {- argument description -} | FZFCancelled -fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> [String] -> IO (Either FZFResolveFailure [String]) +fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments) fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do -- We resolve args in two steps, first we check that all arguments that will require a fzf -- resolver have one, and only if so do we prompt the user to actually do a fuzzy search. -- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver -- for a later arg. - argumentResolvers :: [ExceptT FZFResolveFailure IO [String]] <- + argumentResolvers :: [ExceptT FZFResolveFailure IO InputPattern.Arguments] <- (Align.align (InputPattern.args pat) args) & traverse \case This (argName, opt, InputPattern.ArgumentType {fzfResolver}) @@ -212,7 +211,7 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do These _ arg -> pure $ pure [arg] argumentResolvers & foldMapM id where - fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO [String] + fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch options <- liftIO $ getOptions codebase projCtx currentBranch @@ -223,8 +222,9 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do `whenNothingM` throwError FZFCancelled -- If the user triggered the fuzzy finder, but selected nothing, abort the command rather than continuing execution -- with no arguments. - when (null results) $ throwError FZFCancelled - pure (Text.unpack <$> results) + if null results + then throwError FZFCancelled + else pure (Left . Text.unpack <$> results) multiSelectForOptional :: InputPattern.IsOptional -> Bool multiSelectForOptional = \case diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index f72506bab..4014bc1dc 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -4,8 +4,10 @@ module Unison.CommandLine.InputPattern ( InputPattern (..), + Argument, ArgumentType (..), ArgumentDescription, + Arguments, argType, FZFResolver (..), IsOptional (..), @@ -25,6 +27,7 @@ import System.Console.Haskeline qualified as Line import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Editor.Input (Input (..)) +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.Path as Path import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.Prelude @@ -44,6 +47,14 @@ data IsOptional data Visibility = Hidden | Visible deriving (Show, Eq, Ord) +-- | An argument to a command is either a string provided by the user which +-- needs to be parsed or a numbered argument that doesn’t need to be parsed, as +-- we’ve preserved its representation (although the numbered argument could +-- still be of the wrong type, which should result in an error). +type Argument = Either String StructuredArgument + +type Arguments = [Argument] + -- | Argument description -- It should fit grammatically into sentences like "I was expecting an argument for the " -- e.g. "namespace to merge", "definition to delete", "remote target to push to" etc. @@ -55,7 +66,7 @@ data InputPattern = InputPattern visibility :: Visibility, -- Allow hiding certain commands when debugging or work-in-progress args :: [(ArgumentDescription, IsOptional, ArgumentType)], help :: P.Pretty CT.ColorText, - parse :: [String] -> Either (P.Pretty CT.ColorText) Input + parse :: Arguments -> Either (P.Pretty CT.ColorText) Input } data ArgumentType = ArgumentType diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 05eb24753..f2016eeed 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2,7 +2,140 @@ This module defines 'InputPattern' values for every supported input command. -} -module Unison.CommandLine.InputPatterns where +module Unison.CommandLine.InputPatterns + ( -- * Input commands + add, + aliasMany, + aliasTerm, + aliasType, + api, + authLogin, + back, + branchEmptyInputPattern, + branchInputPattern, + branchRenameInputPattern, + branchesInputPattern, + cd, + clear, + clone, + compileScheme, + createAuthor, + debugClearWatchCache, + debugDoctor, + debugDumpNamespace, + debugDumpNamespaceSimple, + debugFileHashes, + debugFormat, + debugFuzzyOptions, + debugLSPFoldRanges, + debugNameDiff, + debugNumberedArgs, + debugTabCompletion, + debugTerm, + debugTermVerbose, + debugType, + delete, + deleteBranch, + deleteNamespace, + deleteNamespaceForce, + deleteProject, + deleteTerm, + deleteTermVerbose, + deleteType, + deleteTypeVerbose, + deleteVerbose, + dependencies, + dependents, + diffNamespace, + display, + displayTo, + docToMarkdown, + docs, + docsToHtml, + edit, + editNamespace, + execute, + find, + findAll, + findGlobal, + findIn, + findInAll, + findShallow, + findVerbose, + findVerboseAll, + forkLocal, + help, + helpTopics, + history, + ioTest, + ioTestAll, + libInstallInputPattern, + load, + makeStandalone, + mergeBuiltins, + mergeIOBuiltins, + mergeInputPattern, + mergeOldInputPattern, + mergeOldPreviewInputPattern, + mergeOldSquashInputPattern, + moveAll, + names, + namespaceDependencies, + previewAdd, + previewUpdate, + printVersion, + projectCreate, + projectCreateEmptyInputPattern, + projectRenameInputPattern, + projectSwitch, + projectsInputPattern, + pull, + pullWithoutHistory, + push, + pushCreate, + pushExhaustive, + pushForce, + quit, + releaseDraft, + renameBranch, + renameTerm, + renameType, + reset, + resetRoot, + runScheme, + saveExecuteResult, + sfind, + sfindReplace, + test, + testAll, + todo, + ui, + undo, + up, + update, + updateBuiltins, + updateOld, + updateOldNoPatch, + upgrade, + upgradeCommitInputPattern, + view, + viewGlobal, + viewReflog, + + -- * Misc + formatStructuredArgument, + helpFor, + makeExample', + makeExample, + makeExampleEOS, + makeExampleNoBackticks, + patternMap, + patternName, + showPatternHelp, + unifyArgument, + validInputs, + ) +where import Control.Lens (preview, review, (^.)) import Control.Lens.Cons qualified as Cons @@ -11,7 +144,6 @@ import Data.List.Extra qualified as List import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map import Data.Maybe (fromJust) -import Data.Proxy (Proxy (..)) import Data.Set qualified as Set import Data.Text qualified as Text import Data.These (These (..)) @@ -20,8 +152,8 @@ import System.Console.Haskeline.Completion (Completion (Completion)) import System.Console.Haskeline.Completion qualified as Haskeline import System.Console.Haskeline.Completion qualified as Line import Text.Megaparsec qualified as Megaparsec -import Text.Megaparsec.Internal qualified as Megaparsec (withParsecT) -import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.HashTags (CausalHash (..)) +import U.Codebase.Sqlite.DbId (ProjectBranchId) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Auth.HTTPClient (AuthenticatedHttpClient) @@ -33,28 +165,33 @@ import Unison.Codebase.Branch.Merge qualified as Branch import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) -import Unison.Codebase.Editor.Output.PushPull qualified as PushPull -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SR +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser) import Unison.Codebase.Editor.UriParser qualified as UriParser +import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.PushBehavior qualified as PushBehavior -import Unison.Codebase.Verbosity (Verbosity) -import Unison.Codebase.Verbosity qualified as Verbosity +import Unison.Codebase.ShortCausalHash (ShortCausalHash) +import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.CommandLine -import Unison.CommandLine.BranchRelativePath (parseBranchRelativePath, parseIncrementalBranchRelativePath) +import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..), parseBranchRelativePath, parseIncrementalBranchRelativePath) import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath import Unison.CommandLine.Completion import Unison.CommandLine.FZFResolvers qualified as Resolvers import Unison.CommandLine.InputPattern (ArgumentType (..), InputPattern (InputPattern), IsOptional (..), unionSuggestions) import Unison.CommandLine.InputPattern qualified as I import Unison.HashQualified qualified as HQ +import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Project ( ProjectAndBranch (..), @@ -64,14 +201,67 @@ import Unison.Project ProjectBranchSpecifier (..), ProjectName, Semver, + branchWithOptionalProjectParser, ) import Unison.Project.Util (ProjectContext (..), projectContextFromPath) -import Unison.Syntax.HashQualified qualified as HQ (parseText) -import Unison.Syntax.Name qualified as Name (parseText, unsafeParseText) -import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP) +import Unison.Referent qualified as Referent +import Unison.Server.Backend (ShallowListEntry (..)) +import Unison.Server.Backend qualified as Backend +import Unison.Server.SearchResult (SearchResult) +import Unison.Server.SearchResult qualified as SR +import Unison.ShortHash (ShortHash) +import Unison.Syntax.HashQualified qualified as HQ (parseText, toText) +import Unison.Syntax.Name qualified as Name (parseTextEither, toText) +import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) +import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as P +import Unison.Util.Pretty.MegaParsec (prettyPrintParseError) + +formatStructuredArgument :: Maybe Int -> StructuredArgument -> Text +formatStructuredArgument schLength = \case + SA.AbsolutePath path -> into @Text $ show path + SA.Name name -> Name.toText name + SA.HashQualified hqName -> HQ.toText hqName + SA.Project projectName -> into @Text projectName + SA.ProjectBranch (ProjectAndBranch mproj branch) -> + maybe (Text.cons '/' . into @Text) (\project -> into @Text . ProjectAndBranch project) mproj branch + -- also: ("#" <>) . Hash.toBase32HexText . unCausalHash + SA.Namespace causalHash -> ("#" <>) . SCH.toText $ maybe SCH.fromFullHash SCH.fromHash schLength causalHash + SA.NameWithBranchPrefix absBranchId name -> prefixBranchId absBranchId name + SA.HashQualifiedWithBranchPrefix absBranchId hq'Name -> HQ'.toTextWith (prefixBranchId absBranchId) hq'Name + SA.ShallowListEntry path entry -> entryToHQText path entry + SA.SearchResult searchRoot searchResult -> HQ.toText $ searchResultToHQ searchRoot searchResult + where + -- E.g. + -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef:.base.List.map" + -- prefixBranchId ".base" "List.map" -> ".base.List.map" + prefixBranchId :: Input.AbsBranchId -> Name -> Text + prefixBranchId branchId name = case branchId of + Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) + Right pathPrefix -> Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name) + + entryToHQText :: Path' -> ShallowListEntry v Ann -> Text + entryToHQText pathArg = + fixup . \case + ShallowTypeEntry te -> Backend.typeEntryDisplayName te + ShallowTermEntry te -> Backend.termEntryDisplayName te + ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns + ShallowPatchEntry ns -> NameSegment.toEscapedText ns + where + fixup s = + pathArgStr + <> if Text.null pathArgStr || Text.isSuffixOf "." pathArgStr + then s + else "." <> s + pathArgStr = Text.pack $ show pathArg + +-- | Converts an arbitrary argument to a `String`. This is for cases where the +-- command /should/ accept a structured argument of some type, but currently +-- wants a `String`. +unifyArgument :: I.Argument -> String +unifyArgument = either id (Text.unpack . formatStructuredArgument Nothing) showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = @@ -85,6 +275,48 @@ showPatternHelp i = I.help i ] +-- | restores the full hash to these search results, for _numberedArgs purposes +searchResultToHQ :: Maybe Path -> SearchResult -> HQ.HashQualified Name +searchResultToHQ oprefix = \case + SR.Tm' n r _ -> HQ.requalify (addPrefix <$> n) r + SR.Tp' n r _ -> HQ.requalify (addPrefix <$> n) (Referent.Ref r) + _ -> error "impossible match failure" + where + addPrefix :: Name -> Name + addPrefix = maybe id Path.prefixName2 oprefix + +unsupportedStructuredArgument :: Text -> I.Argument -> Either (P.Pretty CT.ColorText) String +unsupportedStructuredArgument expected = + either pure (const . Left . P.text $ "can’t use a numbered argument for " <> expected) + +expectedButActually :: Text -> StructuredArgument -> Text -> P.Pretty CT.ColorText +expectedButActually expected actualValue actualType = + P.text $ + "Expected " + <> expected + <> ", but the numbered arg resulted in " + <> formatStructuredArgument Nothing actualValue + <> ", which is " + <> actualType + <> "." + +wrongStructuredArgument :: Text -> StructuredArgument -> P.Pretty CT.ColorText +wrongStructuredArgument expected actual = + expectedButActually + expected + actual + case actual of + SA.Name _ -> "a name" + SA.AbsolutePath _ -> "an absolute path" + SA.Namespace _ -> "a namespace" + SA.Project _ -> "a project" + SA.ProjectBranch _ -> "a branch" + SA.HashQualified _ -> "a hash-qualified name" + SA.NameWithBranchPrefix _ _ -> "a name" + SA.HashQualifiedWithBranchPrefix _ _ -> "a hash-qualified name" + SA.ShallowListEntry _ _ -> "an annotated symbol" + SA.SearchResult _ _ -> "a search result" + patternName :: InputPattern -> P.Pretty P.ColorText patternName = fromString . I.patternName @@ -97,14 +329,346 @@ makeExampleNoBackticks p args = makeExample' :: InputPattern -> P.Pretty CT.ColorText makeExample' p = makeExample p [] -makeExampleEOS :: - InputPattern -> [P.Pretty CT.ColorText] -> P.Pretty CT.ColorText +makeExampleEOS :: InputPattern -> [P.Pretty CT.ColorText] -> P.Pretty CT.ColorText makeExampleEOS p args = P.group $ backtick (intercalateMap " " id (P.nonEmpty $ fromString (I.patternName p) : args)) <> "." helpFor :: InputPattern -> P.Pretty CT.ColorText -helpFor p = I.help p +helpFor = I.help + +handleProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectName +handleProjectArg = + either + ( \name -> + first (const . P.text $ "“" <> Text.pack name <> "” is an invalid project name") . tryInto @ProjectName $ + Text.pack name + ) + \case + SA.Project project -> pure project + otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType + +handleLooseCodeOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.LooseCodeOrProject +handleLooseCodeOrProjectArg = + either + (maybe (Left $ P.text "invalid path or project branch") pure . parseLooseCodeOrProject) + \case + SA.AbsolutePath path -> pure . This $ Path.absoluteToPath' path + SA.ProjectBranch pb -> pure $ That pb + otherArgType -> Left $ wrongStructuredArgument "a path or project branch" otherArgType + +handleMaybeProjectBranchArg :: + I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) +handleMaybeProjectBranchArg = + either + (megaparse branchWithOptionalProjectParser . Text.pack) + \case + SA.ProjectBranch pb -> pure pb + otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType + +handleProjectMaybeBranchArg :: + I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) +handleProjectMaybeBranchArg = + either + (first (const $ P.text "The argument wasn’t a project") . tryInto . Text.pack) + \case + SA.Project proj -> pure $ ProjectAndBranch proj Nothing + SA.ProjectBranch (ProjectAndBranch (Just proj) branch) -> + pure . ProjectAndBranch proj . pure $ ProjectBranchNameOrLatestRelease'Name branch + otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType + +handleHashQualifiedNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) +handleHashQualifiedNameArg = + either + parseHashQualifiedName + \case + SA.Name name -> pure $ HQ.NameOnly name + SA.NameWithBranchPrefix mprefix name -> + pure . HQ.NameOnly $ foldr (\prefix -> Name.makeAbsolute . Path.prefixName prefix) name mprefix + SA.HashQualified hqname -> pure hqname + SA.HashQualifiedWithBranchPrefix mprefix hqname -> + pure . HQ'.toHQ $ foldr (\prefix -> fmap $ Name.makeAbsolute . Path.prefixName prefix) hqname mprefix + SA.SearchResult mpath result -> pure $ searchResultToHQ mpath result + otherArgType -> Left $ wrongStructuredArgument "a hash-qualified name" otherArgType + +handlePathArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path +handlePathArg = + either + (first P.text . Path.parsePath) + \case + SA.Name name -> pure $ Path.fromName name + SA.NameWithBranchPrefix mprefix name -> pure . Path.fromName $ foldr Path.prefixName name mprefix + otherArgType -> Left $ wrongStructuredArgument "a relative path" otherArgType + +handlePath'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path' +handlePath'Arg = + either + (first P.text . Path.parsePath') + \case + SA.AbsolutePath path -> pure $ Path.absoluteToPath' path + SA.Name name -> pure $ Path.fromName' name + SA.NameWithBranchPrefix mprefix name -> + pure . Path.fromName' $ foldr (\prefix -> Name.makeAbsolute . Path.prefixName prefix) name mprefix + otherArgType -> Left $ wrongStructuredArgument "a namespace" otherArgType + +handleNewName :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split' +handleNewName = + either + (first P.text . Path.parseSplit') + (const . Left $ "can’t use a numbered argument for a new name") + +handleNewPath :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path' +handleNewPath = + either + (first P.text . Path.parsePath') + (const . Left $ "can’t use a numbered argument for a new namespace") + +-- | When only a relative name is allowed. +handleSplitArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split +handleSplitArg = + either + (first P.text . Path.parseSplit) + \case + SA.Name name | Name.isRelative name -> pure $ Path.splitFromName name + SA.NameWithBranchPrefix (Left _) name | Name.isRelative name -> pure $ Path.splitFromName name + SA.NameWithBranchPrefix (Right prefix) name + | Name.isRelative name -> pure . Path.splitFromName . Name.makeAbsolute $ Path.prefixName prefix name + otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg + +handleSplit'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split' +handleSplit'Arg = + either + (first P.text . Path.parseSplit') + \case + SA.Name name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . Path.splitFromName' . Name.makeAbsolute $ Path.prefixName prefix name + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg + +handleProjectBranchNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectBranchName +handleProjectBranchNameArg = + either + (first (const $ P.text "Wanted a branch name, but it wasn’t") . tryInto . Text.pack) + \case + SA.ProjectBranch (ProjectAndBranch _ branch) -> pure branch + otherNumArg -> Left $ wrongStructuredArgument "a branch name" otherNumArg + +handleBranchIdArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.BranchId +handleBranchIdArg = + either + (first P.text . Input.parseBranchId) + \case + SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path + SA.Name name -> pure . pure $ Path.fromName' name + SA.NameWithBranchPrefix mprefix name -> + pure . pure . Path.fromName' $ either (const name) (Name.makeAbsolute . flip Path.prefixName name) mprefix + SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg + +handleBranchIdOrProjectArg :: + I.Argument -> + Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) +handleBranchIdOrProjectArg = + either + (maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject) + \case + SA.Namespace hash -> pure . This . Left $ SCH.fromFullHash hash + SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path + SA.Name name -> pure . This . pure $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . This . pure . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch pb -> pure $ pure pb + otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType + where + branchIdOrProject :: + String -> + Maybe + ( These + Input.BranchId + (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + ) + branchIdOrProject str = + let branchIdRes = Input.parseBranchId str + projectRes = + tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + (Text.pack str) + in case (branchIdRes, projectRes) of + (Left _, Left _) -> Nothing + (Left _, Right pr) -> Just (That pr) + (Right bid, Left _) -> Just (This bid) + (Right bid, Right pr) -> Just (These bid pr) + +handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) +handleBranchId2Arg = + either + Input.parseBranchId2 + \case + SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash + SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path + SA.Name name -> pure . pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch (ProjectAndBranch mproject branch) -> + pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg + +handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath +handleBranchRelativePathArg = + either + parseBranchRelativePath + \case + SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path + SA.Name name -> pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch (ProjectAndBranch mproject branch) -> + pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg + +hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit' +hqNameToSplit' = \case + HQ.HashOnly hash -> Left hash + HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName' name + HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName' name + +hqNameToSplit :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit +hqNameToSplit = \case + HQ.HashOnly hash -> Left hash + HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName name + HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName name + +hq'NameToSplit' :: HQ'.HashQualified Name -> Path.HQSplit' +hq'NameToSplit' = \case + HQ'.NameOnly name -> HQ'.NameOnly <$> Path.splitFromName' name + HQ'.HashQualified name hash -> flip HQ'.HashQualified hash <$> Path.splitFromName' name + +hq'NameToSplit :: HQ'.HashQualified Name -> Path.HQSplit +hq'NameToSplit = \case + HQ'.NameOnly name -> HQ'.NameOnly <$> Path.splitFromName name + HQ'.HashQualified name hash -> flip HQ'.HashQualified hash <$> Path.splitFromName name + +handleHashQualifiedSplit'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.HQSplit' +handleHashQualifiedSplit'Arg = + either + (first P.text . Path.parseHQSplit') + \case + hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit' name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . hq'NameToSplit' $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + sr@(SA.SearchResult mpath result) -> + first (const $ expectedButActually "a name" sr "a hash") . hqNameToSplit' $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg + +handleHashQualifiedSplitArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.HQSplit +handleHashQualifiedSplitArg = + either + (first P.text . Path.parseHQSplit) + \case + hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . hq'NameToSplit $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + sr@(SA.SearchResult mpath result) -> + first (const $ expectedButActually "a name" sr "a hash") . hqNameToSplit $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg + +handleShortCausalHashArg :: I.Argument -> Either (P.Pretty CT.ColorText) ShortCausalHash +handleShortCausalHashArg = + either + (first (P.text . Text.pack) . Input.parseShortCausalHash) + \case + SA.Namespace hash -> pure $ SCH.fromFullHash hash + otherNumArg -> Left $ wrongStructuredArgument "a causal hash" otherNumArg + +handleShortHashOrHQSplit'Arg :: + I.Argument -> Either (P.Pretty CT.ColorText) (Either ShortHash Path.HQSplit') +handleShortHashOrHQSplit'Arg = + either + (first P.text . Path.parseShortHashOrHQSplit') + \case + SA.HashQualified name -> pure $ hqNameToSplit' name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . pure $ hq'NameToSplit' (Name.makeAbsolute . Path.prefixName prefix <$> hqname) + SA.SearchResult mpath result -> pure . hqNameToSplit' $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a hash or name" otherNumArg + +handleRelativeNameSegmentArg :: I.Argument -> Either (P.Pretty CT.ColorText) NameSegment +handleRelativeNameSegmentArg arg = do + name <- handleNameArg arg + let (segment NE.:| tail) = Name.reverseSegments name + if Name.isRelative name && null tail + then pure segment + else Left $ P.text "Wanted a single relative name segment, but it wasn’t." + +handleNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) Name +handleNameArg = + either + (first P.text . Name.parseTextEither . Text.pack) + \case + SA.Name name -> pure name + SA.NameWithBranchPrefix (Left _) name -> pure name + SA.NameWithBranchPrefix (Right prefix) name -> pure . Name.makeAbsolute $ Path.prefixName prefix name + SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . Name.makeAbsolute . Path.prefixName prefix $ HQ'.toName hqname + SA.SearchResult mpath result -> + maybe (Left "can’t find a name from the numbered arg") pure . HQ.toName $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg + +handlePullSourceArg :: + I.Argument -> + Either + (P.Pretty CT.ColorText) + (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) +handlePullSourceArg = + either + (megaparse (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) . Text.pack) + \case + SA.Project project -> pure . RemoteRepo.ReadShare'ProjectBranch $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> + pure . RemoteRepo.ReadShare'ProjectBranch . maybe That These project $ + ProjectBranchNameOrLatestRelease'Name branch + otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg + +handlePushTargetArg :: + I.Argument -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +handlePushTargetArg = + either + (maybe (Left "Wanted a source to push from, but this ain’t it.") pure . parsePushTarget) + $ fmap RemoteRepo.WriteRemoteProjectBranch . \case + SA.Project project -> pure $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch + otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg + +handlePushSourceArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.PushSource +handlePushSourceArg = + either + (maybe (Left $ P.text "Wanted a source to push from, but this ain’t it.") pure . parsePushSource) + \case + SA.AbsolutePath path -> pure . Input.PathySource $ Path.absoluteToPath' path + SA.Name name -> pure . Input.PathySource $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . Input.PathySource $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . Input.PathySource . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.Project project -> pure . Input.ProjySource $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource $ maybe That These project branch + otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg + +handleProjectAndBranchNamesArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectAndBranchNames +handleProjectAndBranchNamesArg = + either + (first (const $ P.text "The argument wasn’t a project or branch") . tryInto @ProjectAndBranchNames . Text.pack) + $ fmap ProjectAndBranchNames'Unambiguous . \case + SA.Project project -> pure $ This project + SA.ProjectBranch (ProjectAndBranch mproj branch) -> pure $ maybe That These mproj branch + otherNumArg -> Left $ wrongStructuredArgument "a project or branch" otherNumArg mergeBuiltins :: InputPattern mergeBuiltins = @@ -116,9 +680,7 @@ mergeBuiltins = "Adds the builtins (excluding `io` and misc) to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeBuiltinsI $ Nothing - [p] -> first P.text do - p <- Path.parsePath p - pure . Input.MergeBuiltinsI $ Just p + [p] -> Input.MergeBuiltinsI . Just <$> handlePathArg p _ -> Left (I.help mergeBuiltins) mergeIOBuiltins :: InputPattern @@ -131,9 +693,7 @@ mergeIOBuiltins = "Adds all the builtins, including `io` and misc., to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeIOBuiltinsI $ Nothing - [p] -> first P.text do - p <- Path.parsePath p - pure . Input.MergeIOBuiltinsI $ Just p + [p] -> Input.MergeIOBuiltinsI . Just <$> handlePathArg p _ -> Left (I.help mergeBuiltins) updateBuiltins :: InputPattern @@ -169,16 +729,15 @@ todo = ) ] ) - ( \case - patchStr : ws -> mapLeft (warn . P.text) $ do - patch <- Path.parseSplit' patchStr - branch <- case ws of - [] -> pure Path.relativeEmpty' - [pathStr] -> Path.parsePath' pathStr - _ -> Left "`todo` just takes a patch and one optional namespace" - Right $ Input.TodoI (Just patch) branch - [] -> Right $ Input.TodoI Nothing Path.relativeEmpty' - ) + \case + patchStr : ws -> first warn $ do + patch <- handleSplit'Arg patchStr + branch <- case ws of + [] -> pure Path.relativeEmpty' + [pathStr] -> handlePath'Arg pathStr + _ -> Left "`todo` just takes a patch and one optional namespace" + Right $ Input.TodoI (Just patch) branch + [] -> Right $ Input.TodoI Nothing Path.relativeEmpty' load :: InputPattern load = @@ -196,11 +755,10 @@ load = ) ] ) - ( \case - [] -> pure $ Input.LoadI Nothing - [file] -> pure $ Input.LoadI . Just $ file - _ -> Left (I.help load) - ) + \case + [] -> pure $ Input.LoadI Nothing + [file] -> Input.LoadI . Just <$> unsupportedStructuredArgument "a file name" file + _ -> Left (I.help load) clear :: InputPattern clear = @@ -215,10 +773,9 @@ clear = ) ] ) - ( \case - [] -> pure $ Input.ClearI - _ -> Left (I.help clear) - ) + \case + [] -> pure Input.ClearI + _ -> Left (I.help clear) add :: InputPattern add = @@ -230,7 +787,7 @@ add = ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." ) - \ws -> pure $ Input.AddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + $ fmap (Input.AddI . Set.fromList) . traverse handleNameArg previewAdd :: InputPattern previewAdd = @@ -244,7 +801,7 @@ previewAdd = <> "results. Use `load` to reparse & typecheck the file if the context " <> "has changed." ) - \ws -> pure $ Input.PreviewAddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + $ fmap (Input.PreviewAddI . Set.fromList) . traverse handleNameArg update :: InputPattern update = @@ -259,10 +816,9 @@ update = <> "replacing existing definitions having the same name, and attempts to update all the existing dependents accordingly. If the process" <> "can't be completed automatically, the dependents will be added back to the scratch file" <> "for your review.", - parse = - maybeToEither (I.help update) . \case - [] -> Just Input.Update2I - _ -> Nothing + parse = \case + [] -> pure Input.Update2I + _ -> Left $ I.help update } updateOldNoPatch :: InputPattern @@ -291,13 +847,7 @@ updateOldNoPatch = ) ] ) - ( \case - ws -> do - pure $ - Input.UpdateI - Input.NoPatch - (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) - ) + $ fmap (Input.UpdateI Input.NoPatch . Set.fromList) . traverse handleNameArg updateOld :: InputPattern updateOld = @@ -332,12 +882,8 @@ updateOld = ] ) \case - patchStr : ws -> do - patch <- first P.text $ Path.parseSplit' patchStr - pure $ - Input.UpdateI - (Input.UsePatch patch) - (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + patchStr : ws -> + Input.UpdateI . Input.UsePatch <$> handleSplit'Arg patchStr <*> fmap Set.fromList (traverse handleNameArg ws) [] -> Right $ Input.UpdateI Input.DefaultPatch mempty previewUpdate :: InputPattern @@ -352,46 +898,7 @@ previewUpdate = <> "typechecking results. Use `load` to reparse & typecheck the file if " <> "the context has changed." ) - \ws -> pure $ Input.PreviewUpdateI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) - -patch :: InputPattern -patch = - InputPattern - "patch" - [] - I.Visible - [("patch", Required, patchArg), ("namespace", Optional, namespaceArg)] - ( P.lines - [ P.wrap $ - makeExample' patch - <> "rewrites any definitions that depend on " - <> "definitions with type-preserving edits to use the updated versions of" - <> "these dependencies.", - "", - P.wrapColumn2 - [ ( makeExample patch ["", "[path]"], - "applies the given patch" - <> "to the given namespace" - ), - ( makeExample patch [""], - "applies the given patch" - <> "to the current namespace" - ) - ] - ] - ) - \case - patchStr : ws -> first P.text do - patch <- Path.parseSplit' patchStr - branch <- case ws of - [pathStr] -> Path.parsePath' pathStr - _ -> pure Path.relativeEmpty' - pure $ Input.PropagatePatchI patch branch - [] -> - Left $ - warn $ - makeExample' patch - <> "takes a patch and an optional namespace." + $ fmap (Input.PreviewUpdateI . Set.fromList) . traverse handleNameArg view :: InputPattern view = @@ -411,12 +918,12 @@ view = <> "not `List.map.doc` (since ? only matches 1 name segment)." ] ) - ( \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - & fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionLocal) - _ -> Left (I.help view) + ( maybe + (Left $ I.help view) + ( fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionLocal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty ) viewGlobal :: InputPattern @@ -431,12 +938,12 @@ viewGlobal = "`view.global` without arguments invokes a search to select definitions to view, which requires that `fzf` can be found within your PATH." ] ) - ( \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - & fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionGlobal) - _ -> Left (I.help viewGlobal) + ( maybe + (Left $ I.help viewGlobal) + ( fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionGlobal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty ) display :: InputPattern @@ -451,12 +958,8 @@ display = "`display` without arguments invokes a search to select a definition to display, which requires that `fzf` can be found within your PATH." ] ) - \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> Input.DisplayI Input.ConsoleLocation - _ -> Left (I.help display) + $ maybe (Left $ I.help display) (fmap (Input.DisplayI Input.ConsoleLocation) . traverse handleHashQualifiedNameArg) + . NE.nonEmpty displayTo :: InputPattern displayTo = @@ -469,11 +972,16 @@ displayTo = makeExample displayTo ["", "foo"] <> "prints a rendered version of the term `foo` to the given file." ) - \case - file : (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> Input.DisplayI (Input.FileLocation file) + $ \case + file : defs -> + maybe + (Left $ I.help displayTo) + ( \defs -> + Input.DisplayI . Input.FileLocation + <$> unsupportedStructuredArgument "a file name" file + <*> traverse handleHashQualifiedNameArg defs + ) + $ NE.nonEmpty defs _ -> Left (I.help displayTo) docs :: InputPattern @@ -488,13 +996,7 @@ docs = "`docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH." ] ) - ( \case - x : xs -> - (x NE.:| xs) - & traverse Path.parseHQSplit' - & bimap P.text Input.DocsI - _ -> Left (I.help docs) - ) + $ maybe (Left $ I.help docs) (fmap Input.DocsI . traverse handleNameArg) . NE.nonEmpty api :: InputPattern api = @@ -516,9 +1018,7 @@ ui = help = P.wrap "`ui` opens the Local UI in the default browser.", parse = \case [] -> pure $ Input.UiI Path.relativeEmpty' - [path] -> first P.text $ do - p <- Path.parsePath' path - pure $ Input.UiI p + [path] -> Input.UiI <$> handlePath'Arg path _ -> Left (I.help ui) } @@ -532,23 +1032,13 @@ undo = "`undo` reverts the most recent change to the codebase." (const $ pure Input.UndoI) -viewByPrefix :: InputPattern -viewByPrefix = - InputPattern - "view.recursive" - [] - I.Visible - [("definition to view", OnePlus, definitionQueryArg)] - "`view.recursive Foo` prints the definitions of `Foo` and `Foo.blah`." - ( fmap (Input.ShowDefinitionByPrefixI Input.ConsoleLocation) - . traverse parseHashQualifiedName - ) - sfind :: InputPattern sfind = InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse where - parse [q] = Input.StructuredFindI (Input.FindLocal Path.empty) <$> parseHashQualifiedName q + parse [q] = + Input.StructuredFindI (Input.FindLocal Path.empty) + <$> handleHashQualifiedNameArg q parse _ = Left "expected exactly one argument" msg = P.lines @@ -579,7 +1069,7 @@ sfindReplace :: InputPattern sfindReplace = InputPattern "rewrite" ["sfind.replace"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse where - parse [q] = Input.StructuredFindReplaceI <$> parseHashQualifiedName q + parse [q] = Input.StructuredFindReplaceI <$> handleHashQualifiedNameArg q parse _ = Left "expected exactly one argument" msg :: P.Pretty CT.ColorText msg = @@ -627,9 +1117,7 @@ findIn' cmd mkfscope = [("namespace", Required, namespaceArg), ("query", ZeroPlus, exactDefinitionArg)] findHelp \case - p : args -> first P.text do - p <- Path.parsePath p - pure (Input.FindI False (mkfscope p) args) + p : args -> Input.FindI False . mkfscope <$> handlePathArg p <*> pure (unifyArgument <$> args) _ -> Left findHelp findHelp :: P.Pretty CT.ColorText @@ -676,7 +1164,7 @@ find' cmd fscope = I.Visible [("query", ZeroPlus, exactDefinitionArg)] findHelp - (pure . Input.FindI False fscope) + (pure . Input.FindI False fscope . fmap unifyArgument) findShallow :: InputPattern findShallow = @@ -691,11 +1179,9 @@ findShallow = ("`list .foo`", "lists the '.foo' namespace.") ] ) - ( \case - [] -> pure $ Input.FindShallowI Path.relativeEmpty' - [path] -> first P.text $ do - p <- Path.parsePath' path - pure $ Input.FindShallowI p + ( fmap Input.FindShallowI . \case + [] -> pure Path.relativeEmpty' + [path] -> handlePath'Arg path _ -> Left (I.help findShallow) ) @@ -709,7 +1195,7 @@ findVerbose = ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True (Input.FindLocal Path.empty)) + (pure . Input.FindI True (Input.FindLocal Path.empty) . fmap unifyArgument) findVerboseAll :: InputPattern findVerboseAll = @@ -721,19 +1207,7 @@ findVerboseAll = ( "`find.all.verbose` searches for definitions like `find.all`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty)) - -findPatch :: InputPattern -findPatch = - InputPattern - "find.patch" - ["list.patch", "ls.patch"] - I.Visible - [] - ( P.wrapColumn2 - [("`find.patch`", "lists all patches in the current namespace.")] - ) - (pure . const Input.FindPatchI) + (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty) . fmap unifyArgument) renameTerm :: InputPattern renameTerm = @@ -745,16 +1219,9 @@ renameTerm = ("new location", Required, newNameArg) ] "`move.term foo bar` renames `foo` to `bar`." - ( \case - [oldName, newName] -> first P.text do - src <- Path.parseHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.MoveTermI src target - _ -> - Left . P.warnCallout $ - P.wrap - "`rename.term` takes two arguments, like `rename.term oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveTermI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName + _ -> Left . P.warnCallout $ P.wrap "`rename.term` takes two arguments, like `rename.term oldname newname`." moveAll :: InputPattern moveAll = @@ -766,16 +1233,9 @@ moveAll = ("new location", Required, newNameArg) ] "`move foo bar` renames the term, type, and namespace foo to bar." - ( \case - [oldName, newName] -> first P.text $ do - src <- Path.parsePath' oldName - target <- Path.parsePath' newName - pure $ Input.MoveAllI src target - _ -> - Left . P.warnCallout $ - P.wrap - "`move` takes two arguments, like `move oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveAllI <$> handlePath'Arg oldName <*> handleNewPath newName + _ -> Left . P.warnCallout $ P.wrap "`move` takes two arguments, like `move oldname newname`." renameType :: InputPattern renameType = @@ -787,16 +1247,10 @@ renameType = ("new location", Required, newNameArg) ] "`move.type foo bar` renames `foo` to `bar`." - ( \case - [oldName, newName] -> first P.text do - src <- Path.parseHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.MoveTypeI src target - _ -> - Left . P.warnCallout $ - P.wrap - "`rename.type` takes two arguments, like `rename.type oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveTypeI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName + _ -> + Left . P.warnCallout $ P.wrap "`rename.type` takes two arguments, like `rename.type oldname newname`." deleteGen :: Maybe String -> ArgumentType -> String -> ([Path.HQSplit'] -> DeleteTarget) -> InputPattern deleteGen suffix queryCompletionArg target mkTarget = @@ -835,12 +1289,9 @@ deleteGen suffix queryCompletionArg target mkTarget = I.Visible [("definition to delete", OnePlus, queryCompletionArg)] info - ( \case - [] -> Left . P.warnCallout $ P.wrap warn - queries -> first P.text do - paths <- traverse Path.parseHQSplit' queries - pure $ Input.DeleteI (mkTarget paths) - ) + \case + [] -> Left . P.warnCallout $ P.wrap warn + queries -> Input.DeleteI . mkTarget <$> traverse handleHashQualifiedSplit'Arg queries delete :: InputPattern delete = deleteGen Nothing exactDefinitionTypeOrTermQueryArg "term or type" (DeleteTarget'TermOrType DeleteOutput'NoDiff) @@ -860,54 +1311,6 @@ deleteType = deleteGen (Just "type") exactDefinitionTypeQueryArg "type" (DeleteT deleteTypeVerbose :: InputPattern deleteTypeVerbose = deleteGen (Just "type.verbose") exactDefinitionTypeQueryArg "type" (DeleteTarget'Type DeleteOutput'Diff) -deleteTermReplacementCommand :: String -deleteTermReplacementCommand = "delete.term-replacement" - -deleteTypeReplacementCommand :: String -deleteTypeReplacementCommand = "delete.type-replacement" - -deleteReplacement :: Bool -> InputPattern -deleteReplacement isTerm = - InputPattern - commandName - [] - I.Visible - [("definition", Required, if isTerm then exactDefinitionTermQueryArg else exactDefinitionTypeQueryArg), ("patch", Optional, patchArg)] - ( P.string $ - commandName - <> " ` removes any edit of the " - <> str - <> " `foo` from the patch `patch`, " - <> "or from the default patch if none is specified. Note that `foo` refers to the " - <> "original name for the " - <> str - <> " - not the one in place after the edit." - ) - ( \case - query : patch -> do - patch <- first P.text . traverse Path.parseSplit' $ listToMaybe patch - q <- parseHashQualifiedName query - pure $ input q patch - _ -> - Left - . P.warnCallout - . P.wrapString - $ commandName - <> " needs arguments. See `help " - <> commandName - <> "`." - ) - where - input = - if isTerm - then Input.RemoveTermReplacementI - else Input.RemoveTypeReplacementI - str = if isTerm then "term" else "type" - commandName = - if isTerm - then deleteTermReplacementCommand - else deleteTypeReplacementCommand - deleteProject :: InputPattern deleteProject = InputPattern @@ -920,9 +1323,7 @@ deleteProject = [ ("`delete.project foo`", "deletes the local project `foo`") ], parse = \case - [name] - | Right project <- tryInto @ProjectName (Text.pack name) -> - Right (Input.DeleteI (DeleteTarget'Project project)) + [name] -> Input.DeleteI . DeleteTarget'Project <$> handleProjectArg name _ -> Left (showPatternHelp deleteProject) } @@ -939,10 +1340,7 @@ deleteBranch = ("`delete.branch /bar`", "deletes the branch `bar` in the current project") ], parse = \case - [name] -> - case tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) of - Left _ -> Left (showPatternHelp deleteBranch) - Right projectAndBranch -> Right (Input.DeleteI (DeleteTarget'ProjectBranch projectAndBranch)) + [name] -> Input.DeleteI . DeleteTarget'ProjectBranch <$> handleMaybeProjectBranchArg name _ -> Left (showPatternHelp deleteBranch) } where @@ -953,12 +1351,6 @@ deleteBranch = branchInclusion = AllBranches } -deleteTermReplacement :: InputPattern -deleteTermReplacement = deleteReplacement True - -deleteTypeReplacement :: InputPattern -deleteTypeReplacement = deleteReplacement False - aliasTerm :: InputPattern aliasTerm = InputPattern @@ -967,15 +1359,9 @@ aliasTerm = I.Visible [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)] "`alias.term foo bar` introduces `bar` with the same definition as `foo`." - \case - [oldName, newName] -> first P.text do - source <- Path.parseShortHashOrHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.AliasTermI source target - _ -> - Left . warn $ - P.wrap - "`alias.term` takes two arguments, like `alias.term oldname newname`." + $ \case + [oldName, newName] -> Input.AliasTermI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> Left . warn $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`." aliasType :: InputPattern aliasType = @@ -986,14 +1372,8 @@ aliasType = [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)] "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." \case - [oldName, newName] -> first P.text do - source <- Path.parseShortHashOrHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.AliasTypeI source target - _ -> - Left . warn $ - P.wrap - "`alias.type` takes two arguments, like `alias.type oldname newname`." + [oldName, newName] -> Input.AliasTypeI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> Left . warn $ P.wrap "`alias.type` takes two arguments, like `alias.type oldname newname`." aliasMany :: InputPattern aliasMany = @@ -1012,10 +1392,8 @@ aliasMany = ] ) \case - srcs@(_ : _) Cons.:> dest -> first P.text do - sourceDefinitions <- traverse Path.parseHQSplit srcs - destNamespace <- Path.parsePath' dest - pure $ Input.AliasManyI sourceDefinitions destNamespace + srcs@(_ : _) Cons.:> dest -> + Input.AliasManyI <$> traverse handleHashQualifiedSplitArg srcs <*> handlePath'Arg dest _ -> Left (I.help aliasMany) up :: InputPattern @@ -1026,10 +1404,9 @@ up = I.Hidden [] (P.wrapColumn2 [(makeExample up [], "move current path up one level (deprecated)")]) - ( \case - [] -> Right Input.UpI - _ -> Left (I.help up) - ) + \case + [] -> Right Input.UpI + _ -> Left (I.help up) cd :: InputPattern cd = @@ -1058,10 +1435,8 @@ cd = ] ) \case - [".."] -> Right Input.UpI - [p] -> first P.text do - p <- Path.parsePath' p - pure . Input.SwitchBranchI $ p + [Left ".."] -> Right Input.UpI + [p] -> Input.SwitchBranchI <$> handlePath'Arg p _ -> Left (I.help cd) back :: InputPattern @@ -1103,67 +1478,12 @@ deleteNamespaceForce = ) (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force) -deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> [String] -> Either (P.Pretty CT.ColorText) Input +deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input deleteNamespaceParser helpText insistence = \case - ["."] -> - first fromString - . pure - $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) - [p] -> first P.text do - p <- Path.parseSplit' p - pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p)) + [Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) + [p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p _ -> Left helpText -deletePatch :: InputPattern -deletePatch = - InputPattern - "delete.patch" - [] - I.Visible - [("patch to delete", Required, patchArg)] - "`delete.patch ` deletes the patch `foo`" - \case - [p] -> first P.text do - p <- Path.parseSplit' p - pure . Input.DeleteI $ DeleteTarget'Patch p - _ -> Left (I.help deletePatch) - -movePatch :: String -> String -> Either (P.Pretty CT.ColorText) Input -movePatch src dest = first P.text do - src <- Path.parseSplit' src - dest <- Path.parseSplit' dest - pure $ Input.MovePatchI src dest - -copyPatch' :: String -> String -> Either (P.Pretty CT.ColorText) Input -copyPatch' src dest = first P.text do - src <- Path.parseSplit' src - dest <- Path.parseSplit' dest - pure $ Input.CopyPatchI src dest - -copyPatch :: InputPattern -copyPatch = - InputPattern - "copy.patch" - [] - I.Visible - [("patch to copy", Required, patchArg), ("copy destination", Required, newNameArg)] - "`copy.patch foo bar` copies the patch `foo` to `bar`." - \case - [src, dest] -> copyPatch' src dest - _ -> Left (I.help copyPatch) - -renamePatch :: InputPattern -renamePatch = - InputPattern - "move.patch" - ["rename.patch"] - I.Visible - [("patch", Required, patchArg), ("new location", Required, newNameArg)] - "`move.patch foo bar` renames the patch `foo` to `bar`." - \case - [src, dest] -> movePatch src dest - _ -> Left (I.help renamePatch) - renameBranch :: InputPattern renameBranch = InputPattern @@ -1173,10 +1493,7 @@ renameBranch = [("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)] "`move.namespace foo bar` renames the path `foo` to `bar`." \case - [src, dest] -> first P.text do - src <- Path.parsePath' src - dest <- Path.parsePath' dest - pure $ Input.MoveBranchI src dest + [src, dest] -> Input.MoveBranchI <$> handlePath'Arg src <*> handlePath'Arg dest _ -> Left (I.help renameBranch) history :: InputPattern @@ -1196,9 +1513,7 @@ history = ] ) \case - [src] -> first P.text do - p <- Input.parseBranchId src - pure $ Input.HistoryI (Just 10) (Just 10) p + [src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) _ -> Left (I.help history) @@ -1224,10 +1539,7 @@ forkLocal = ] ) \case - [src, dest] -> do - src <- Input.parseBranchId2 src - dest <- parseBranchRelativePath dest - pure $ Input.ForkLocalBranchI src dest + [src, dest] -> Input.ForkLocalBranchI <$> handleBranchId2Arg src <*> handleBranchRelativePathArg dest _ -> Left (I.help forkLocal) libInstallInputPattern :: InputPattern @@ -1238,18 +1550,27 @@ libInstallInputPattern = visibility = I.Visible, args = [], help = - P.wrapColumn2 - [ ( makeExample libInstallInputPattern ["@unison/base/releases/latest"], - "installs `@unison/base/releases/latest` as a dependency of the current project" - ) + P.lines + [ P.wrap $ + "The" + <> makeExample' libInstallInputPattern + <> "command installs a dependency into the `lib` namespace.", + "", + P.wrapColumn2 + [ ( makeExample libInstallInputPattern ["@unison/base/releases/latest"], + "installs the latest release of `@unison/base`" + ), + ( makeExample libInstallInputPattern ["@unison/base/releases/3.0.0"], + "installs version 3.0.0 of `@unison/base`" + ), + ( makeExample libInstallInputPattern ["@unison/base/topic"], + "installs the `topic` branch of `@unison/base`" + ) + ] ], - parse = \args -> - maybe (Left (I.help libInstallInputPattern)) Right do - [arg] <- Just args - libdep <- - eitherToMaybe $ - tryInto @(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) (Text.pack arg) - Just (Input.LibInstallI libdep) + parse = \case + [arg] -> Input.LibInstallI <$> handleProjectMaybeBranchArg arg + _ -> Left (I.help libInstallInputPattern) } reset :: InputPattern @@ -1268,32 +1589,11 @@ reset = ("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.") ] ) - ( maybeToEither (I.help reset) . \case - arg0 : restArgs -> do - arg0 <- branchIdOrProject arg0 - arg1 <- case restArgs of - [] -> pure Nothing - arg1 : [] -> Just <$> parseLooseCodeOrProject arg1 - _ -> Nothing - Just (Input.ResetI arg0 arg1) - _ -> Nothing - ) + \case + [arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing + [arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1) + _ -> Left $ I.help reset where - branchIdOrProject :: - String -> - Maybe - ( These - Input.BranchId - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) - branchIdOrProject str = - let branchIdRes = Input.parseBranchId str - projectRes = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack str) - in case (branchIdRes, projectRes) of - (Left _, Left _) -> Nothing - (Left _, Right pr) -> Just (That pr) - (Right bid, Left _) -> Just (This bid) - (Right bid, Right pr) -> Just (These bid pr) config = ProjectBranchSuggestionsConfig { showProjectCompletions = False, @@ -1322,30 +1622,24 @@ resetRoot = ] ] ) - \case - [src] -> first P.text $ do - src <- Input.parseBranchId src - pure $ Input.ResetRootI src + $ \case + [src] -> Input.ResetRootI <$> handleBranchIdArg src _ -> Left (I.help resetRoot) pull :: InputPattern pull = - pullImpl "pull" ["pull.silent"] Verbosity.Silent Input.PullWithHistory "without listing the merged entities" - -pullVerbose :: InputPattern -pullVerbose = pullImpl "pull.verbose" [] Verbosity.Verbose Input.PullWithHistory "and lists the merged entities" + pullImpl "pull" [] Input.PullWithHistory "" pullWithoutHistory :: InputPattern pullWithoutHistory = pullImpl "pull.without-history" [] - Verbosity.Silent Input.PullWithoutHistory "without including the remote's history. This usually results in smaller codebase sizes." -pullImpl :: String -> [String] -> Verbosity -> Input.PullMode -> P.Pretty CT.ColorText -> InputPattern -pullImpl name aliases verbosity pullMode addendum = do +pullImpl :: String -> [String] -> Input.PullMode -> P.Pretty CT.ColorText -> InputPattern +pullImpl name aliases pullMode addendum = do self where self = @@ -1353,57 +1647,84 @@ pullImpl name aliases verbosity pullMode addendum = do { patternName = name, aliases = aliases, visibility = I.Visible, - args = [("remote location to pull", Optional, remoteNamespaceArg), ("destination namespace", Optional, namespaceArg)], + args = + [ ("remote namespace to pull", Optional, remoteNamespaceArg), + ( "destination branch", + Optional, + projectBranchNameArg + ProjectBranchSuggestionsConfig + { showProjectCompletions = False, + projectInclusion = AllProjects, + branchInclusion = AllBranches + } + ) + ], help = P.lines [ P.wrap $ "The" <> makeExample' self - <> "command merges a remote namespace into a local namespace" + <> "command merges a remote namespace into a local branch" <> addendum, "", P.wrapColumn2 [ ( makeExample self ["@unison/base/main"], "merges the branch `main`" <> "of the Unison Share hosted project `@unison/base`" - <> "into the current namespace" + <> "into the current branch" ), ( makeExample self ["@unison/base/main", "my-base/topic"], "merges the branch `main`" <> "of the Unison Share hosted project `@unison/base`" <> "into the branch `topic` of the local `my-base` project" - ), - ( makeExample self ["remote", "local"], - "merges the remote namespace `remote`" - <> "into the local namespace `local" - ), - ( makeExample self ["remote"], - "merges the remote namespace `remote`" - <> "into the current namespace" - ), - ( makeExample' self, - "merges the remote namespace configured in `.unisonConfig`" - <> "at the key `RemoteMappings.` where `` is the current namespace," ) ], "", explainRemote Pull ], parse = - maybeToEither (I.help self) . \case - [] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 pullMode verbosity - [sourceString] -> do - source <- parsePullSource (Text.pack sourceString) - Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) pullMode verbosity - [sourceString, targetString] -> do - source <- parsePullSource (Text.pack sourceString) - target <- parseLooseCodeOrProject targetString - Just $ - Input.PullRemoteBranchI - (Input.PullSourceTarget2 source target) - pullMode - verbosity - _ -> Nothing + fmap + (flip Input.PullI pullMode) + . ( \case + [] -> pure $ Input.PullSourceTarget0 + [sourceString] -> + bimap (\err -> I.help self <> P.newline <> err) Input.PullSourceTarget1 $ + handlePullSourceArg sourceString + [sourceString, targetString] -> + Input.PullSourceTarget2 + <$> first (\err -> I.help self <> P.newline <> err) (handlePullSourceArg sourceString) + <*> first + ( \err -> + -- You used to be able to pull into a path. So if target parsing fails, but path parsing succeeds, + -- explain that the command has changed. Furthermore, in the special case that the user is trying to + -- pull into the `lib` namespace, suggest using `lib.install`. + case handlePath'Arg targetString of + Left _ -> I.help self <> P.newline <> err + Right path -> + I.help self + <> P.newline + <> P.newline + <> P.newline + <> let pullingIntoLib = + case path of + Path.RelativePath' + ( Path.Relative + (Path.toList -> lib : _) + ) -> lib == NameSegment.libSegment + _ -> False + in P.wrap $ + "You may only" + <> makeExample' pull + <> "into a branch." + <> if pullingIntoLib + then + "Did you mean to run" + <> P.group (makeExample libInstallInputPattern [P.string $ unifyArgument sourceString] <> "?") + else mempty + ) + (handleMaybeProjectBranchArg targetString) + _ -> Left $ I.help self + ) } debugTabCompletion :: InputPattern @@ -1418,9 +1739,7 @@ debugTabCompletion = P.wrap $ "Completions which are finished are prefixed with a * represent finished completions." ] ) - ( \inputs -> - Right $ Input.DebugTabCompletionI inputs - ) + (fmap Input.DebugTabCompletionI . traverse (unsupportedStructuredArgument "text")) debugFuzzyOptions :: InputPattern debugFuzzyOptions = @@ -1439,7 +1758,9 @@ debugFuzzyOptions = ) \case (cmd : args) -> - Right $ Input.DebugFuzzyOptionsI cmd args + Input.DebugFuzzyOptionsI + <$> unsupportedStructuredArgument "a command" cmd + <*> traverse (unsupportedStructuredArgument "text") args _ -> Left (I.help debugFuzzyOptions) debugFormat :: InputPattern @@ -1490,24 +1811,20 @@ push = explainRemote Push ] ) - \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help push) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireNonEmpty - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireNonEmpty + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr + [targetStr, sourceStr] -> + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr + _ -> Left (I.help push) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1545,24 +1862,20 @@ pushCreate = explainRemote Push ] ) - \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushForce) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireEmpty - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireEmpty + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr + [targetStr, sourceStr] -> + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr + _ -> Left (I.help pushForce) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1579,24 +1892,20 @@ pushForce = I.Hidden [("remote destination", Optional, remoteNamespaceArg), ("local source", Optional, namespaceOrProjectBranchArg suggestionsConfig)] (P.wrap "Like `push`, but overwrites any remote namespace.") - \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushForce) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.ForcePush - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.ForcePush + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr + [targetStr, sourceStr] -> + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr + _ -> Left (I.help pushForce) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1623,24 +1932,20 @@ pushExhaustive = <> "versions M1l and earlier. It may be extra slow!" ] ) - \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushExhaustive) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireNonEmpty - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireNonEmpty + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr + [targetStr, sourceStr] -> + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr + _ -> Left (I.help pushExhaustive) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1666,13 +1971,13 @@ mergeOldSquashInputPattern = <> "discarding the history of `src` in the process." <> "The resulting `dest` will have (at most) 1" <> "additional history entry.", - parse = - maybeToEither (I.help mergeOldSquashInputPattern) . \case - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge - _ -> Nothing + parse = \case + [src, dest] -> + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + <*> pure Branch.SquashMerge + _ -> Left $ I.help mergeOldSquashInputPattern } where suggestionsConfig = @@ -1712,15 +2017,18 @@ mergeOldInputPattern = ) ] ) - ( maybeToEither (I.help mergeOldInputPattern) . \case - [src] -> do - src <- parseLooseCodeOrProject src - Just $ Input.MergeLocalBranchI src (This Path.relativeEmpty') Branch.RegularMerge - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.RegularMerge - _ -> Nothing + ( \case + [src] -> + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> pure (This Path.relativeEmpty') + <*> pure Branch.RegularMerge + [src, dest] -> + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + <*> pure Branch.RegularMerge + _ -> Left $ I.help mergeOldInputPattern ) where config = @@ -1749,15 +2057,10 @@ mergeInputPattern = ], help = P.wrap $ makeExample mergeInputPattern ["/branch"] <> "merges `branch` into the current branch", parse = - \args -> - maybeToEither (I.help mergeInputPattern) do - [branchString] <- Just args - branch <- - eitherToMaybe $ - tryInto - @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - (Text.pack branchString) - pure (Input.MergeI branch) + \case + [branchString] -> + Input.MergeI <$> handleMaybeProjectBranchArg branchString + _ -> Left $ I.help mergeInputPattern } parseLooseCodeOrProject :: String -> Maybe Input.LooseCodeOrProject @@ -1788,13 +2091,8 @@ diffNamespace = ] ) ( \case - [before, after] -> first P.text do - before <- Input.parseBranchId before - after <- Input.parseBranchId after - pure $ Input.DiffNamespaceI before after - [before] -> first P.text do - before <- Input.parseBranchId before - pure $ Input.DiffNamespaceI before (Right Path.currentPath) + [before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after + [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (pure Path.currentPath) _ -> Left $ I.help diffNamespace ) where @@ -1821,15 +2119,11 @@ mergeOldPreviewInputPattern = ) ] ) - ( maybeToEither (I.help mergeOldPreviewInputPattern) . \case - [src] -> do - src <- parseLooseCodeOrProject src - pure $ Input.PreviewMergeLocalBranchI src (This Path.relativeEmpty') - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - pure $ Input.PreviewMergeLocalBranchI src dest - _ -> Nothing + ( \case + [src] -> Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> pure (This Path.relativeEmpty') + [src, dest] -> + Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> handleLooseCodeOrProjectArg dest + _ -> Left $ I.help mergeOldPreviewInputPattern ) where suggestionsConfig = @@ -1839,45 +2133,6 @@ mergeOldPreviewInputPattern = branchInclusion = AllBranches } -replaceEdit :: - ( HQ.HashQualified Name -> - HQ.HashQualified Name -> - Maybe Input.PatchPath -> - Input - ) -> - InputPattern -replaceEdit f = self - where - self = - InputPattern - "replace" - [] - I.Visible - [ ("definition to replace", Required, definitionQueryArg), - ("definition replacement", Required, definitionQueryArg), - ("patch", Optional, patchArg) - ] - ( P.wrapColumn2 - [ ( makeExample self ["", "", ""], - "Replace the term/type in the given patch with the term/type ." - ), - ( makeExample self ["", ""], - "Replace the term/type with in the default patch." - ) - ] - ) - ( \case - source : target : patch -> do - patch <- first P.text <$> traverse Path.parseSplit' $ listToMaybe patch - sourcehq <- parseHashQualifiedName source - targethq <- parseHashQualifiedName target - pure $ f sourcehq targethq patch - _ -> Left $ I.help self - ) - -replace :: InputPattern -replace = replaceEdit Input.ReplaceI - viewReflog :: InputPattern viewReflog = InputPattern @@ -1907,12 +2162,12 @@ edit = "`edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH." ], parse = - \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal) - [] -> Left (I.help edit) + maybe + (Left $ I.help edit) + ( fmap (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty } editNamespace :: InputPattern @@ -1927,7 +2182,7 @@ editNamespace = [ "`edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries.", "`edit.namespace ns1 ns2 ...` loads the terms and types contained within the provided namespaces." ], - parse = Right . Input.EditNamespaceI . fmap (Path.unsafeParseText . Text.pack) + parse = fmap Input.EditNamespaceI . traverse handlePathArg } topicNameArg :: ArgumentType @@ -1935,18 +2190,10 @@ topicNameArg = let topics = Map.keys helpTopicsMap in ArgumentType { typeName = "topic", - suggestions = \q _ _ _ -> pure (exactComplete q $ topics), + suggestions = \q _ _ _ -> pure (exactComplete q topics), fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> topics) } -codebaseServerNameArg :: ArgumentType -codebaseServerNameArg = - ArgumentType - { typeName = "codebase-server", - suggestions = \_ _ _ _ -> pure [], - fzfResolver = Nothing - } - helpTopics :: InputPattern helpTopics = InputPattern @@ -1957,9 +2204,11 @@ helpTopics = ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") ( \case [] -> Left topics - [topic] -> case Map.lookup topic helpTopicsMap of - Nothing -> Left . warn $ "I don't know of that topic. Try `help-topics`." - Just t -> Left t + [topic] -> do + topic <- unsupportedStructuredArgument "a help topic" topic + case Map.lookup topic helpTopicsMap of + Nothing -> Left . warn $ "I don't know of that topic. Try `help-topics`." + Just t -> Left t _ -> Left $ warn "Use `help-topics ` or `help-topics`." ) where @@ -2137,14 +2386,15 @@ help = I.Visible [("command", Optional, commandNameArg)] "`help` shows general help and `help ` shows help for one command." - \case + $ \case [] -> Left $ intercalateMap "\n\n" showPatternHelp visibleInputs - [cmd] -> + [cmd] -> do + cmd <- unsupportedStructuredArgument "a command" cmd case (Map.lookup cmd commandsByName, isHelp cmd) of (Nothing, Just msg) -> Left msg (Nothing, Nothing) -> Left . warn $ "I don't know of that command. Try `help`." @@ -2183,29 +2433,6 @@ quit = [] -> pure Input.QuitI _ -> Left "Use `quit`, `exit`, or to quit." -viewPatch :: InputPattern -viewPatch = - InputPattern - "view.patch" - [] - I.Visible - [("patch", Optional, patchArg)] - ( P.wrapColumn2 - [ ( makeExample' viewPatch, - "Lists all the edits in the default patch." - ), - ( makeExample viewPatch [""], - "Lists all the edits in the given patch." - ) - ] - ) - \case - [] -> Right $ Input.ListEditsI Nothing - [patchStr] -> mapLeft P.text do - patch <- Path.parseSplit' patchStr - Right $ Input.ListEditsI (Just patch) - _ -> Left $ warn "`view.patch` takes a patch and that's it." - names :: Input.IsGlobal -> InputPattern names isGlobal = InputPattern @@ -2214,13 +2441,8 @@ names isGlobal = I.Visible [("name or hash", Required, definitionQueryArg)] (P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.") - \case - [thing] -> case HQ.parseText (Text.pack thing) of - Just hq -> Right $ Input.NamesI isGlobal hq - Nothing -> - Left $ - "I was looking for one of these forms: " - <> P.blue "foo .foo.bar foo#abc #abcde .foo.bar#asdf" + $ \case + [thing] -> Input.NamesI isGlobal <$> handleHashQualifiedNameArg thing _ -> Left (I.help (names isGlobal)) where cmdName = if isGlobal then "names.global" else "names" @@ -2233,8 +2455,8 @@ dependents = I.Visible [("definition", Required, definitionQueryArg)] "List the named dependents of the specified definition." - \case - [thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing + $ \case + [thing] -> Input.ListDependentsI <$> handleHashQualifiedNameArg thing _ -> Left (I.help dependents) dependencies = InputPattern @@ -2243,8 +2465,8 @@ dependencies = I.Visible [("definition", Required, definitionQueryArg)] "List the dependencies of the specified definition." - \case - [thing] -> fmap Input.ListDependenciesI $ parseHashQualifiedName thing + $ \case + [thing] -> Input.ListDependenciesI <$> handleHashQualifiedNameArg thing _ -> Left (I.help dependencies) namespaceDependencies :: InputPattern @@ -2255,10 +2477,8 @@ namespaceDependencies = I.Visible [("namespace", Optional, namespaceArg)] "List the external dependencies of the specified namespace." - \case - [p] -> first P.text do - p <- Path.parsePath' p - pure $ Input.NamespaceDependenciesI (Just p) + $ \case + [p] -> Input.NamespaceDependenciesI . pure <$> handlePath'Arg p [] -> pure (Input.NamespaceDependenciesI Nothing) _ -> Left (I.help namespaceDependencies) @@ -2311,7 +2531,7 @@ debugTerm = [("term", Required, exactDefinitionTermQueryArg)] "View debugging information for a given term." ( \case - [thing] -> fmap (Input.DebugTermI False) $ parseHashQualifiedName thing + [thing] -> Input.DebugTermI False <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugTerm) ) @@ -2324,7 +2544,7 @@ debugTermVerbose = [("term", Required, exactDefinitionTermQueryArg)] "View verbose debugging information for a given term." ( \case - [thing] -> fmap (Input.DebugTermI True) $ parseHashQualifiedName thing + [thing] -> Input.DebugTermI True <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugTermVerbose) ) @@ -2337,7 +2557,7 @@ debugType = [("type", Required, exactDefinitionTypeQueryArg)] "View debugging information for a given type." ( \case - [thing] -> fmap (Input.DebugTypeI) $ parseHashQualifiedName thing + [thing] -> Input.DebugTypeI <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugType) ) @@ -2383,14 +2603,9 @@ debugNameDiff = visibility = I.Hidden, args = [("before namespace", Required, namespaceArg), ("after namespace", Required, namespaceArg)], help = P.wrap "List all name changes between two causal hashes. Does not detect patch changes.", - parse = - ( \case - [from, to] -> first fromString $ do - fromSCH <- Input.parseShortCausalHash from - toSCH <- Input.parseShortCausalHash to - pure $ Input.DebugNameDiffI fromSCH toSCH - _ -> Left (I.help debugNameDiff) - ) + parse = \case + [from, to] -> Input.DebugNameDiffI <$> handleShortCausalHashArg from <*> handleShortCausalHashArg to + _ -> Left (I.help debugNameDiff) } test :: InputPattern @@ -2405,21 +2620,21 @@ test = [ ("`test`", "runs unit tests for the current branch"), ("`test foo`", "runs unit tests for the current branch defined in namespace `foo`") ], - parse = \args -> - maybe (Left (I.help test)) Right do - path <- - case args of - [] -> Just Path.empty - [pathString] -> eitherToMaybe $ Path.parsePath pathString - _ -> Nothing - Just $ - Input.TestI - Input.TestInput - { includeLibNamespace = False, - path, - showFailures = True, - showSuccesses = True - } + parse = + fmap + ( \path -> + Input.TestI + Input.TestInput + { includeLibNamespace = False, + path, + showFailures = True, + showSuccesses = True + } + ) + . \case + [] -> pure Path.empty + [pathString] -> handlePathArg pathString + _ -> Left $ I.help test } testAll :: InputPattern @@ -2456,9 +2671,10 @@ docsToHtml = ] ) \case - [namespacePath, destinationFilePath] -> first P.text do - np <- Path.parsePath' namespacePath - pure $ Input.DocsToHtmlI np destinationFilePath + [namespacePath, destinationFilePath] -> + Input.DocsToHtmlI + <$> handlePath'Arg namespacePath + <*> unsupportedStructuredArgument "a file name" destinationFilePath _ -> Left $ showPatternHelp docsToHtml docToMarkdown :: InputPattern @@ -2475,9 +2691,7 @@ docToMarkdown = ] ) \case - [docNameText] -> first fromString $ do - docName <- maybeToEither "Invalid name" . Name.parseText . Text.pack $ docNameText - pure $ Input.DocToMarkdownI docName + [docNameText] -> Input.DocToMarkdownI <$> handleNameArg docNameText _ -> Left $ showPatternHelp docToMarkdown execute :: InputPattern @@ -2496,9 +2710,11 @@ execute = ) ] ) - \case - [w] -> pure $ Input.ExecuteI (Text.pack w) [] - w : ws -> pure $ Input.ExecuteI (Text.pack w) ws + $ \case + main : args -> + Input.ExecuteI + <$> handleHashQualifiedNameArg main + <*> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp execute saveExecuteResult :: InputPattern @@ -2511,8 +2727,8 @@ saveExecuteResult = ( "`add.run name` adds to the codebase the result of the most recent `run` command" <> "as `name`." ) - \case - [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeParseText (Text.pack w)) + $ \case + [w] -> Input.SaveExecuteResultI <$> handleNameArg w _ -> Left $ showPatternHelp saveExecuteResult ioTest :: InputPattern @@ -2529,7 +2745,7 @@ ioTest = ) ], parse = \case - [thing] -> fmap Input.IOTestI $ parseHashQualifiedName thing + [thing] -> Input.IOTestI <$> handleHashQualifiedNameArg thing _ -> Left $ showPatternHelp ioTest } @@ -2566,9 +2782,11 @@ makeStandalone = ) ] ) - \case + $ \case [main, file] -> - Input.MakeStandaloneI file <$> parseHashQualifiedName main + Input.MakeStandaloneI + <$> unsupportedStructuredArgument "a file name" file + <*> handleHashQualifiedNameArg main _ -> Left $ showPatternHelp makeStandalone runScheme :: InputPattern @@ -2584,8 +2802,11 @@ runScheme = ) ] ) - \case - main : args -> Right $ Input.ExecuteSchemeI (Text.pack main) args + $ \case + main : args -> + Input.ExecuteSchemeI + <$> handleHashQualifiedNameArg main + <*> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp runScheme compileScheme :: InputPattern @@ -2603,9 +2824,11 @@ compileScheme = ) ] ) - \case + $ \case [main, file] -> - Input.CompileSchemeI (Text.pack file) <$> parseHashQualifiedName main + Input.CompileSchemeI . Text.pack + <$> unsupportedStructuredArgument "a file name" file + <*> handleHashQualifiedNameArg main _ -> Left $ showPatternHelp compileScheme createAuthor :: InputPattern @@ -2626,54 +2849,26 @@ createAuthor = <> backtick (P.group ("metadata.copyrightHolders" <> ".")) ) ) - ( \case - symbolStr : authorStr@(_ : _) -> first P.text do - symbol <- - Megaparsec.runParser (Megaparsec.withParsecT (fmap NameSegment.renderParseErr) NameSegment.segmentP <* Megaparsec.eof) "" symbolStr - & mapLeft (Text.pack . Megaparsec.errorBundlePretty) - -- let's have a real parser in not too long - let author :: Text - author = Text.pack $ case (unwords authorStr) of - quoted@('"' : _) -> (init . tail) quoted - bare -> bare - pure $ Input.CreateAuthorI symbol author - _ -> Left $ showPatternHelp createAuthor - ) - -gist :: InputPattern -gist = - InputPattern - "push.gist" - ["gist"] - I.Visible - [("repository", Required, gitUrlArg)] - ( P.lines - [ "Publish the current namespace.", - "", - P.wrapColumn2 - [ ( "`gist git(git@github.com:user/repo)`", - "publishes the contents of the current namespace into the specified git repo." - ) - ], - "", - P.indentN 2 . P.wrap $ - "Note: Gists are not yet supported on Unison Share, though you can just do a normal" - <> "`push.create` of the current namespace to your Unison Share codebase wherever you like!" - ] - ) - ( \case - [repoString] -> do - repo <- parseWriteGitRepo "gist git repo" repoString - pure (Input.GistI (Input.GistInput repo)) - _ -> Left (showPatternHelp gist) - ) + \case + symbolStr : authorStr@(_ : _) -> + Input.CreateAuthorI + <$> handleRelativeNameSegmentArg symbolStr + <*> fmap (parseAuthorName . unwords) (traverse (unsupportedStructuredArgument "text") authorStr) + _ -> Left $ showPatternHelp createAuthor + where + -- let's have a real parser in not too long + parseAuthorName :: String -> Text + parseAuthorName = + Text.pack . \case + ('"' : quoted) -> init quoted + bare -> bare authLogin :: InputPattern authLogin = InputPattern "auth.login" [] - I.Hidden + I.Visible [] ( P.lines [ P.wrap "Obtain an authentication session with Unison Share.", @@ -2700,24 +2895,6 @@ printVersion = _ -> Left (showPatternHelp printVersion) ) -diffNamespaceToPatch :: InputPattern -diffNamespaceToPatch = - InputPattern - { patternName = "diff.namespace.to-patch", - aliases = [], - visibility = I.Visible, - args = [], - help = P.wrap "Create a patch from a namespace diff.", - parse = \case - [branchId1, branchId2, patch] -> - mapLeft P.text do - branchId1 <- Input.parseBranchId branchId1 - branchId2 <- Input.parseBranchId branchId2 - patch <- Path.parseSplit' patch - pure (Input.DiffNamespaceToPatchI Input.DiffNamespaceToPatchInput {branchId1, branchId2, patch}) - _ -> Left (showPatternHelp diffNamespaceToPatch) - } - projectCreate :: InputPattern projectCreate = InputPattern @@ -2731,11 +2908,9 @@ projectCreate = ("`project.create foo`", "creates a project named `foo`") ], parse = \case - [name] -> - case tryInto @ProjectName (Text.pack name) of - Left _ -> Left "Invalid project name." - Right name1 -> Right (Input.ProjectCreateI True (Just name1)) - _ -> Right (Input.ProjectCreateI True Nothing) + [] -> pure $ Input.ProjectCreateI True Nothing + [name] -> Input.ProjectCreateI True . pure <$> handleProjectArg name + _ -> Left $ showPatternHelp projectCreate } projectCreateEmptyInputPattern :: InputPattern @@ -2751,11 +2926,9 @@ projectCreateEmptyInputPattern = ("`project.create-empty foo`", "creates an empty project named `foo`") ], parse = \case - [name] -> - case tryInto @ProjectName (Text.pack name) of - Left _ -> Left "Invalid project name." - Right name1 -> Right (Input.ProjectCreateI False (Just name1)) - _ -> Right (Input.ProjectCreateI False Nothing) + [] -> pure $ Input.ProjectCreateI False Nothing + [name] -> Input.ProjectCreateI False . pure <$> handleProjectArg name + _ -> Left $ showPatternHelp projectCreateEmptyInputPattern } projectRenameInputPattern :: InputPattern @@ -2770,7 +2943,7 @@ projectRenameInputPattern = [ ("`project.rename foo`", "renames the current project to `foo`") ], parse = \case - [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.ProjectRenameI name) + [nameString] -> Input.ProjectRenameI <$> handleProjectArg nameString _ -> Left (showPatternHelp projectRenameInputPattern) } @@ -2789,10 +2962,7 @@ projectSwitch = ("`switch /bar`", "switches to the branch `bar` in the current project") ], parse = \case - [name] -> - case tryInto @ProjectAndBranchNames (Text.pack name) of - Left _ -> Left (showPatternHelp projectSwitch) - Right projectAndBranch -> Right (Input.ProjectSwitchI projectAndBranch) + [name] -> Input.ProjectSwitchI <$> handleProjectAndBranchNamesArg name _ -> Left (showPatternHelp projectSwitch) } where @@ -2828,7 +2998,7 @@ branchesInputPattern = ], parse = \case [] -> Right (Input.BranchesI Nothing) - [nameString] | Right name <- tryFrom (Text.pack nameString) -> Right (Input.BranchesI (Just name)) + [nameString] -> Input.BranchesI . pure <$> handleProjectArg nameString _ -> Left (showPatternHelp branchesInputPattern) } @@ -2848,22 +3018,13 @@ branchInputPattern = ("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`"), ("`branch .bar foo`", "forks the path `.bar` of the current project to a new branch `foo`") ], - parse = - maybeToEither (showPatternHelp branchInputPattern) . \case - [source0, name] -> do - source <- parseLooseCodeOrProject source0 - projectAndBranch <- - Text.pack name - & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - & eitherToMaybe - Just (Input.BranchI (Input.BranchSourceI'LooseCodeOrProject source) projectAndBranch) - [name] -> do - projectAndBranch <- - Text.pack name - & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - & eitherToMaybe - Just (Input.BranchI Input.BranchSourceI'CurrentContext projectAndBranch) - _ -> Nothing + parse = \case + [source0, name] -> + Input.BranchI . Input.BranchSourceI'LooseCodeOrProject + <$> handleLooseCodeOrProjectArg source0 + <*> handleMaybeProjectBranchArg name + [name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name + _ -> Left $ showPatternHelp branchInputPattern } where newBranchNameArg = @@ -2889,9 +3050,8 @@ branchEmptyInputPattern = help = P.wrap "Create a new empty branch.", parse = \case [name] -> - first (\_ -> showPatternHelp branchEmptyInputPattern) do - projectAndBranch <- tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) - Right (Input.BranchI Input.BranchSourceI'Empty projectAndBranch) + Input.BranchI Input.BranchSourceI'Empty + <$> handleMaybeProjectBranchArg name _ -> Left (showPatternHelp branchEmptyInputPattern) } @@ -2904,10 +3064,9 @@ branchRenameInputPattern = args = [], help = P.wrapColumn2 - [ ("`branch.rename foo`", "renames the current branch to `foo`") - ], + [("`branch.rename foo`", "renames the current branch to `foo`")], parse = \case - [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.BranchRenameI name) + [name] -> Input.BranchRenameI <$> handleProjectBranchNameArg name _ -> Left (showPatternHelp branchRenameInputPattern) } @@ -2940,16 +3099,13 @@ clone = <> P.group (makeExample helpTopics ["remotes"] <> ")") ) ], - parse = - maybe (Left (showPatternHelp clone)) Right . \case - [remoteNamesString] -> do - remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) - Just (Input.CloneI remoteNames Nothing) - [remoteNamesString, localNamesString] -> do - remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) - localNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack localNamesString)) - Just (Input.CloneI remoteNames (Just localNames)) - _ -> Nothing + parse = \case + [remoteNames] -> Input.CloneI <$> handleProjectAndBranchNamesArg remoteNames <*> pure Nothing + [remoteNames, localNames] -> + Input.CloneI + <$> handleProjectAndBranchNamesArg remoteNames + <*> fmap pure (handleProjectAndBranchNamesArg localNames) + _ -> Left $ showPatternHelp clone } releaseDraft :: InputPattern @@ -2961,7 +3117,11 @@ releaseDraft = args = [], help = P.wrap "Draft a release.", parse = \case - [tryInto @Semver . Text.pack -> Right semver] -> Right (Input.ReleaseDraftI semver) + [semverString] -> + bimap (const "Couldn’t parse version number") Input.ReleaseDraftI + . tryInto @Semver + . Text.pack + =<< unsupportedStructuredArgument "a version number" semverString _ -> Left (showPatternHelp releaseDraft) } @@ -2975,20 +3135,24 @@ upgrade = help = P.wrap $ "`upgrade old new` upgrades library dependency `lib.old` to `lib.new`, and, if successful, deletes `lib.old`.", - parse = - maybeToEither (I.help upgrade) . \args -> do - [oldString, newString] <- Just args - old <- parseRelativeNameSegment oldString - new <- parseRelativeNameSegment newString - Just (Input.UpgradeI old new) + parse = \case + [oldString, newString] -> + Input.UpgradeI <$> handleRelativeNameSegmentArg oldString <*> handleRelativeNameSegmentArg newString + _ -> Left $ I.help upgrade + } + +upgradeCommitInputPattern :: InputPattern +upgradeCommitInputPattern = + InputPattern + { patternName = "upgrade.commit", + aliases = ["commit.upgrade"], + visibility = I.Visible, + args = [], + help = P.wrap $ makeExample' upgradeCommitInputPattern <> "commits the current upgrade.", + parse = \case + [] -> Right Input.UpgradeCommitI + _ -> Left (I.help upgradeCommitInputPattern) } - where - parseRelativeNameSegment :: String -> Maybe NameSegment - parseRelativeNameSegment string = do - name <- Name.parseText (Text.pack string) - guard (Name.isRelative name) - segment NE.:| [] <- Just (Name.reverseSegments name) - Just segment validInputs :: [InputPattern] validInputs = @@ -3009,7 +3173,6 @@ validInputs = clear, clone, compileScheme, - copyPatch, createAuthor, debugClearWatchCache, debugDoctor, @@ -3030,18 +3193,14 @@ validInputs = deleteProject, deleteNamespace, deleteNamespaceForce, - deletePatch, deleteTerm, - deleteTermReplacement, deleteTermVerbose, deleteType, - deleteTypeReplacement, deleteTypeVerbose, deleteVerbose, dependencies, dependents, diffNamespace, - diffNamespaceToPatch, display, displayTo, docToMarkdown, @@ -3055,14 +3214,12 @@ validInputs = findAll, findInAll, findGlobal, - findPatch, findShallow, findVerbose, findVerboseAll, sfind, sfindReplace, forkLocal, - gist, help, helpTopics, history, @@ -3080,7 +3237,6 @@ validInputs = names False, -- names names True, -- names.global namespaceDependencies, - patch, previewAdd, previewUpdate, printVersion, @@ -3090,7 +3246,6 @@ validInputs = projectSwitch, projectsInputPattern, pull, - pullVerbose, pullWithoutHistory, push, pushCreate, @@ -3099,11 +3254,9 @@ validInputs = quit, releaseDraft, renameBranch, - renamePatch, renameTerm, renameType, moveAll, - replace, reset, resetRoot, runScheme, @@ -3119,9 +3272,9 @@ validInputs = updateOld, updateOldNoPatch, upgrade, + upgradeCommitInputPattern, view, viewGlobal, - viewPatch, viewReflog ] @@ -3155,14 +3308,6 @@ exactDefinitionArg = fzfResolver = Just Resolvers.definitionResolver } -fuzzyDefinitionQueryArg :: ArgumentType -fuzzyDefinitionQueryArg = - ArgumentType - { typeName = "fuzzy definition query", - suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteTermOrType q p), - fzfResolver = Just Resolvers.definitionResolver - } - definitionQueryArg :: ArgumentType definitionQueryArg = exactDefinitionArg {typeName = "definition query"} @@ -3267,39 +3412,12 @@ filePathArg = fzfResolver = Nothing } --- Arya: I could imagine completions coming from previous pulls -gitUrlArg :: ArgumentType -gitUrlArg = - ArgumentType - { typeName = "git-url", - suggestions = - let complete s = pure [Completion s s False] - in \input _ _ _ -> case input of - "gh" -> complete "git(https://github.com/" - "gl" -> complete "git(https://gitlab.com/" - "bb" -> complete "git(https://bitbucket.com/" - "ghs" -> complete "git(git@github.com:" - "gls" -> complete "git(git@gitlab.com:" - "bbs" -> complete "git(git@bitbucket.com:" - _ -> pure [], - fzfResolver = Nothing - } - -- | Refers to a namespace on some remote code host. remoteNamespaceArg :: ArgumentType remoteNamespaceArg = ArgumentType { typeName = "remote-namespace", - suggestions = - let complete s = pure [Completion s s False] - in \input _cb http _p -> case input of - "gh" -> complete "git(https://github.com/" - "gl" -> complete "git(https://gitlab.com/" - "bb" -> complete "git(https://bitbucket.com/" - "ghs" -> complete "git(git@github.com:" - "gls" -> complete "git(git@gitlab.com:" - "bbs" -> complete "git(git@bitbucket.com:" - _ -> sharePathCompletion http input, + suggestions = \input _cb http _p -> sharePathCompletion http input, fzfResolver = Nothing } @@ -3309,18 +3427,6 @@ data ProjectInclusion = OnlyWithinCurrentProject | OnlyOutsideCurrentProject | A data BranchInclusion = ExcludeCurrentBranch | AllBranches deriving stock (Eq, Ord, Show) -projectsByPrefix :: MonadIO m => ProjectInclusion -> Codebase m v a -> Path.Absolute -> Text -> m [(ProjectId, ProjectName)] -projectsByPrefix projectInclusion codebase path query = do - allProjectMatches <- Codebase.runTransaction codebase do - Queries.loadAllProjectsBeginningWith (Just query) - <&> map (\(Sqlite.Project projId projName) -> (projId, projName)) - let projectCtx = projectContextFromPath path - pure $ case (projectCtx, projectInclusion) of - (_, AllProjects) -> allProjectMatches - (LooseCodePath {}, _) -> allProjectMatches - (ProjectBranchPath currentProjectId _branchId _path, OnlyWithinCurrentProject) -> allProjectMatches & filter \(projId, _) -> projId == currentProjectId - (ProjectBranchPath currentProjectId _branchId _path, OnlyOutsideCurrentProject) -> allProjectMatches & filter \(projId, _) -> projId /= currentProjectId - data ProjectBranchSuggestionsConfig = ProjectBranchSuggestionsConfig { -- Whether projects (without branches) should be considered possible completions. showProjectCompletions :: Bool, @@ -3389,7 +3495,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) handleAmbiguousComplete :: - MonadIO m => + (MonadIO m) => Text -> Codebase m v a -> m [Completion] @@ -3478,7 +3584,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do then projectCompletions else branchCompletions ++ projectCompletions - handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> Path.Absolute -> m [Completion] + handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> Path.Absolute -> m [Completion] handleBranchesComplete branchName codebase path = do branches <- case preview ProjectUtils.projectBranchPathPrism path of @@ -3519,7 +3625,7 @@ projectBranchToCompletion projectName (_, branchName) = } handleBranchesComplete :: - MonadIO m => + (MonadIO m) => ProjectBranchSuggestionsConfig -> Text -> Codebase m v a -> @@ -3555,7 +3661,7 @@ currentProjectBranchToCompletion (_, branchName) = } branchRelativePathSuggestions :: - MonadIO m => + (MonadIO m) => ProjectBranchSuggestionsConfig -> String -> Codebase m v a -> @@ -3661,7 +3767,7 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = branchPathSepPretty = P.hiBlack branchPathSep - branchPathSep :: IsString s => s + branchPathSep :: (IsString s) => s branchPathSep = ":" -- | A project name, branch name, or both. @@ -3682,15 +3788,6 @@ projectBranchNameArg config = fzfResolver = Just Resolvers.projectBranchResolver } --- [project/]branch -projectBranchNameWithOptionalProjectNameArg :: ArgumentType -projectBranchNameWithOptionalProjectNameArg = - ArgumentType - { typeName = "project-branch-name-with-optional-project-name", - suggestions = \_ _ _ _ -> pure [], - fzfResolver = Just Resolvers.projectBranchResolver - } - branchRelativePathArg :: ArgumentType branchRelativePathArg = ArgumentType @@ -3720,7 +3817,7 @@ data OptionalSlash | NoSlash projectNameSuggestions :: - MonadIO m => + (MonadIO m) => OptionalSlash -> String -> Codebase m v a -> @@ -3746,26 +3843,17 @@ projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do isFinished = False } -parsePullSource :: Text -> Maybe (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) -parsePullSource = - Megaparsec.parseMaybe (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) - -- | Parse a 'Input.PushSource'. -parsePushSource :: String -> Either (P.Pretty CT.ColorText) Input.PushSource +parsePushSource :: String -> Maybe Input.PushSource parsePushSource sourceStr = - case tryFrom (Text.pack sourceStr) of - Left _ -> - case Path.parsePath' sourceStr of - Left _ -> Left (I.help push) - Right path -> Right (Input.PathySource path) - Right branch -> Right (Input.ProjySource branch) + fixup Input.ProjySource (tryFrom $ Text.pack sourceStr) + <|> fixup Input.PathySource (Path.parsePath' sourceStr) + where + fixup = either (const Nothing) . (pure .) -- | Parse a push target. -parsePushTarget :: String -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName)) -parsePushTarget target = - case Megaparsec.parseMaybe UriParser.writeRemoteNamespace (Text.pack target) of - Nothing -> Left (I.help push) - Just path -> Right path +parsePushTarget :: String -> Maybe (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack parseHashQualifiedName :: String -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) @@ -3781,48 +3869,21 @@ parseHashQualifiedName s = Right $ HQ.parseText (Text.pack s) -parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo -parseWriteGitRepo label input = do - first - (fromString . show) -- turn any parsing errors into a Pretty. - (Megaparsec.parse (UriParser.writeGitRepo <* Megaparsec.eof) label (Text.pack input)) - -collectNothings :: (a -> Maybe b) -> [a] -> [a] -collectNothings f as = [a | (Nothing, a) <- map f as `zip` as] - explainRemote :: PushPull -> P.Pretty CT.ColorText explainRemote pushPull = P.group $ P.lines - [ P.wrap $ "where `remote` is a hosted codebase, such as:", + [ P.wrap $ "where `remote` is a project or project branch, such as:", P.indentN 2 . P.column2 $ - [ ("Unison Share", P.backticked "user.public.some.remote.path"), - ("Git + root", P.backticked $ "git(" <> gitRepo <> "user/repo)"), - ("Git + path", P.backticked $ "git(" <> gitRepo <> "user/repo).some.remote.path"), - ("Git + branch", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch)"), - ("Git + branch + path", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch).some.remote.path") + [ ("Project (defaults to the /main branch)", P.backticked "@unison/base"), + ("Project Branch", P.backticked "@unison/base/feature"), + ("Contributor Branch", P.backticked "@unison/base/@johnsmith/feature") ] + <> Monoid.whenM (pushPull == Pull) [("Project Release", P.backticked "@unison/base/releases/1.0.0")] ] - where - gitRepo = PushPull.fold @(P.Pretty P.ColorText) "git@github.com:" "https://github.com/" pushPull -showErrorFancy :: (Megaparsec.ShowErrorComponent e) => Megaparsec.ErrorFancy e -> String -showErrorFancy (Megaparsec.ErrorFail msg) = msg -showErrorFancy (Megaparsec.ErrorIndentation ord ref actual) = - "incorrect indentation (got " - <> show (Megaparsec.unPos actual) - <> ", should be " - <> p - <> show (Megaparsec.unPos ref) - <> ")" - where - p = case ord of - LT -> "less than " - EQ -> "equal to " - GT -> "greater than " -showErrorFancy (Megaparsec.ErrorCustom a) = Megaparsec.showErrorComponent a - -showErrorItem :: Megaparsec.ErrorItem (Megaparsec.Token Text) -> String -showErrorItem (Megaparsec.Tokens ts) = Megaparsec.showTokens (Proxy @Text) ts -showErrorItem (Megaparsec.Label label) = NE.toList label -showErrorItem Megaparsec.EndOfInput = "end of input" +megaparse :: Megaparsec.Parsec Void Text a -> Text -> Either (P.Pretty P.ColorText) a +megaparse parser input = + input + & Megaparsec.parse (parser <* Megaparsec.eof) "" + & mapLeft (prettyPrintParseError (Text.unpack input)) diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index de0d7e12f..f675f9189 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -33,7 +33,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.HandleInput qualified as HandleInput import Unison.Codebase.Editor.Input (Event, Input (..)) -import Unison.Codebase.Editor.Output (Output) +import Unison.Codebase.Editor.Output (NumberedArgs, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime qualified as Runtime @@ -61,7 +61,7 @@ getUserInput :: Codebase IO Symbol Ann -> AuthenticatedHttpClient -> Path.Absolute -> - [String] -> + NumberedArgs -> IO Input getUserInput codebase authHTTPClient currentPath numberedArgs = Line.runInputT @@ -113,10 +113,11 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = -- Ctrl-c or some input cancel, re-run the prompt go Right (Just (expandedArgs, i)) -> do - let expandedArgsStr = unwords expandedArgs - when (expandedArgs /= ws) $ do + let expandedArgs' = IP.unifyArgument <$> expandedArgs + expandedArgsStr = unwords expandedArgs' + when (expandedArgs' /= ws) $ do liftIO . putStrLn $ fullPrompt <> expandedArgsStr - Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ unwords expandedArgs + Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ expandedArgsStr pure i settings :: Line.Settings IO settings = diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 86e8b2bcf..fa3aedbe9 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -6,9 +6,7 @@ module Unison.CommandLine.OutputMessages where import Control.Lens hiding (at) -import Control.Monad.State import Control.Monad.State.Strict qualified as State -import Control.Monad.Writer (Writer, runWriter, tell) import Data.ByteString.Lazy qualified as LazyByteString import Data.Foldable qualified as Foldable import Data.List (stripPrefix) @@ -37,10 +35,12 @@ import U.Codebase.Branch (NamespaceStats (..)) import U.Codebase.Branch.Diff (NameChanges (..)) import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference -import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import Unison.ABT qualified as ABT import Unison.Auth.Types qualified as Auth import Unison.Builtin.Decls qualified as DD +import Unison.Cli.MergeTypes (MergeSourceAndTarget (..)) import Unison.Cli.Pretty import Unison.Cli.ProjectUtils qualified as ProjectUtils 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 qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.TodoOutput qualified as TO -import Unison.Codebase.GitError import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors) import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch @@ -72,11 +73,7 @@ import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.Codebase.SqliteCodebase.GitError - ( GitSqliteCodebaseError (..), - ) import Unison.Codebase.TermEdit qualified as TermEdit -import Unison.Codebase.Type (GitError (GitCodebaseError, GitProtocolError, GitSqliteCodebaseError)) import Unison.Codebase.TypeEdit qualified as TypeEdit import Unison.CommandLine (bigproblem, note, tip) import Unison.CommandLine.FZFResolvers qualified as FZFResolvers @@ -127,7 +124,6 @@ import Unison.Server.Backend qualified as Backend import Unison.Server.SearchResult' qualified as SR' import Unison.Share.Sync qualified as Share import Unison.Share.Sync.Types (CodeserverTransportError (..)) -import Unison.ShortHash qualified as ShortHash import Unison.Sync.Types qualified as Share import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar) @@ -348,7 +344,7 @@ notifyNumbered = \case ] branchHashes :: [CausalHash] branchHashes = (fst <$> reversedHistory) <> tailHashes - in (msg, displayBranchHash <$> branchHashes) + in (msg, SA.Namespace <$> branchHashes) where toSCH :: CausalHash -> ShortCausalHash toSCH h = SCH.fromHash schLength h @@ -404,10 +400,9 @@ notifyNumbered = \case ], numberedArgsForEndangerments ppeDecl endangerments ) - ListEdits patch ppe -> showListEdits patch ppe ListProjects projects -> ( P.numberedList (map (prettyProjectName . view #name) projects), - map (Text.unpack . into @Text . view #name) projects + map (SA.Project . view #name) projects ) ListBranches projectName branches -> ( P.columnNHeader @@ -423,7 +418,9 @@ notifyNumbered = \case ] : map (\branch -> ["", "", prettyRemoteBranchInfo branch]) remoteBranches ), - map (\(branchName, _) -> Text.unpack (into @Text (ProjectAndBranch projectName branchName))) branches + map + (SA.ProjectBranch . ProjectAndBranch (pure projectName) . fst) + branches ) AmbiguousSwitch project (ProjectAndBranch currentProject branch) -> ( P.wrap @@ -448,8 +445,9 @@ notifyNumbered = \case <> switch ["2"] <> " to pick one of these." ), - [ Text.unpack (Text.cons '/' (into @Text branch)), - Text.unpack (into @Text (ProjectAndBranch project (UnsafeProjectBranchName "main"))) + [ SA.ProjectBranch $ ProjectAndBranch Nothing branch, + SA.ProjectBranch . ProjectAndBranch (pure project) $ + UnsafeProjectBranchName "main" ] ) where @@ -478,8 +476,8 @@ notifyNumbered = \case <> reset (resetArgs ["2"]) <> " to pick one of these." ), - [ Text.unpack (Text.cons '/' (into @Text branch)), - Text.unpack (into @Text (show absPath0)) + [ SA.ProjectBranch $ ProjectAndBranch Nothing branch, + SA.AbsolutePath absPath0 ] ) where @@ -515,13 +513,13 @@ notifyNumbered = \case newNextNum = nextNum + length unnumberedNames in ( newNextNum, ( nameToNum <> (Map.fromList (zip unnumberedNames [nextNum ..])), - args <> fmap Name.toText unnumberedNames + args <> unnumberedNames ) ) ) (1, (mempty, mempty)) & snd - & over (_2 . mapped) Text.unpack + & over (_2 . mapped) SA.Name externalDepsTable :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)] externalDepsTable = ifoldMap $ \ld dependents -> [(prettyLD ld, prettyDependents dependents)] @@ -550,99 +548,6 @@ undoTip = <> IP.makeExample' IP.viewReflog <> "to undo this change." -showListEdits :: Patch -> PPE.PrettyPrintEnv -> (P.Pretty P.ColorText, NumberedArgs) -showListEdits patch ppe = - ( P.sepNonEmpty - "\n\n" - [ if null types - then mempty - else - "Edited Types:" - `P.hang` P.column2 typeOutputs, - if null terms - then mempty - else - "Edited Terms:" - `P.hang` P.column2 termOutputs, - if null types && null terms - then "This patch is empty." - else - tip . P.string $ - "To remove entries from a patch, use " - <> IP.deleteTermReplacementCommand - <> " or " - <> IP.deleteTypeReplacementCommand - <> ", as appropriate." - ], - numberedArgsCol1 <> numberedArgsCol2 - ) - where - typeOutputs, termOutputs :: [(Pretty, Pretty)] - numberedArgsCol1, numberedArgsCol2 :: NumberedArgs - -- We use the output of the first column's count as the first number in the second - -- column's count. Laziness allows this since they're used independently of one another. - (((typeOutputs, termOutputs), (lastNumberInFirstColumn, _)), (numberedArgsCol1, numberedArgsCol2)) = - runWriter . flip runStateT (1, lastNumberInFirstColumn) $ do - typeOutputs <- traverse prettyTypeEdit types - termOutputs <- traverse prettyTermEdit terms - pure (typeOutputs, termOutputs) - types :: [(Reference, TypeEdit.TypeEdit)] - types = R.toList $ Patch._typeEdits patch - terms :: [(Reference, TermEdit.TermEdit)] - terms = R.toList $ Patch._termEdits patch - showNum :: Int -> Pretty - showNum n = P.hiBlack (P.shown n <> ". ") - - prettyTermEdit :: - (Reference.TermReference, TermEdit.TermEdit) -> - StateT (Int, Int) (Writer (NumberedArgs, NumberedArgs)) (Pretty, Pretty) - prettyTermEdit (lhsRef, termEdit) = do - n1 <- gets fst <* modify (first succ) - let lhsTermName = PPE.termName ppe (Referent.Ref lhsRef) - -- We use the shortHash of the lhs rather than its name for numbered args, - -- since its name is likely to be "historical", and won't work if passed to a ucm command. - let lhsHash = Text.unpack . ShortHash.toText . Reference.toShortHash $ lhsRef - case termEdit of - TermEdit.Deprecate -> do - lift $ tell ([lhsHash], []) - pure - ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName), - "-> (deprecated)" - ) - TermEdit.Replace rhsRef _typing -> do - n2 <- gets snd <* modify (second succ) - let rhsTermName = PPE.termName ppe (Referent.Ref rhsRef) - lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTermName)]) - pure - ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName), - "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTermName) - ) - - prettyTypeEdit :: - (Reference, TypeEdit.TypeEdit) -> - StateT (Int, Int) (Writer (NumberedArgs, NumberedArgs)) (Pretty, Pretty) - prettyTypeEdit (lhsRef, typeEdit) = do - n1 <- gets fst <* modify (first succ) - let lhsTypeName = PPE.typeName ppe lhsRef - -- We use the shortHash of the lhs rather than its name for numbered args, - -- since its name is likely to be "historical", and won't work if passed to a ucm command. - let lhsHash = Text.unpack . ShortHash.toText . Reference.toShortHash $ lhsRef - case typeEdit of - TypeEdit.Deprecate -> do - lift $ tell ([lhsHash], []) - pure - ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName), - "-> (deprecated)" - ) - TypeEdit.Replace rhsRef -> do - n2 <- gets snd <* modify (second succ) - let rhsTypeName = PPE.typeName ppe rhsRef - lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTypeName)]) - pure - ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName), - "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTypeName) - ) - notifyUser :: FilePath -> Output -> IO Pretty notifyUser dir = \case SaveTermNameConflict name -> @@ -684,49 +589,6 @@ notifyUser dir = \case $ "The namespaces " <> P.commas (prettyBranchId <$> ps) <> " are empty. Was there a typo?" - WarnIncomingRootBranch current hashes -> - pure $ - if null hashes - then - P.wrap $ - "Please let someone know I generated an empty IncomingRootBranch" - <> " event, which shouldn't be possible!" - else - P.lines - [ P.wrap $ - (if length hashes == 1 then "A" else "Some") - <> "codebase" - <> P.plural hashes "root" - <> "appeared unexpectedly" - <> "with" - <> P.group (P.plural hashes "hash" <> ":"), - "", - (P.indentN 2 . P.oxfordCommas) - (map prettySCH $ toList hashes), - "", - P.wrap $ - "and I'm not sure what to do about it." - <> "The last root namespace hash that I knew about was:", - "", - P.indentN 2 $ prettySCH current, - "", - P.wrap $ "Now might be a good time to make a backup of your codebase. 😬", - "", - P.wrap $ - "After that, you might try using the" - <> makeExample' IP.forkLocal - <> "command to inspect the namespaces listed above, and decide which" - <> "one you want as your root." - <> "You can also use" - <> makeExample' IP.viewReflog - <> "to see the" - <> "last few root namespace hashes on record.", - "", - P.wrap $ - "Once you find one you like, you can use the" - <> makeExample' IP.resetRoot - <> "command to set it." - ] LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath -> pure $ P.lines @@ -824,13 +686,6 @@ notifyUser dir = \case <> " by someone else. Trying your command again might fix it." ] EvaluationFailure err -> pure err - TypeTermMismatch typeName termName -> - pure $ - P.warnCallout "I was expecting either two types or two terms but was given a type " - <> P.syntaxToColor (prettyHashQualified typeName) - <> " and a term " - <> P.syntaxToColor (prettyHashQualified termName) - <> "." SearchTermsNotFound hqs | null hqs -> pure mempty SearchTermsNotFound hqs -> pure $ @@ -856,8 +711,6 @@ notifyUser dir = \case P.warnCallout typeOrTermMsg <> P.newline <> P.syntaxToColor (P.indent " " (P.lines (prettyHashQualified <$> otherHits))) - PatchNotFound _ -> - pure . P.warnCallout $ "I don't know about that patch." NameNotFound _ -> pure . P.warnCallout $ "I don't know about that name." NamesNotFound hqs -> @@ -875,8 +728,6 @@ notifyUser dir = \case pure . P.warnCallout $ "A term by that name already exists." TypeAlreadyExists _ _ -> pure . P.warnCallout $ "A type by that name already exists." - PatchAlreadyExists _ -> - pure . P.warnCallout $ "A patch by that name already exists." BranchEmpty b -> pure . P.warnCallout . P.wrap $ P.group (prettyWhichBranchEmpty b) <> "is an empty namespace." @@ -888,21 +739,21 @@ notifyUser dir = \case P.lines [ P.wrap $ "I looked for a function" - <> P.backticked (P.text main) + <> P.backticked (P.text $ HQ.toText main) <> "in the most recently typechecked file and codebase but couldn't find one. It has to have the type:", "", - P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts] + P.indentN 2 $ P.lines [P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe t | t <- ts] ] BadMainFunction what main ty ppe ts -> pure . P.callout "😶" $ P.lines [ P.string "I found this function:", "", - P.indentN 2 $ P.text main <> " : " <> TypePrinter.pretty ppe ty, + P.indentN 2 $ P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe ty, "", P.wrap $ P.string "but in order for me to" <> P.backticked (P.text what) <> "it needs to be a subtype of:", "", - P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts] + P.indentN 2 $ P.lines [P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe t | t <- ts] ] NoUnisonFile -> do dir' <- canonicalizePath dir @@ -1187,8 +1038,6 @@ notifyUser dir = \case LoadingFile sourceName -> do fileName <- renderFileName $ Text.unpack sourceName 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 let fileStatusMsg = SlurpResult.pretty False ppe slurpResult let containsWatchExpressions = notNull $ UF.watchComponents uf @@ -1221,8 +1070,7 @@ notifyUser dir = \case <> IP.makeExample' IP.add <> " or " <> P.group (IP.makeExample' IP.update <> ",") - <> "here's how your codebase would" - <> "change:", + <> "here's how your codebase would change:", P.indentN 2 $ SlurpResult.pretty False ppe slurpResult ] ] @@ -1242,133 +1090,6 @@ notifyUser dir = \case pure . P.wrap $ "I loaded " <> P.text sourceName <> " and didn't find anything." else pure mempty - GitError e -> pure $ case e of - GitSqliteCodebaseError e -> case e of - CodebaseFileLockFailed -> - P.wrap $ - "It looks to me like another ucm process is using this codebase. Only one ucm process can use a codebase at a time." - NoDatabaseFile repo localPath -> - P.wrap $ - "I didn't find a codebase in the repository at" - <> prettyReadGitRepo repo - <> "in the cache directory at" - <> P.backticked' (P.string localPath) "." - CodebaseRequiresMigration (SchemaVersion fromSv) (SchemaVersion toSv) -> do - P.wrap $ - "The specified codebase codebase is on version " - <> P.shown fromSv - <> " but needs to be on version " - <> P.shown toSv - UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> - P.wrap $ - "I don't know how to interpret schema version " - <> P.shown v - <> "in the repository at" - <> prettyReadGitRepo repo - <> "in the cache directory at" - <> P.backticked' (P.string localPath) "." - GitCouldntParseRootBranchHash repo s -> - P.wrap $ - "I couldn't parse the string" - <> P.red (P.string s) - <> "into a namespace hash, when opening the repository at" - <> P.group (prettyReadGitRepo repo <> ".") - GitProtocolError e -> case e of - NoGit -> - P.wrap $ - "I couldn't find git. Make sure it's installed and on your path." - CleanupError e -> - P.wrap $ - "I encountered an exception while trying to clean up a git cache directory:" - <> P.group (P.shown e) - CloneException repo msg -> - P.wrap $ - "I couldn't clone the repository at" - <> prettyReadGitRepo repo - <> ";" - <> "the error was:" - <> (P.indentNAfterNewline 2 . P.group . P.string) msg - CopyException srcRepoPath destPath msg -> - P.wrap $ - "I couldn't copy the repository at" - <> P.string srcRepoPath - <> "into" - <> P.string destPath - <> ";" - <> "the error was:" - <> (P.indentNAfterNewline 2 . P.group . P.string) msg - PushNoOp repo -> - P.wrap $ - "The repository at" <> prettyWriteGitRepo repo <> "is already up-to-date." - PushException repo msg -> - P.wrap $ - "I couldn't push to the repository at" - <> prettyWriteGitRepo repo - <> ";" - <> "the error was:" - <> (P.indentNAfterNewline 2 . P.group . P.string) msg - RemoteRefNotFound repo ref -> - P.wrap $ - "I couldn't find the ref " <> P.green (P.text ref) <> " in the repository at " <> P.blue (P.text repo) <> ";" - UnrecognizableCacheDir uri localPath -> - P.wrap $ - "A cache directory for" - <> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri) - <> "already exists at" - <> P.backticked' (P.string localPath) "," - <> "but it doesn't seem to" - <> "be a git repository, so I'm not sure what to do next. Delete it?" - UnrecognizableCheckoutDir uri localPath -> - P.wrap $ - "I tried to clone" - <> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri) - <> "into a cache directory at" - <> P.backticked' (P.string localPath) "," - <> "but I can't recognize the" - <> "result as a git repository, so I'm not sure what to do next." - PushDestinationHasNewStuff repo -> - P.callout "⏸" . P.lines $ - [ P.wrap $ - "The repository at" - <> prettyWriteGitRepo repo - <> "has some changes I don't know about.", - "", - P.wrap $ "Try" <> pull <> "to merge these changes locally, then" <> push <> "again." - ] - where - push = P.group . P.backticked . IP.patternName $ IP.push - pull = P.group . P.backticked . IP.patternName $ IP.pull - GitCodebaseError e -> case e of - CouldntFindRemoteBranch repo path -> - P.wrap $ - "I couldn't find the remote branch at" - <> P.shown path - <> "in the repository at" - <> prettyReadGitRepo repo - NoRemoteNamespaceWithHash repo sch -> - P.wrap $ - "The repository at" - <> prettyReadGitRepo repo - <> "doesn't contain a namespace with the hash prefix" - <> (P.blue . P.text . SCH.toText) sch - RemoteNamespaceHashAmbiguous repo sch hashes -> - P.lines - [ P.wrap $ - "The namespace hash" - <> prettySCH sch - <> "at" - <> prettyReadGitRepo repo - <> "is ambiguous." - <> "Did you mean one of these hashes?", - "", - P.indentN 2 $ - P.lines - ( prettySCH . SCH.fromHash ((Text.length . SCH.toText) sch * 2) - <$> Set.toList hashes - ), - "", - P.wrap "Try again with a few more hash characters to disambiguate." - ] BustedBuiltins (Set.toList -> new) (Set.toList -> old) -> -- todo: this could be prettier! Have a nice list like `find` gives, but -- that requires querying the codebase to determine term types. Probably @@ -1398,17 +1119,6 @@ notifyUser dir = \case "You're missing:" `P.hang` P.lines (fmap (P.text . Reference.toText) new), "I'm missing:" `P.hang` P.lines (fmap (P.text . Reference.toText) old) ] - ListOfPatches patches -> - pure $ - if null patches - then P.lit "nothing to show" - else numberedPatches patches - where - numberedPatches :: Set Name -> Pretty - numberedPatches patches = - (P.column2 . fmap format) ([(1 :: Integer) ..] `zip` (toList patches)) - where - format (i, p) = (P.hiBlack . fromString $ show i <> ".", prettyName p) NoConfiguredRemoteMapping pp p -> do let (localPathExample, sharePathExample) = if Path.isRoot p @@ -1428,7 +1138,7 @@ notifyUser dir = \case "Type `help " <> PushPull.fold "push" "pull" pp <> "` for more information." ] - -- | ConfiguredGitUrlParseError PushPull Path' Text String + -- | ConfiguredRemoteMappingParseError PushPull Path' Text String ConfiguredRemoteMappingParseError pp p url err -> pure . P.fatalCallout . P.lines $ [ P.wrap $ @@ -1542,12 +1252,6 @@ notifyUser dir = \case "I could't find a type with hash " <> (prettyShortHash sh) AboutToPropagatePatch -> pure "Applying changes from patch..." - NothingToPatch _patchPath dest -> - pure $ - P.callout "😶" . P.wrap $ - "This had no effect. Perhaps the patch has already been applied" - <> "or it doesn't intersect with the definitions in" - <> P.group (prettyPath' dest <> ".") PatchNeedsToBeConflictFree -> pure . P.wrap $ "I tried to auto-apply the patch, but couldn't because it contained" @@ -1605,35 +1309,75 @@ notifyUser dir = \case PullAlreadyUpToDate ns dest -> pure . P.callout "😶" $ P.wrap $ - prettyNamespaceKey dest + prettyProjectAndBranchName (ProjectAndBranch dest.project.name dest.branch.name) <> "was already up-to-date with" <> P.group (prettyReadRemoteNamespace ns <> ".") PullSuccessful ns dest -> pure . P.okCallout $ P.wrap $ "Successfully updated" - <> prettyNamespaceKey dest + <> prettyProjectAndBranchName (ProjectAndBranch dest.project.name dest.branch.name) <> "from" <> P.group (prettyReadRemoteNamespace ns <> ".") AboutToMerge -> pure "Merging..." MergeOverEmpty dest -> pure . P.okCallout $ 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 -> pure . P.callout "😶" $ P.wrap $ - prettyNamespaceKey dest + either prettyPath' prettyProjectAndBranchName dest <> "was already up-to-date with" - <> P.group (prettyNamespaceKey src <> ".") - MergeConflictedAliases branch name1 name2 -> - pure . P.wrap $ - "On" - <> P.group (prettyProjectBranchName branch <> ",") - <> prettyName name1 - <> "and" - <> prettyName name2 - <> "are not aliases, but they used to be." + <> P.group (either prettyPath' prettyProjectAndBranchName src <> ".") + MergeAlreadyUpToDate2 aliceAndBob -> + pure . P.callout "😶" $ + P.wrap $ + 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 + <> "and" + <> prettyName name2 + <> "were aliases for the same definition, but on" + <> prettyMergeSourceOrTarget aliceOrBob + <> "the names have different definitions currently. I'd need just a single new definition to use in their" + <> "dependents when I merge." + ) + <> P.newline + <> P.newline + <> P.wrap ("Please fix up" <> prettyMergeSourceOrTarget aliceOrBob <> "to resolve this. For example,") + <> P.newline + <> P.newline + <> P.indentN + 2 + ( P.bulleted + [ P.wrap + ( IP.makeExample' IP.update + <> "the definitions to be the same again, so that there's nothing for me to decide." + ), + P.wrap + ( IP.makeExample' IP.moveAll + <> "or" + <> IP.makeExample' IP.delete + <> "all but one of the definitions; I'll use the remaining name when propagating updates." + ) + ] + ) + <> P.newline + <> P.newline + <> P.wrap "and then try merging again." MergeConflictedTermName name _refs -> pure . P.wrap $ "The term name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging." @@ -1641,49 +1385,101 @@ notifyUser dir = \case pure . P.wrap $ "The type name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging." MergeConflictInvolvingBuiltin name -> - pure . P.wrap $ - "There's a merge conflict on" - <> P.group (prettyName name <> ",") - <> "but it's a builtin on one or both branches. We can't yet handle merge conflicts on builtins." - MergeConstructorAlias maybeBranch name1 name2 -> + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap + ( "There's a merge conflict on" + <> P.group (prettyName name <> ",") + <> "but it's a builtin on one or both branches. I can't yet handle merge conflicts involving builtins." + ), + "", + P.wrap + ( "Please eliminate this conflict by updating one branch or the other, making" + <> prettyName name + <> "the same on both branches, or making neither of them a builtin, and then try the merge again." + ) + ] + MergeConstructorAlias aliceOrBob typeName conName1 conName2 -> + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap $ + "On" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "the type" + <> prettyName typeName + <> "has a constructor with multiple names, and I can't perform a merge in this situation:", + "", + P.indentN 2 (P.bulleted [prettyName conName1, prettyName conName2]), + "", + P.wrap "Please delete all but one name for each constructor, and then try merging again." + ] + MergeDefnsInLib aliceOrBob -> + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap $ + "On" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "there's a type or term at the top level of the `lib` namespace, where I only expect to find" + <> "subnamespaces representing library dependencies.", + "", + P.wrap "Please move or remove it and then try merging again." + ] + MergeMissingConstructorName aliceOrBob name -> + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap $ + "On" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "the type" + <> prettyName name + <> "has some constructors with missing names, and I can't perform a merge in this situation.", + "", + P.wrap $ + "You can use" + <> IP.makeExample IP.view [prettyName name] + <> "and" + <> IP.makeExample IP.aliasTerm ["", prettyName name <> "."] + <> "to give names to each unnamed constructor, and then try the merge again." + ] + MergeNestedDeclAlias aliceOrBob shorterName longerName -> pure . P.wrap $ "On" - <> case maybeBranch of - Nothing -> "the LCA," - 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" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "the type" <> prettyName longerName <> "is an alias of" <> P.group (prettyName shorterName <> ".") - <> "Type aliases cannot be nested. Please make them disjoint before merging." - MergeStrayConstructor name -> - pure . P.wrap $ - "The constructor" - <> prettyName name - <> "is not in a subnamespace of a name of its type." - <> "Please either delete it or rename it before merging." + <> "I'm not able to perform a merge when a type exists nested under an alias of itself. Please separate them or" + <> "delete one copy, and then try merging again." + MergeStrayConstructor aliceOrBob name -> + 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 + <> "is not nested beneath the corresponding type name. Please either use" + <> IP.makeExample' IP.moveAll + <> "to move it, or if it's an extra copy, you can simply" + <> IP.makeExample' IP.delete + <> "it. Then try the merge again." + ] PreviewMergeAlreadyUpToDate src dest -> pure . P.callout "😶" $ P.wrap $ prettyNamespaceKey dest <> "is already up-to-date with" <> P.group (prettyNamespaceKey src <> ".") - DumpNumberedArgs args -> pure . P.numberedList $ fmap P.string args + DumpNumberedArgs schLength args -> + pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args NoConflictsOrEdits -> pure (P.okCallout "No conflicts or edits in progress.") HelpMessage pat -> pure $ IP.showPatternHelp pat @@ -1805,7 +1601,7 @@ notifyUser dir = \case ShareError shareError -> pure (prettyShareError shareError) ViewOnShare shareRef -> pure $ - "View it on Unison Share: " <> case shareRef of + "View it here: " <> case shareRef of Left repoPath -> prettyShareLink repoPath Right branchInfo -> prettyRemoteBranchInfo branchInfo IntegrityCheck result -> pure $ case result of @@ -1931,12 +1727,17 @@ notifyUser dir = \case "I just created" <> prettyProjectName projectName <> "on" - <> prettyURI host + <> prettyShareURI host CreatedRemoteProjectBranch host projectAndBranch -> pure . P.wrap $ - "I just created" <> prettyProjectAndBranchName projectAndBranch <> "on" <> prettyURI host + "I just created" <> prettyProjectAndBranchName projectAndBranch <> "on" <> prettyShareURI host RemoteProjectBranchIsUpToDate host projectAndBranch -> - pure (P.wrap (prettyProjectAndBranchName projectAndBranch <> "on" <> prettyURI host <> "is already up-to-date.")) + pure $ + P.wrap $ + prettyProjectAndBranchName projectAndBranch + <> "on" + <> prettyShareURI host + <> "is already up-to-date." InvalidProjectName name -> pure (P.wrap (P.text name <> "is not a valid project name.")) InvalidProjectBranchName name -> pure (P.wrap (P.text name <> "is not a valid branch name.")) ProjectNameAlreadyExists name -> @@ -1956,12 +1757,12 @@ notifyUser dir = \case NotOnProjectBranch -> pure (P.wrap "You are not currently on a branch.") NoAssociatedRemoteProject host projectAndBranch -> pure . P.wrap $ - prettyProjectAndBranchName projectAndBranch <> "isn't associated with any project on" <> prettyURI host + prettyProjectAndBranchName projectAndBranch <> "isn't associated with any project on" <> prettyShareURI host NoAssociatedRemoteProjectBranch host (ProjectAndBranch project branch) -> pure . P.wrap $ prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name)) <> "isn't associated with any branch on" - <> prettyURI host + <> prettyShareURI host LocalProjectDoesntExist project -> pure . P.wrap $ prettyProjectName project <> "does not exist." @@ -1977,17 +1778,17 @@ notifyUser dir = \case <> "exists." RemoteProjectDoesntExist host project -> pure . P.wrap $ - prettyProjectName project <> "does not exist on" <> prettyURI host + prettyProjectName project <> "does not exist on" <> prettyShareURI host RemoteProjectBranchDoesntExist host projectAndBranch -> pure . P.wrap $ - prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyURI host + prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyShareURI host RemoteProjectBranchDoesntExist'Push host projectAndBranch -> let push = P.group . P.backticked . IP.patternName $ IP.push in pure . P.wrap $ "The previous push target named" <> prettyProjectAndBranchName projectAndBranch <> "has been deleted from" - <> P.group (prettyURI host <> ".") + <> P.group (prettyShareURI host <> ".") <> "I've deleted the invalid push target." <> "Run the" <> push @@ -1996,14 +1797,14 @@ notifyUser dir = \case pure . P.wrap $ prettyProjectAndBranchName projectAndBranch <> "on" - <> prettyURI host + <> prettyShareURI host <> "has some history that I don't know about." RemoteProjectPublishedReleaseCannotBeChanged host projectAndBranch -> pure . P.wrap $ "The release" <> prettyProjectAndBranchName projectAndBranch <> "on" - <> prettyURI host + <> prettyShareURI host <> "has already been published and cannot be changed." <> "Consider making a new release instead." RemoteProjectReleaseIsDeprecated host projectAndBranch -> @@ -2011,7 +1812,7 @@ notifyUser dir = \case "The release" <> prettyProjectAndBranchName projectAndBranch <> "on" - <> prettyURI host + <> prettyShareURI host <> "has been deprecated." Unauthorized message -> 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`" ] - MergeFailure path base target -> + MergeFailure path aliceAndBob -> pure . P.wrap $ "I couldn't automatically merge" - <> prettyProjectBranchName (view #branch target) + <> prettyMergeSource aliceAndBob.bob <> "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" <> P.group (prettyFilePath path <> ".") - MergeSuccess base target -> + MergeSuccess aliceAndBob -> pure . P.wrap $ "I merged" - <> prettyProjectBranchName (view #branch target) + <> prettyMergeSource aliceAndBob.bob <> "into" - <> P.group (prettyProjectBranchName (view #branch base) <> ".") - MergeSuccessFastForward base target -> + <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".") + MergeSuccessFastForward aliceAndBob -> pure . P.wrap $ "I fast-forward merged" - <> prettyProjectBranchName (view #branch target) + <> prettyMergeSource aliceAndBob.bob <> "into" - <> P.group (prettyProjectBranchName (view #branch base) <> ".") + <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".") InstalledLibdep libdep segment -> pure . P.wrap $ "I installed" <> prettyProjectAndBranchName libdep <> "as" <> 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 namespace = @@ -2770,7 +2573,7 @@ renderNameConflicts ppe conflictedNames = do P.lines <$> do for (Map.toList conflictedNames) $ \(name, hashes) -> do prettyConflicts <- for hashes \hash -> do - n <- addNumberedArg (Text.unpack (HQ.toText hash)) + n <- addNumberedArg $ SA.HashQualified hash pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash) pure . P.wrap $ ( "The " @@ -2802,7 +2605,7 @@ renderEditConflicts ppe Patch {..} = do <> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits) numberedHQName :: HQ.HashQualified Name -> Numbered Pretty numberedHQName hqName = do - n <- addNumberedArg (Text.unpack (HQ.toText hqName)) + n <- addNumberedArg $ SA.HashQualified hqName pure $ formatNum n <> styleHashQualified P.bold hqName formatTypeEdits :: (Reference, Set TypeEdit.TypeEdit) -> @@ -2841,9 +2644,9 @@ renderEditConflicts ppe Patch {..} = do Numbered Pretty formatConflict = either formatTypeEdits formatTermEdits -type Numbered = State.State (Int, Seq.Seq String) +type Numbered = State.State (Int, Seq.Seq StructuredArgument) -addNumberedArg :: String -> Numbered Int +addNumberedArg :: StructuredArgument -> Numbered Int addNumberedArg s = do (n, args) <- State.get State.put (n + 1, args Seq.|> s) @@ -2915,11 +2718,11 @@ todoOutput ppe todo = runNumbered do todoEdits :: Numbered Pretty todoEdits = do numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do - n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.typeName ppeu ref)) + n <- addNumberedArg . SA.HashQualified $ PPE.typeName ppeu ref pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj) let filteredTerms = goodTerms (unscore <$> dirtyTerms) termNumbers <- for filteredTerms \(ref, _, _) -> do - n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.termName ppeu ref)) + n <- addNumberedArg . SA.HashQualified $ PPE.termName ppeu ref pure $ formatNum n let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms numberedTerms = zipWith (<>) termNumbers formattedTerms @@ -3324,21 +3127,13 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = -- DeclPrinter.prettyDeclHeader : HQ -> Either numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty numPatch prefix name = - addNumberedArg' $ prefixBranchId prefix name + addNumberedArg' $ SA.NameWithBranchPrefix prefix name numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty numHQ' prefix hq r = - addNumberedArg' . HQ'.toStringWith (prefixBranchId prefix) . HQ'.requalify hq $ r + addNumberedArg' . SA.HashQualifiedWithBranchPrefix prefix $ HQ'.requalify hq r - -- E.g. - -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef.base.List.map" - -- prefixBranchId ".base" "List.map" -> ".base.List.map" - prefixBranchId :: Input.AbsBranchId -> Name -> String - prefixBranchId branchId name = case branchId of - Left sch -> "#" <> SCH.toString sch <> ":" <> Text.unpack (Name.toText (Name.makeAbsolute name)) - Right pathPrefix -> Text.unpack (Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name)) - - addNumberedArg' :: String -> Numbered Pretty + addNumberedArg' :: StructuredArgument -> Numbered Pretty addNumberedArg' s = case sn of ShowNumbers -> do n <- addNumberedArg s @@ -3593,7 +3388,7 @@ numberedArgsForEndangerments (PPED.unsuffixifiedPPE -> ppe) m = m & Map.elems & concatMap toList - & fmap (Text.unpack . HQ.toText . PPE.labeledRefName ppe) + & fmap (SA.HashQualified . PPE.labeledRefName ppe) -- | Format and render all dependents which are endangered by references going extinct. endangeredDependentsTable :: diff --git a/unison-cli/src/Unison/LSP/Queries.hs b/unison-cli/src/Unison/LSP/Queries.hs index 9eeaac3fb..b6e87497c 100644 --- a/unison-cli/src/Unison/LSP/Queries.hs +++ b/unison-cli/src/Unison/LSP/Queries.hs @@ -389,7 +389,7 @@ markdownDocsForFQN fileUri fqn = nameSearch <- lift $ getNameSearch Env {codebase, runtime} <- ask liftIO $ do - docRefs <- Backend.docsForDefinitionName codebase nameSearch ExactName name + docRefs <- Codebase.runTransaction codebase $ Backend.docsForDefinitionName codebase nameSearch ExactName name for docRefs $ \docRef -> do Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef) pure . Md.toText $ Md.toMarkdown doc diff --git a/unison-cli/tests/Main.hs b/unison-cli/tests/Main.hs index b94d9407f..c0aa02275 100644 --- a/unison-cli/tests/Main.hs +++ b/unison-cli/tests/Main.hs @@ -6,7 +6,6 @@ import System.IO import System.IO.CodePage (withCP65001) import Unison.Test.ClearCache qualified as ClearCache import Unison.Test.Cli.Monad qualified as Cli.Monad -import Unison.Test.GitSync qualified as GitSync import Unison.Test.LSP qualified as LSP import Unison.Test.UriParser qualified as UriParser @@ -16,7 +15,6 @@ test = [ LSP.test, ClearCache.test, Cli.Monad.test, - GitSync.test, UriParser.test ] diff --git a/unison-cli/tests/Unison/Test/Cli/Monad.hs b/unison-cli/tests/Unison/Test/Cli/Monad.hs index 3b9407da1..712b6c083 100644 --- a/unison-cli/tests/Unison/Test/Cli/Monad.hs +++ b/unison-cli/tests/Unison/Test/Cli/Monad.hs @@ -6,6 +6,8 @@ where import Control.Lens import EasyTest import Unison.Cli.Monad qualified as Cli +import Unison.Codebase.Editor.StructuredArgument qualified as SA +import Unison.Syntax.Name qualified as Name test :: Test () test = @@ -16,13 +18,15 @@ test = Cli.runCli dummyEnv dummyLoopState do Cli.label \goto -> do Cli.label \_ -> do - Cli.setNumberedArgs ["foo"] + Cli.setNumberedArgs [SA.Name $ Name.unsafeParseText "foo"] goto (1 :: Int) pure 2 -- test that 'goto' short-circuits, as expected expectEqual' (Cli.Success 1) r -- test that calling 'goto' doesn't lose state changes made along the way - expectEqual' ["foo"] (state ^. #numberedArgs) + expectEqual' + [SA.Name $ Name.unsafeParseText "foo"] + (state ^. #numberedArgs) ok ] diff --git a/unison-cli/tests/Unison/Test/GitSync.hs b/unison-cli/tests/Unison/Test/GitSync.hs deleted file mode 100644 index a4a719a7b..000000000 --- a/unison-cli/tests/Unison/Test/GitSync.hs +++ /dev/null @@ -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 diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index 8c642eb0c..1a896f4ba 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -7,15 +7,11 @@ import Data.Void (Void) import EasyTest import Text.Megaparsec qualified as P import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRepo (..), - ReadRemoteNamespace (..), + ( ReadRemoteNamespace (..), ShareCodeserver (..), ShareUserHandle (..), - WriteGitRemoteNamespace (..), - WriteGitRepo (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), - pattern ReadGitRemoteNamespace, pattern ReadShareLooseCode, ) import Unison.Codebase.Editor.UriParser qualified as UriParser @@ -34,22 +30,7 @@ test = [ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]), ("project", branchR (This "project")), ("/branch", branchR (That "branch")), - ("project/branch", branchR (These "project" "branch")), - ("git(/srv/git/project.git)", gitR "/srv/git/project.git" Nothing Nothing []), - ("git(/srv/git/project.git:abc)#def.hij.klm", gitR "/srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(srv/git/project.git)", gitR "srv/git/project.git" Nothing Nothing []), - ("git(srv/git/project.git:abc)#def.hij.klm", gitR "srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(file:///srv/git/project.git)", gitR "file:///srv/git/project.git" Nothing Nothing []), - ("git(file:///srv/git/project.git:abc)#def.hij.klm", gitR "file:///srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(file://srv/git/project.git)", gitR "file://srv/git/project.git" Nothing Nothing []), - ("git(file://srv/git/project.git:abc)#def.hij.klm", gitR "file://srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(https://example.com/git/project.git)", gitR "https://example.com/git/project.git" Nothing Nothing []), - ("git(https://user@example.com/git/project.git:abc)#def.hij.klm", gitR "https://user@example.com/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(ssh://git@8.8.8.8:222/user/project.git)", gitR "ssh://git@8.8.8.8:222/user/project.git" Nothing Nothing []), - ("git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", gitR "ssh://git@github.com/user/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(git@github.com:user/project.git)", gitR "git@github.com:user/project.git" Nothing Nothing []), - ("git(github.com:user/project.git)", gitR "github.com:user/project.git" Nothing Nothing []), - ("git(git@github.com:user/project.git:abc)#def.hij.klm", gitR "git@github.com:user/project.git" (Just "abc") (sch "def") ["hij", "klm"]) + ("project/branch", branchR (These "project" "branch")) ] [".unisonweb.base"], parserTests @@ -58,36 +39,15 @@ test = [ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]), ("project", branchW (This "project")), ("/branch", branchW (That "branch")), - ("project/branch", branchW (These "project" "branch")), - ("git(/srv/git/project.git)", gitW "/srv/git/project.git" Nothing []), - ("git(srv/git/project.git)", gitW "srv/git/project.git" Nothing []), - ("git(file:///srv/git/project.git)", gitW "file:///srv/git/project.git" Nothing []), - ("git(file://srv/git/project.git)", gitW "file://srv/git/project.git" Nothing []), - ("git(https://example.com/git/project.git)", gitW "https://example.com/git/project.git" Nothing []), - ("git(ssh://git@8.8.8.8:222/user/project.git)", gitW "ssh://git@8.8.8.8:222/user/project.git" Nothing []), - ("git(git@github.com:user/project.git)", gitW "git@github.com:user/project.git" Nothing []), - ("git(github.com:user/project.git)", gitW "github.com:user/project.git" Nothing []) + ("project/branch", branchW (These "project" "branch")) ] - [ ".unisonweb.base", - "git(/srv/git/project.git:abc)#def.hij.klm", - "git(srv/git/project.git:abc)#def.hij.klm", - "git(file:///srv/git/project.git:abc)#def.hij.klm", - "git(file://srv/git/project.git:abc)#def.hij.klm", - "git(https://user@example.com/git/project.git:abc)#def.hij.klm", - "git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", - "git(git@github.com:user/project.git:abc)#def.hij.klm" + [ ".unisonweb.base" ] ] mkPath :: [Text] -> Path.Path 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 user path = ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (mkPath path)) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 6923ab417..403d2f7e7 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack @@ -35,6 +35,7 @@ library Unison.Auth.Types Unison.Auth.UserInfo Unison.Cli.DownloadUtils + Unison.Cli.MergeTypes Unison.Cli.Monad Unison.Cli.MonadUtils Unison.Cli.NamesUtils @@ -54,6 +55,7 @@ library Unison.Codebase.Editor.HandleInput.Branch Unison.Codebase.Editor.HandleInput.Branches Unison.Codebase.Editor.HandleInput.BranchRename + Unison.Codebase.Editor.HandleInput.CommitUpgrade Unison.Codebase.Editor.HandleInput.DebugDefinition Unison.Codebase.Editor.HandleInput.DebugFoldRanges Unison.Codebase.Editor.HandleInput.DeleteBranch @@ -96,6 +98,7 @@ library Unison.Codebase.Editor.Slurp Unison.Codebase.Editor.SlurpComponent Unison.Codebase.Editor.SlurpResult + Unison.Codebase.Editor.StructuredArgument Unison.Codebase.Editor.TodoOutput Unison.Codebase.Editor.UCMVersion Unison.Codebase.Editor.UriParser @@ -426,7 +429,6 @@ test-suite cli-tests other-modules: Unison.Test.ClearCache Unison.Test.Cli.Monad - Unison.Test.GitSync Unison.Test.LSP Unison.Test.Ucm Unison.Test.UriParser diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index 9467880ca..e06f71512 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -33,10 +33,11 @@ module Unison.DataDeclaration constructors_, asDataDecl_, declAsDataDecl_, + setConstructorNames, ) where -import Control.Lens (Iso', Lens', imap, iso, lens, over, _3) +import Control.Lens (Iso', Lens', imap, iso, lens, over, set, _2, _3) import Control.Monad.State (evalState) import Data.Map qualified as Map import Data.Set qualified as Set @@ -164,6 +165,20 @@ constructorVars dd = fst <$> constructors dd constructorNames :: (Var v) => DataDeclaration v a -> [Text] constructorNames dd = Var.name <$> constructorVars dd +-- | Overwrite the constructor names with the given list, given in canonical order, which is assumed to be of the +-- correct length. +-- +-- Presumably this is called because the decl was loaded from the database outside of the context of a namespace, +-- since it's not stored with names there, so we had plugged in dummy names like "Constructor1", "Constructor2", ... +-- +-- Then, at some point, we discover the constructors' names in a namespace, and now we'd like to combine the two +-- together to get a Decl structure in memory with good/correct names for constructors. +setConstructorNames :: [v] -> Decl v a -> Decl v a +setConstructorNames constructorNames = + over + (declAsDataDecl_ . constructors_) + (zipWith (set _2) constructorNames) + -- This function is unsound, since the `rid` and the `decl` have to match. -- It should probably be hashed directly from the Decl, once we have a -- reliable way of doing that. —AI diff --git a/unison-core/src/Unison/Project.hs b/unison-core/src/Unison/Project.hs index 56eb6c55d..77a96a448 100644 --- a/unison-core/src/Unison/Project.hs +++ b/unison-core/src/Unison/Project.hs @@ -17,6 +17,8 @@ module Unison.Project ProjectBranchSpecifier (..), ProjectAndBranch (..), projectAndBranchNamesParser, + projectAndOptionalBranchParser, + branchWithOptionalProjectParser, ProjectAndBranchNames (..), projectAndBranchNamesParser2, projectNameParser, diff --git a/unison-merge/src/Unison/Merge/Database.hs b/unison-merge/src/Unison/Merge/Database.hs index 9ee91cf33..28cc05c93 100644 --- a/unison-merge/src/Unison/Merge/Database.hs +++ b/unison-merge/src/Unison/Merge/Database.hs @@ -16,11 +16,12 @@ import U.Codebase.Sqlite.Operations qualified as Operations import Unison.Builtin qualified as Builtins import Unison.Codebase (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.ConstructorType (ConstructorType) 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.Prelude import Unison.Referent qualified as V1 (Referent) @@ -29,6 +30,7 @@ import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite import Unison.Symbol qualified as V1 (Symbol) import Unison.Term qualified as V1 (Term) +import Unison.Type qualified as V1 (Type) import Unison.Util.Cache qualified as Cache ------------------------------------------------------------------------------------------------------------------------ @@ -39,9 +41,10 @@ data MergeDatabase = MergeDatabase { loadCausal :: CausalHash -> Transaction (CausalBranch Transaction), loadDeclNumConstructors :: TypeReferenceId -> Transaction Int, loadDeclType :: TypeReference -> Transaction ConstructorType, - loadV1Branch :: CausalHash -> Transaction (V1.Branch Transaction), 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 @@ -53,7 +56,6 @@ makeMergeDatabase codebase = liftIO do loadDeclNumConstructors <- do cache <- Cache.semispaceCache 1024 pure (Sqlite.cacheTransaction cache Operations.expectDeclNumConstructors) - let loadV1Branch = undefined -- Codebase.expectBranchForHash codebase loadV1Decl <- do cache <- Cache.semispaceCache 1024 pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTypeDeclaration codebase)) @@ -67,7 +69,18 @@ makeMergeDatabase codebase = liftIO do loadV1Term <- do cache <- Cache.semispaceCache 1024 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. referent2to1 :: MergeDatabase -> Referent -> Transaction V1.Referent diff --git a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs index b763d4e55..b2780772d 100644 --- a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs +++ b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs @@ -82,10 +82,11 @@ module Unison.Merge.DeclCoherencyCheck ( IncoherentDeclReason (..), checkDeclCoherency, + lenientCheckDeclCoherency, ) where -import Control.Lens (view, (%=), (.=)) +import Control.Lens (over, view, (%=), (.=), _2) import Control.Monad.Except (ExceptT) import Control.Monad.Except qualified as Except import Control.Monad.State.Strict (StateT) @@ -101,6 +102,7 @@ import Data.Maybe (fromJust) import Data.Set qualified as Set import U.Codebase.Reference (Reference' (..), TypeReference, TypeReferenceId) import Unison.ConstructorReference (GConstructorReference (..)) +import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Merge.DeclNameLookup (DeclNameLookup (..)) import Unison.Name (Name) import Unison.Name qualified as Name @@ -108,9 +110,8 @@ import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Sqlite (Transaction) import Unison.Util.Defns (Defns (..), DefnsF) -import Unison.Util.Map qualified as Map (deleteLookup, upsertF) +import Unison.Util.Map qualified as Map (deleteLookup, deleteLookupJust, upsertF) import Unison.Util.Nametree (Nametree (..)) data IncoherentDeclReason @@ -119,7 +120,7 @@ data IncoherentDeclReason -- Foo#Foo -- Foo.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 | -- | A second naming of a decl was discovered underneath its name, e.g. -- @@ -129,9 +130,11 @@ data IncoherentDeclReason | IncoherentDeclReason'StrayConstructor !Name checkDeclCoherency :: - (TypeReferenceId -> Transaction Int) -> + forall m. + Monad m => + (TypeReferenceId -> m Int) -> Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> - Transaction (Either IncoherentDeclReason DeclNameLookup) + m (Either IncoherentDeclReason DeclNameLookup) checkDeclCoherency loadDeclNumConstructors = Except.runExceptT . fmap (view #declNameLookup) @@ -140,10 +143,10 @@ checkDeclCoherency loadDeclNumConstructors = where go :: [NameSegment] -> - (Nametree (Defns (Map NameSegment Referent) (Map NameSegment TypeReference))) -> - StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason Transaction) () - go prefix (Nametree Defns {terms, types} children) = do - for_ (Map.toList terms) \case + (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason m) () + go prefix (Nametree defns children) = do + for_ (Map.toList defns.terms) \case (_, Referent.Ref _) -> pure () (_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure () (name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do @@ -152,35 +155,33 @@ checkDeclCoherency loadDeclNumConstructors = #expectedConstructors .= expectedConstructors1 where f :: - Maybe (Name, IntMap MaybeConstructorName) -> - Either IncoherentDeclReason (Name, IntMap MaybeConstructorName) + Maybe (Name, ConstructorNames) -> + Either IncoherentDeclReason (Name, ConstructorNames) f = \case - Nothing -> Left (IncoherentDeclReason'StrayConstructor (fullName name)) - Just (typeName, expected) -> (typeName,) <$> IntMap.alterF g (fromIntegral @Word64 @Int conId) expected - where - g :: Maybe MaybeConstructorName -> Either IncoherentDeclReason (Maybe MaybeConstructorName) - g = \case - Nothing -> error "didnt put expected constructor id" - Just NoConstructorNameYet -> Right (Just (YesConstructorName (fullName name))) - Just (YesConstructorName firstName) -> - Left (IncoherentDeclReason'ConstructorAlias firstName (fullName name)) + Nothing -> Left (IncoherentDeclReason'StrayConstructor name1) + Just (typeName, expected) -> + case recordConstructorName conId name1 expected of + Left existingName -> Left (IncoherentDeclReason'ConstructorAlias typeName existingName name1) + Right expected1 -> Right (typeName, expected1) + where + name1 = fullName name childrenWeWentInto <- - forMaybe (Map.toList types) \case + forMaybe (Map.toList defns.types) \case (_, ReferenceBuiltin _) -> pure Nothing (name, ReferenceDerived typeRef) -> do DeclCoherencyCheckState {expectedConstructors} <- State.get whatHappened <- do let recordNewDecl :: - Maybe (Name, IntMap MaybeConstructorName) -> - Compose (ExceptT IncoherentDeclReason Transaction) WhatHappened (Name, IntMap MaybeConstructorName) + Maybe (Name, ConstructorNames) -> + Compose (ExceptT IncoherentDeclReason m) WhatHappened (Name, ConstructorNames) recordNewDecl = Compose . \case Just (shorterTypeName, _) -> Except.throwError (IncoherentDeclReason'NestedDeclAlias shorterTypeName typeName) Nothing -> lift (loadDeclNumConstructors typeRef) <&> \case 0 -> UninhabitedDecl - n -> InhabitedDecl (typeName, IntMap.fromAscList [(i, NoConstructorNameYet) | i <- [0 .. n - 1]]) + n -> InhabitedDecl (typeName, emptyConstructorNames n) lift (getCompose (Map.upsertF recordNewDecl typeRef expectedConstructors)) case whatHappened of UninhabitedDecl -> do @@ -197,18 +198,88 @@ checkDeclCoherency loadDeclNumConstructors = let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) = Map.deleteLookup typeRef expectedConstructors constructorNames <- - unMaybeConstructorNames maybeConstructorNames & onNothing do + sequence (IntMap.elems maybeConstructorNames) & onNothing do Except.throwError (IncoherentDeclReason'MissingConstructorName typeName) #expectedConstructors .= expectedConstructors1 - #declNameLookup %= \declNameLookup -> - DeclNameLookup - { constructorToDecl = - List.foldl' - (\acc constructorName -> Map.insert constructorName typeName acc) - declNameLookup.constructorToDecl - constructorNames, - declToConstructors = Map.insert typeName constructorNames declNameLookup.declToConstructors - } + #declNameLookup . #constructorToDecl %= \constructorToDecl -> + List.foldl' + (\acc constructorName -> Map.insert constructorName typeName acc) + constructorToDecl + constructorNames + #declNameLookup . #declToConstructors %= Map.insert typeName constructorNames + pure (Just name) + where + typeName = fullName name + + let childrenWeHaventGoneInto = children `Map.withoutKeys` Set.fromList childrenWeWentInto + for_ (Map.toList childrenWeHaventGoneInto) \(name, child) -> go (name : prefix) child + where + fullName name = + Name.fromReverseSegments (name :| prefix) + +-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns a mapping from decl name to +-- constructor names, where constructor names can be missing. +-- +-- This function exists merely to extract a best-effort decl-name-to-constructor-name mapping for the LCA of a merge. +-- We require Alice and Bob to have coherent decls, but their LCA is out of the user's control and may have incoherent +-- decls, and whether or not it does, we still need to compute *some* syntactic hash for its decls. +lenientCheckDeclCoherency :: + forall m. + Monad m => + (TypeReferenceId -> m Int) -> + Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> + m (Map Name [Maybe Name]) +lenientCheckDeclCoherency loadDeclNumConstructors = + fmap (view #declToConstructors) + . (`State.execStateT` LenientDeclCoherencyCheckState Map.empty Map.empty) + . go [] + where + go :: + [NameSegment] -> + (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + StateT LenientDeclCoherencyCheckState m () + go prefix (Nametree defns children) = do + for_ (Map.toList defns.terms) \case + (_, Referent.Ref _) -> pure () + (_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure () + (name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do + #expectedConstructors %= Map.adjust (Map.map (lenientRecordConstructorName conId (fullName name))) typeRef + + childrenWeWentInto <- + forMaybe (Map.toList defns.types) \case + (_, ReferenceBuiltin _) -> pure Nothing + (name, ReferenceDerived typeRef) -> do + whatHappened <- do + let recordNewDecl :: m (WhatHappened (Map Name ConstructorNames)) + recordNewDecl = + loadDeclNumConstructors typeRef <&> \case + 0 -> UninhabitedDecl + n -> InhabitedDecl (Map.singleton typeName (emptyConstructorNames n)) + state <- State.get + lift (getCompose (Map.upsertF (\_ -> Compose recordNewDecl) typeRef state.expectedConstructors)) + case whatHappened of + UninhabitedDecl -> do + #declToConstructors %= Map.insert typeName [] + pure Nothing + InhabitedDecl expectedConstructors1 -> do + let child = Map.findWithDefault (Nametree (Defns Map.empty Map.empty) Map.empty) name children + #expectedConstructors .= expectedConstructors1 + go (name : prefix) child + state <- State.get + let (maybeConstructorNames, expectedConstructors) = + Map.alterF f typeRef state.expectedConstructors + where + f :: + Maybe (Map Name ConstructorNames) -> + (ConstructorNames, Maybe (Map Name ConstructorNames)) + f = + -- fromJust is safe here because we upserted `typeRef` key above + -- deleteLookupJust is safe here because we upserted `typeName` key above + fromJust + >>> Map.deleteLookupJust typeName + >>> over _2 \m -> if Map.null m then Nothing else Just m + #expectedConstructors .= expectedConstructors + #declToConstructors %= Map.insert typeName (IntMap.elems maybeConstructorNames) pure (Just name) where typeName = fullName name @@ -220,23 +291,47 @@ checkDeclCoherency loadDeclNumConstructors = Name.fromReverseSegments (name :| prefix) data DeclCoherencyCheckState = DeclCoherencyCheckState - { expectedConstructors :: !(Map TypeReferenceId (Name, IntMap MaybeConstructorName)), + { expectedConstructors :: !(Map TypeReferenceId (Name, ConstructorNames)), declNameLookup :: !DeclNameLookup } deriving stock (Generic) -data MaybeConstructorName - = NoConstructorNameYet - | YesConstructorName !Name +data LenientDeclCoherencyCheckState = LenientDeclCoherencyCheckState + { expectedConstructors :: !(Map TypeReferenceId (Map Name ConstructorNames)), + declToConstructors :: !(Map Name [Maybe Name]) + } + deriving stock (Generic) -unMaybeConstructorNames :: IntMap MaybeConstructorName -> Maybe [Name] -unMaybeConstructorNames = - traverse f . IntMap.elems +-- A partial mapping from constructor id to name; a collection of constructor names starts out with the correct number +-- of keys (per the number of data constructors) all mapped to Nothing. Then, as names are discovered by walking a +-- name tree, Nothings become Justs. +type ConstructorNames = + IntMap (Maybe Name) + +-- Make an empty set of constructor names given the number of constructors. +emptyConstructorNames :: Int -> ConstructorNames +emptyConstructorNames numConstructors = + IntMap.fromAscList [(i, Nothing) | i <- [0 .. numConstructors - 1]] + +recordConstructorName :: HasCallStack => ConstructorId -> Name -> ConstructorNames -> Either Name ConstructorNames +recordConstructorName conId conName = + IntMap.alterF f (fromIntegral @Word64 @Int conId) where - f :: MaybeConstructorName -> Maybe Name + f :: Maybe (Maybe Name) -> Either Name (Maybe (Maybe Name)) f = \case - NoConstructorNameYet -> Nothing - YesConstructorName name -> Just name + Nothing -> error (reportBug "E397219" ("recordConstructorName: didn't expect constructor id " ++ show conId)) + Just Nothing -> Right (Just (Just conName)) + Just (Just existingName) -> Left existingName + +lenientRecordConstructorName :: ConstructorId -> Name -> ConstructorNames -> ConstructorNames +lenientRecordConstructorName conId conName = + IntMap.adjust f (fromIntegral @Word64 @Int conId) + where + f :: Maybe Name -> Maybe Name + f = \case + Nothing -> Just conName + -- Ignore constructor alias, just keep first name we found + Just existingName -> Just existingName data WhatHappened a = UninhabitedDecl diff --git a/unison-merge/src/Unison/Merge/DeclNameLookup.hs b/unison-merge/src/Unison/Merge/DeclNameLookup.hs index c3e663172..08611a944 100644 --- a/unison-merge/src/Unison/Merge/DeclNameLookup.hs +++ b/unison-merge/src/Unison/Merge/DeclNameLookup.hs @@ -2,19 +2,13 @@ module Unison.Merge.DeclNameLookup ( DeclNameLookup (..), expectDeclName, expectConstructorNames, - setConstructorNames, ) where -import Control.Lens (over) import Data.Map.Strict qualified as Map import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) -import Unison.DataDeclaration (Decl) -import Unison.DataDeclaration qualified as DataDeclaration import Unison.Name (Name) import Unison.Prelude -import Unison.Syntax.Name qualified as Name -import Unison.Var (Var) -- | A lookup from decl-to-constructor name and vice-versa. -- @@ -57,22 +51,3 @@ expectConstructorNames DeclNameLookup {declToConstructors} x = case Map.lookup x declToConstructors of Nothing -> error (reportBug "E077058" ("Expected decl name key " <> show x <> " in decl name lookup")) Just y -> y - --- | Set the constructor names of a data declaration. --- --- Presumably this is used because the decl was loaded from the database outside of the context of a namespace, because --- it's not stored with names there, so we plugged in dummy names like "Constructor1", "Constructor2", ... --- --- Then, at some point, a `DeclNameLookup` was constructed for the corresponding namespace, and now we'd like to --- combine the two together to get a Decl structure in memory with good/correct names for constructors. -setConstructorNames :: forall a v. Var v => DeclNameLookup -> Name -> Decl v a -> Decl v a -setConstructorNames declNameLookup name = - case Map.lookup name declNameLookup.declToConstructors of - Nothing -> id - Just constructorNames -> - over - (DataDeclaration.declAsDataDecl_ . DataDeclaration.constructors_) - ( zipWith - (\realConName (ann, _junkConName, typ) -> (ann, Name.toVar realConName, typ)) - constructorNames - ) diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index f361c77b2..754b36be7 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -9,23 +9,30 @@ import Data.Semialign (alignWith) import Data.Set qualified as Set import Data.These (These (..)) import U.Codebase.Reference (TypeReference) -import Unison.Hash (Hash) +import Unison.DataDeclaration (Decl) +import Unison.DataDeclaration qualified as DataDeclaration +import Unison.Hash (Hash (Hash)) import Unison.HashQualified' qualified as HQ' import Unison.Merge.Database (MergeDatabase (..)) import Unison.Merge.DeclNameLookup (DeclNameLookup) import Unison.Merge.DeclNameLookup qualified as DeclNameLookup import Unison.Merge.DiffOp (DiffOp (..)) -import Unison.Merge.Synhash qualified as Synhash +import Unison.Merge.Synhash import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.ThreeWay (ThreeWay (..)) +import Unison.Merge.ThreeWay qualified as ThreeWay import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Merge.Updated (Updated (..)) import Unison.Name (Name) +import Unison.Parser.Ann (Ann) import Unison.Prelude hiding (catMaybes) import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) import Unison.PrettyPrintEnv qualified as Ppe +import Unison.Reference (Reference' (..), TypeReferenceId) import Unison.Referent (Referent) import Unison.Sqlite (Transaction) +import Unison.Symbol (Symbol) +import Unison.Syntax.Name qualified as Name import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith) @@ -40,12 +47,29 @@ import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith) -- branches. If the hash of a name did not change, it will not appear in the map. nameBasedNamespaceDiff :: MergeDatabase -> - ThreeWay DeclNameLookup -> + TwoWay DeclNameLookup -> + Map Name [Maybe Name] -> ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> Transaction (TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)) -nameBasedNamespaceDiff db declNameLookups defns = do - diffs <- sequence (synhashDefns <$> declNameLookups <*> defns) - pure (diffNamespaceDefns diffs.lca <$> TwoWay {alice = diffs.alice, bob = diffs.bob}) +nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns = do + lcaHashes <- + synhashDefnsWith + hashTerm + ( \name -> \case + ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin) + ReferenceDerived ref -> + case sequence (lcaDeclToConstructors Map.! name) of + -- If we don't have a name for every constructor, that's okay, just use a dummy syntactic hash here. + -- This is safe; Alice/Bob can't have such a decl (it violates a merge precondition), so there's no risk + -- that we accidentally get an equal hash and classify a real update as unchanged. + Nothing -> pure (Hash mempty) + Just names -> do + decl <- loadDeclWithGoodConstructorNames names ref + pure (synhashDerivedDecl ppe name decl) + ) + defns.lca + hashes <- sequence (synhashDefns <$> declNameLookups <*> ThreeWay.forgetLca defns) + pure (diffNamespaceDefns lcaHashes <$> hashes) where synhashDefns :: DeclNameLookup -> @@ -55,16 +79,20 @@ nameBasedNamespaceDiff db declNameLookups defns = do -- FIXME: use cache so we only synhash each thing once synhashDefnsWith hashTerm hashType where - hashTerm :: Referent -> Transaction Hash - hashTerm = - Synhash.hashTerm db.loadV1Term ppe - hashType :: Name -> TypeReference -> Transaction Hash - hashType name = - Synhash.hashDecl - (fmap (DeclNameLookup.setConstructorNames declNameLookup name) . db.loadV1Decl) - ppe - name + hashType name = \case + ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin) + ReferenceDerived ref -> do + decl <- loadDeclWithGoodConstructorNames (DeclNameLookup.expectConstructorNames declNameLookup name) ref + pure (synhashDerivedDecl ppe name decl) + + loadDeclWithGoodConstructorNames :: [Name] -> TypeReferenceId -> Transaction (Decl Symbol Ann) + loadDeclWithGoodConstructorNames names = + fmap (DataDeclaration.setConstructorNames (map Name.toVar names)) . db.loadV1Decl + + hashTerm :: Referent -> Transaction Hash + hashTerm = + synhashTerm db.loadV1Term ppe ppe :: PrettyPrintEnv ppe = diff --git a/unison-merge/src/Unison/Merge/PreconditionViolation.hs b/unison-merge/src/Unison/Merge/PreconditionViolation.hs deleted file mode 100644 index d43cfdee6..000000000 --- a/unison-merge/src/Unison/Merge/PreconditionViolation.hs +++ /dev/null @@ -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) diff --git a/unison-merge/src/Unison/Merge/Synhash.hs b/unison-merge/src/Unison/Merge/Synhash.hs index 56c69d459..29559690b 100644 --- a/unison-merge/src/Unison/Merge/Synhash.hs +++ b/unison-merge/src/Unison/Merge/Synhash.hs @@ -24,9 +24,10 @@ -- "foo" would have the same syntactic hash. This indicates (to our merge algorithm) that this was an auto-propagated -- update. module Unison.Merge.Synhash - ( hashType, - hashTerm, - hashDecl, + ( synhashType, + synhashTerm, + synhashBuiltinDecl, + synhashDerivedDecl, ) where @@ -72,8 +73,8 @@ isDeclTag, isTermTag :: H.Token Hash isDeclTag = H.Tag 0 isTermTag = H.Tag 1 -hashBuiltinDecl :: Text -> Hash -hashBuiltinDecl name = +synhashBuiltinDecl :: Text -> Hash +synhashBuiltinDecl name = H.accumulate [isBuiltinTag, isDeclTag, H.Text name] hashBuiltinTerm :: Text -> Hash @@ -104,23 +105,6 @@ hashConstructorNameToken declName conName = ) in H.Text (Name.toText strippedConName) --- | Syntactically hash a decl, using reference names rather than hashes. Two decls will have the same syntactic hash if --- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same, --- the constructors appear in the same order and have the same names, and the constructors' types have the same --- syntactic hashes. -hashDecl :: - (Monad m, Var v) => - (TypeReferenceId -> m (Decl v a)) -> - PrettyPrintEnv -> - Name -> - TypeReference -> - m Hash -hashDecl loadDecl ppe name = \case - ReferenceBuiltin builtin -> pure (hashBuiltinDecl builtin) - ReferenceDerived ref -> do - decl <- loadDecl ref - pure (hashDerivedDecl ppe name decl) - hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash hashDerivedTerm ppe t = H.accumulate $ isNotBuiltinTag : hashTermTokens ppe t @@ -148,8 +132,12 @@ hashDeclTokens :: Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token] hashDeclTokens ppe name decl = hashConstructorType (DD.constructorType decl) : hashDataDeclTokens ppe name (DD.asDataDecl decl) -hashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash -hashDerivedDecl ppe name decl = +-- | Syntactically hash a decl, using reference names rather than hashes. Two decls will have the same syntactic hash if +-- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same, +-- the constructors appear in the same order and have the same names, and the constructors' types have the same +-- syntactic hashes. +synhashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash +synhashDerivedDecl ppe name decl = H.accumulate $ isNotBuiltinTag : hashDeclTokens ppe name decl hashHQNameToken :: HashQualified Name -> Token @@ -218,8 +206,14 @@ hashReferentTokens ppe referent = -- | Syntactically hash a term, using reference names rather than hashes. -- Two terms will have the same syntactic hash if they would -- print the the same way under the given pretty-print env. -hashTerm :: forall m v a. (Monad m, Var v) => (TypeReferenceId -> m (Term v a)) -> PrettyPrintEnv -> V1.Referent -> m Hash -hashTerm loadTerm ppe = \case +synhashTerm :: + forall m v a. + (Monad m, Var v) => + (TypeReferenceId -> m (Term v a)) -> + PrettyPrintEnv -> + V1.Referent -> + m Hash +synhashTerm loadTerm ppe = \case V1.Referent.Con ref CT.Data -> pure (hashDerivedTerm ppe (Term.constructor @v () ref)) V1.Referent.Con ref CT.Effect -> pure (hashDerivedTerm ppe (Term.request @v () ref)) V1.Referent.Ref (ReferenceBuiltin builtin) -> pure (hashBuiltinTerm builtin) @@ -269,8 +263,8 @@ hashTermFTokens ppe = \case -- | Syntactically hash a type, using reference names rather than hashes. -- Two types will have the same syntactic hash if they would -- print the the same way under the given pretty-print env. -hashType :: Var v => PrettyPrintEnv -> Type v a -> Hash -hashType ppe t = +synhashType :: Var v => PrettyPrintEnv -> Type v a -> Hash +synhashType ppe t = H.accumulate $ hashTypeTokens ppe t hashTypeTokens :: forall v a. Var v => PrettyPrintEnv -> Type v a -> [Token] diff --git a/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs b/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs index c62000d6b..556ff0fd2 100644 --- a/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs +++ b/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs @@ -10,4 +10,4 @@ data TwoOrThreeWay a = TwoOrThreeWay alice :: a, bob :: a } - deriving stock (Functor, Generic) + deriving stock (Foldable, Functor, Generic, Traversable) diff --git a/unison-merge/unison-merge.cabal b/unison-merge/unison-merge.cabal index 8aaac5bff..84baab088 100644 --- a/unison-merge/unison-merge.cabal +++ b/unison-merge/unison-merge.cabal @@ -27,7 +27,6 @@ library Unison.Merge.EitherWayI Unison.Merge.Libdeps Unison.Merge.PartitionCombinedDiffs - Unison.Merge.PreconditionViolation Unison.Merge.Synhash Unison.Merge.Synhashed Unison.Merge.ThreeWay diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 1f187d691..6bea13f3d 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -17,6 +17,7 @@ dependencies: - bytes - bytestring - containers + - Diff - directory - errors - extra diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index ac0489be0..c2e2ceffb 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -14,6 +14,7 @@ module Unison.Server.Backend FoundRef (..), IncludeCycles (..), DefinitionResults (..), + SyntaxText, -- * Endpoints fuzzyFind, @@ -66,7 +67,9 @@ module Unison.Server.Backend -- * Re-exported for Share Server termsToSyntax, + termsToSyntaxOf, typesToSyntax, + typesToSyntaxOf, definitionResultsDependencies, evalDocRef, mkTermDefinition, @@ -88,7 +91,6 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as TextE import Data.Text.Lazy (toStrict) -import Data.Tuple.Extra (dupe) import Data.Yaml qualified as Yaml import Lucid qualified import System.Directory @@ -148,7 +150,7 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) 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.Referent (Referent) import Unison.Referent qualified as Referent @@ -845,14 +847,13 @@ docsForDefinitionName :: NameSearch Sqlite.Transaction -> Names.SearchType -> Name -> - IO [TermReference] + Sqlite.Transaction [TermReference] docsForDefinitionName codebase (NameSearch {termSearch}) searchType name = do let potentialDocNames = [name, name Cons.:> NameSegment.docSegment] - Codebase.runTransaction codebase do - refs <- - potentialDocNames & foldMapM \name -> - lookupRelativeHQRefs' termSearch searchType (HQ'.NameOnly name) - filterForDocs (toList refs) + refs <- + potentialDocNames & foldMapM \name -> + lookupRelativeHQRefs' termSearch searchType (HQ'.NameOnly name) + filterForDocs (toList refs) where filterForDocs :: [Referent] -> Sqlite.Transaction [TermReference] filterForDocs rs = do @@ -1119,19 +1120,55 @@ displayType codebase = \case decl <- Codebase.unsafeGetTypeDeclaration codebase rid 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 :: (Var v) => (Ord a) => Suffixify -> Width -> PPED.PrettyPrintEnvDecl -> - Map Reference.Reference (DisplayObject (Type v a) (Term v a)) -> - Map Reference.Reference (DisplayObject SyntaxText SyntaxText) + [(TermReference, (DisplayObject (Type v a) (Term v a)))] -> + [(TermReference, DisplayObject SyntaxText SyntaxText)] termsToSyntax suff width ppe0 terms = - Map.fromList . map go . Map.toList $ - Map.mapKeys - (first (PPE.termName ppeDecl . Referent.Ref) . dupe) - terms + terms + <&> \(r, dispObj) -> + let n = PPE.termName ppeDecl . Referent.Ref $ r + in (r,) case dispObj of + DisplayObject.BuiltinObject typ -> + DisplayObject.BuiltinObject $ + formatType' (ppeBody r) width typ + DisplayObject.MissingObject sh -> DisplayObject.MissingObject sh + DisplayObject.UserObject tm -> + DisplayObject.UserObject + . Pretty.render width + $ TermPrinter.prettyBinding (ppeBody r) n tm where ppeBody r = if suffixified suff @@ -1139,41 +1176,57 @@ termsToSyntax suff width ppe0 terms = 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 $ - formatType' (ppeBody r) width typ - DisplayObject.MissingObject sh -> DisplayObject.MissingObject sh - DisplayObject.UserObject tm -> - DisplayObject.UserObject - . Pretty.render width - $ TermPrinter.prettyBinding (ppeBody r) n tm +-- | Version of 'typesToSyntax' which works over arbitrary traversals. +-- +-- E.g. +-- @@ +-- typesToSyntaxOf suff width pped traversed [(ref, dispObj)] +-- +-- or +-- +-- typesToSyntaxOf suff width pped id (ref, dispObj) +-- +-- or +-- +-- typesToSyntaxOf suff width pped Map.asList_ (Map.singleton ref dispObj) +-- @@ +typesToSyntaxOf :: + (Var v) => + (Ord a) => + Suffixify -> + Width -> + PPED.PrettyPrintEnvDecl -> + Traversal s t (TypeReference, DisplayObject () (DD.Decl v a)) (TypeReference, DisplayObject SyntaxText SyntaxText) -> + s -> + t +typesToSyntaxOf suff width ppe0 trav s = + s & over (unsafePartsOf trav) (typesToSyntax suff width ppe0) + +-- | Converts Type Display Objects into Syntax Text. typesToSyntax :: (Var v) => (Ord a) => Suffixify -> Width -> PPED.PrettyPrintEnvDecl -> - Map Reference.Reference (DisplayObject () (DD.Decl v a)) -> - Map Reference.Reference (DisplayObject SyntaxText SyntaxText) + [(TypeReference, (DisplayObject () (DD.Decl v a)))] -> + [(TypeReference, (DisplayObject SyntaxText SyntaxText))] typesToSyntax suff width ppe0 types = - Map.fromList $ - map go . Map.toList $ - Map.mapKeys - (first (PPE.typeName ppeDecl) . dupe) - types + types + <&> \(r, dispObj) -> + let n = PPE.typeName ppeDecl r + in (r,) $ case dispObj of + BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r) + MissingObject sh -> MissingObject sh + UserObject d -> + UserObject . Pretty.render width $ + DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d where ppeDecl = if suffixified suff then PPED.suffixifiedPPE ppe0 else PPED.unsuffixifiedPPE ppe0 - go ((n, r), dt) = (r,) $ case dt of - BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r) - MissingObject sh -> MissingObject sh - UserObject d -> - UserObject . Pretty.render width $ - DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d -- | Renders a type to its decl header, e.g. -- diff --git a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs new file mode 100644 index 000000000..443f06454 --- /dev/null +++ b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs @@ -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." diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index edad8053d..eb2332dc7 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -48,6 +48,7 @@ import Servant serve, throwError, ) +import Servant qualified as Servant import Servant.API ( Accept (..), Capture, @@ -60,11 +61,13 @@ import Servant.API ) import Servant.Docs ( DocIntro (DocIntro), + ToParam (..), ToSample (..), docsWithIntros, markdown, singleSample, ) +import Servant.Docs qualified as Servant import Servant.OpenApi (HasOpenApi (toOpenApi)) import Servant.Server ( Application, @@ -85,17 +88,24 @@ import System.Random.MWC (createSystemRandom) import U.Codebase.HashTags (CausalHash) import Unison.Codebase (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.Runtime qualified as Rt -import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.HashQualified +import Unison.HashQualified qualified as HQ import Unison.Name as Name (Name, segments) import Unison.Parser.Ann (Ann) 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.Server.Backend (Backend, BackendEnv, runBackend) import Unison.Server.Backend qualified as Backend +import Unison.Server.Backend.DefinitionDiff qualified as DefinitionDiff 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.FuzzyFind (FuzzyFindAPI, serveFuzzyFind) 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.Projects (ListProjectBranchesEndpoint, ListProjectsEndpoint, projectBranchListingEndpoint, projectListingEndpoint) 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.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) 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 data HTML = HTML @@ -143,8 +160,51 @@ type CodebaseServerAPI = type ProjectsAPI = ListProjectsEndpoint - :<|> (Capture "project-name" ProjectName :> "branches" :> ListProjectBranchesEndpoint) - :<|> (Capture "project-name" ProjectName :> "branches" :> Capture "branch-name" ProjectBranchName :> CodebaseServerAPI) + :<|> ( Capture "project-name" ProjectName + :> ( ( "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 @@ -529,40 +589,94 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do where projectAndBranchName = ProjectAndBranch projectName branchName namespaceListingEndpoint _rootParam rel name = do - root <- resolveProjectRoot - setCacheControl <$> NamespaceListing.serve codebase (Just root) rel name + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do - root <- resolveProjectRoot - setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just root) renderWidth + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do - root <- resolveProjectRoot - setCacheControl <$> serveDefinitions rt codebase (Just root) relativePath rawHqns renderWidth suff + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do - root <- resolveProjectRoot - setCacheControl <$> serveFuzzyFind codebase (Just root) relativePath limit renderWidth query + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot - setCacheControl <$> serveTermSummary codebase shortHash mayName (Just root) relativeTo renderWidth + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot - setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just root) relativeTo renderWidth + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth - resolveProjectRoot :: Backend IO (Either ShortCausalHash CausalHash) - resolveProjectRoot = do - mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName - case mayCH of - Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) - Just ch -> pure (Right ch) +resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash +resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do + mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName + case mayCH of + Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) + 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 rt = projectListingEndpoint codebase - :<|> projectBranchListingEndpoint codebase - :<|> serveProjectsCodebaseServerAPI codebase rt + :<|> ( \projectName -> + ( projectBranchListingEndpoint codebase projectName + :<|> serveProjectsCodebaseServerAPI codebase rt projectName + ) + :<|> ( serveProjectDiffTermsEndpoint codebase rt projectName + :<|> serveProjectDiffTypesEndpoint codebase rt projectName + ) + ) serveUnisonLocal :: BackendEnv -> diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 248dc12e9..b1f5b03d5 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -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.Monad.Except +import Control.Monad.Trans.Maybe (mapMaybeT) import Data.Map qualified as Map +import Data.Set.NonEmpty qualified as NESet import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal +import U.Codebase.Reference (TermReference, TypeReference) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Path (Path) 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.Name (Name) +import Unison.NamesWithHistory qualified as NS import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -19,13 +31,20 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Server.Backend +import Unison.Server.Backend qualified as Backend import Unison.Server.Doc qualified as Doc 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.Types import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) 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) -- | 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 docResults :: Name -> IO [(HashQualifiedName, UnisonHash, Doc.Doc)] 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 -- local server currently ignores doc eval errors <&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc) let fqnPPE = PPED.unsuffixifiedPPE pped 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 docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTypeName)) mkTypeDefinition codebase pped width ref docs tp 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 hqTermName = PPE.termNameOrHashOnly fqnPPE referent docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTermName)) @@ -95,3 +114,66 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings renderedDisplayTerms renderedDisplayTypes 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 diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index e130cdbc2..48f9ace2b 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -38,15 +38,16 @@ import U.Codebase.HashTags import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Path qualified as Path +import Unison.Core.Project (ProjectBranchName) import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Prelude -import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) +import Unison.Project (ProjectAndBranch, ProjectName) import Unison.Server.Doc (Doc) import Unison.Server.Orphans () -import Unison.Server.Syntax (SyntaxText) +import Unison.Server.Syntax qualified as Syntax import Unison.ShortHash (ShortHash) import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Syntax.Name qualified as Name @@ -191,6 +192,20 @@ instance ToJSON DefinitionDisplayResults where 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} deriving (Eq, Ord, Show, Generic) @@ -198,8 +213,8 @@ data TermDefinition = TermDefinition { termNames :: [HashQualifiedName], bestTermName :: HashQualifiedName, defnTermTag :: TermTag, - termDefinition :: DisplayObject SyntaxText SyntaxText, - signature :: SyntaxText, + termDefinition :: DisplayObject Syntax.SyntaxText Syntax.SyntaxText, + signature :: Syntax.SyntaxText, termDocs :: [(HashQualifiedName, UnisonHash, Doc)] } deriving (Eq, Show, Generic) @@ -208,7 +223,7 @@ data TypeDefinition = TypeDefinition { typeNames :: [HashQualifiedName], bestTypeName :: HashQualifiedName, defnTypeTag :: TypeTag, - typeDefinition :: DisplayObject SyntaxText SyntaxText, + typeDefinition :: DisplayObject Syntax.SyntaxText Syntax.SyntaxText, typeDocs :: [(HashQualifiedName, UnisonHash, Doc)] } deriving (Eq, Show, Generic) @@ -233,6 +248,64 @@ data TermTag = Doc | Test | Plain | Constructor TypeTag data TypeTag = Ability | Data 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 = TypeRef UnisonHash | TermRef UnisonHash @@ -247,7 +320,7 @@ data NamedTerm = NamedTerm { -- The name of the term, should be hash qualified if conflicted, otherwise name only. termName :: HQ'.HashQualified Name, termHash :: ShortHash, - termType :: Maybe SyntaxText, + termType :: Maybe Syntax.SyntaxText, termTag :: TermTag } deriving (Eq, Generic, Show) @@ -391,3 +464,79 @@ instance Docs.ToCapture (Capture "project-and-branch" ProjectBranchNameParam) wh DocCapture "project-and-branch" "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 + ] diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index ca6396097..3741a1861 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -18,6 +18,7 @@ source-repository head library exposed-modules: Unison.Server.Backend + Unison.Server.Backend.DefinitionDiff Unison.Server.CodebaseServer Unison.Server.Doc Unison.Server.Doc.AsHtml @@ -82,7 +83,8 @@ library ImportQualifiedPost ghc-options: -Wall build-depends: - NanoID + Diff + , NanoID , aeson >=2.0.0.0 , async , base diff --git a/unison-share-projects-api/src/Unison/Share/API/Projects.hs b/unison-share-projects-api/src/Unison/Share/API/Projects.hs index 86dae3cf3..b326aec35 100644 --- a/unison-share-projects-api/src/Unison/Share/API/Projects.hs +++ b/unison-share-projects-api/src/Unison/Share/API/Projects.hs @@ -34,6 +34,7 @@ module Unison.Share.API.Projects ProjectBranchIds (..), NotFound (..), Unauthorized (..), + BranchName, ) where diff --git a/unison-src/transcripts-manual/gen-racket-libs.md b/unison-src/transcripts-manual/gen-racket-libs.md index 3967df5ce..44c078db5 100644 --- a/unison-src/transcripts-manual/gen-racket-libs.md +++ b/unison-src/transcripts-manual/gen-racket-libs.md @@ -5,7 +5,7 @@ Next, we'll download the jit project and generate a few Racket files from it. ```ucm .> project.create-empty jit-setup -jit-setup/main> pull @unison/internal/releases/0.0.17 lib.jit +jit-setup/main> lib.install @unison/internal/releases/0.0.17 ``` ```unison diff --git a/unison-src/transcripts-using-base/fix3939.md b/unison-src/transcripts-using-base/fix3939.md new file mode 100644 index 000000000..7ec695e6c --- /dev/null +++ b/unison-src/transcripts-using-base/fix3939.md @@ -0,0 +1,12 @@ +```unison +{{ +A simple doc. +}} +meh = 9 +``` + +```ucm +.> add +.> find meh +.> docs 1 +``` diff --git a/unison-src/transcripts-using-base/fix3939.output.md b/unison-src/transcripts-using-base/fix3939.output.md new file mode 100644 index 000000000..99197263c --- /dev/null +++ b/unison-src/transcripts-using-base/fix3939.output.md @@ -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. + +``` diff --git a/unison-src/transcripts/command-replace.md b/unison-src/transcripts/command-replace.md deleted file mode 100644 index c1d07740a..000000000 --- a/unison-src/transcripts/command-replace.md +++ /dev/null @@ -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 -``` diff --git a/unison-src/transcripts/command-replace.output.md b/unison-src/transcripts/command-replace.output.md deleted file mode 100644 index 1fb85d502..000000000 --- a/unison-src/transcripts/command-replace.output.md +++ /dev/null @@ -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 - -``` diff --git a/unison-src/transcripts/copy-patch.md b/unison-src/transcripts/copy-patch.md deleted file mode 100644 index 64a1379fa..000000000 --- a/unison-src/transcripts/copy-patch.md +++ /dev/null @@ -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 -``` diff --git a/unison-src/transcripts/copy-patch.output.md b/unison-src/transcripts/copy-patch.output.md deleted file mode 100644 index 881d1b075..000000000 --- a/unison-src/transcripts/copy-patch.output.md +++ /dev/null @@ -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 - -``` diff --git a/unison-src/transcripts/definition-diff-api.md b/unison-src/transcripts/definition-diff-api.md new file mode 100644 index 000000000..922a3c277 --- /dev/null +++ b/unison-src/transcripts/definition-diff-api.md @@ -0,0 +1,41 @@ +```ucm +.> project.create-empty diffs +diffs/main> builtins.merge +``` + +```unison +term = + _ = "Here's some text" + 1 + 1 + +type Type = Type Nat +``` + +```ucm +diffs/main> add +diffs/main> branch.create new +``` + +```unison +term = + _ = "Here's some different text" + 1 + 2 + +type Type a = Type a Text +``` + +```ucm +diffs/new> update +``` + +Diff terms + +```api +GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=term&newTerm=term +``` + +Diff types + +```api +GET /api/projects/diffs/diff/types?oldBranchRef=main&newBranchRef=new&oldType=Type&newType=Type +``` diff --git a/unison-src/transcripts/definition-diff-api.output.md b/unison-src/transcripts/definition-diff-api.output.md new file mode 100644 index 000000000..d0c73dc48 --- /dev/null +++ b/unison-src/transcripts/definition-diff-api.output.md @@ -0,0 +1,823 @@ +```ucm +.> project.create-empty diffs + + 🎉 I've created the project diffs. + + 🎨 Type `ui` to explore this project's code in your browser. + 🔭 Discover libraries at https://share.unison-lang.org + 📖 Use `help-topic projects` to learn more about projects. + + Write your first Unison code with UCM: + + 1. Open scratch.u. + 2. Write some Unison code and save the file. + 3. In UCM, type `add` to save it to your new project. + + 🎉 🥳 Happy coding! + +diffs/main> builtins.merge + + Done. + +``` +```unison +term = + _ = "Here's some text" + 1 + 1 + +type Type = Type 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`: + + type Type + term : Nat + +``` +```ucm +diffs/main> add + + ⍟ I've added these definitions: + + type Type + term : Nat + +diffs/main> branch.create new + + Done. I've created the new branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /new`. + +``` +```unison +term = + _ = "Here's some different text" + 1 + 2 + +type Type a = Type a Text +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Type a + term : Nat + +``` +```ucm +diffs/new> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +``` +Diff terms + +```api +GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=term&newTerm=term +{ + "diff": { + "contents": [ + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "diffTag": "segmentChange", + "fromSegment": "\"Here's some text\"", + "toSegment": "\"Here's some different text\"" + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "diffTag": "segmentChange", + "fromSegment": "1", + "toSegment": "2" + } + ], + "tag": "UserObject" + }, + "diffKind": "diff", + "newBranchRef": "new", + "newTerm": { + "bestTermName": "term", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"Here's some different text\"" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "2" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "term" + ] + }, + "oldBranchRef": "main", + "oldTerm": { + "bestTermName": "term", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"Here's some text\"" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "term" + ] + }, + "project": "diffs" +} +```Diff types + +```api +GET /api/projects/diffs/diff/types?oldBranchRef=main&newBranchRef=new&oldType=Type&newType=Type +{ + "diff": { + "contents": [ + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeParams" + }, + "segment": "a" + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + } + ] + }, + { + "diffTag": "annotationChange", + "fromAnnotation": { + "contents": "#0tc9e438eurvtevfa6k9pg04qvv66is75hs8iqejkuoaef140g8vvu92hc1ks4gamgc3i1ukgdn0blchp3038l43vffijpsbjh14igo#d0", + "tag": "TermReference" + }, + "segment": "Type", + "toAnnotation": { + "contents": "#mft8mne9i92b6k4m512rn2608rsp6ilq4ejufeof6mbh5aintes4tih1fo93fospmu2t3f0h67uu0mrk2qj75o7k0lj1juefhaidt4g#d0", + "tag": "TermReference" + } + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ] + } + ], + "tag": "UserObject" + }, + "diffKind": "diff", + "newBranchRef": "new", + "newType": { + "bestTypeName": "Type", + "defnTypeTag": "Data", + "typeDefinition": { + "contents": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeParams" + }, + "segment": "a" + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + }, + { + "annotation": { + "contents": "#mft8mne9i92b6k4m512rn2608rsp6ilq4ejufeof6mbh5aintes4tih1fo93fospmu2t3f0h67uu0mrk2qj75o7k0lj1juefhaidt4g#d0", + "tag": "TermReference" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ], + "tag": "UserObject" + }, + "typeDocs": [], + "typeNames": [ + "Type" + ] + }, + "oldBranchRef": "main", + "oldType": { + "bestTypeName": "Type", + "defnTypeTag": "Data", + "typeDefinition": { + "contents": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + }, + { + "annotation": { + "contents": "#0tc9e438eurvtevfa6k9pg04qvv66is75hs8iqejkuoaef140g8vvu92hc1ks4gamgc3i1ukgdn0blchp3038l43vffijpsbjh14igo#d0", + "tag": "TermReference" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "tag": "UserObject" + }, + "typeDocs": [], + "typeNames": [ + "Type" + ] + }, + "project": "diffs" +} +``` \ No newline at end of file diff --git a/unison-src/transcripts/delete-namespace-dependents-check.md b/unison-src/transcripts/delete-namespace-dependents-check.md new file mode 100644 index 000000000..9bbf7b94d --- /dev/null +++ b/unison-src/transcripts/delete-namespace-dependents-check.md @@ -0,0 +1,23 @@ + + +# Delete namespace dependents check + +This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name _anywhere_ in your codebase, it should only check the current project branch. + +```ucm:hide +.> project.create-empty myproject +myproject/main> builtins.merge +``` + +```unison +sub.dependency = 123 + +dependent = dependency + 99 +``` + +```ucm:error +myproject/main> add +myproject/main> branch /new +myproject/new> delete.namespace sub +myproject/new> view dependent +``` diff --git a/unison-src/transcripts/delete-namespace-dependents-check.output.md b/unison-src/transcripts/delete-namespace-dependents-check.output.md new file mode 100644 index 000000000..4ab652409 --- /dev/null +++ b/unison-src/transcripts/delete-namespace-dependents-check.output.md @@ -0,0 +1,62 @@ + + +# Delete namespace dependents check + +This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name _anywhere_ in your codebase, it should only check the current project branch. + +```unison +sub.dependency = 123 + +dependent = dependency + 99 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + dependent : Nat + sub.dependency : Nat + +``` +```ucm +myproject/main> add + + ⍟ I've added these definitions: + + dependent : Nat + sub.dependency : Nat + +myproject/main> branch /new + + Done. I've created the new branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /new`. + +myproject/new> delete.namespace sub + + ⚠️ + + I didn't delete the namespace because the following + definitions are still in use. + + Dependency Referenced In + dependency 1. dependent + + If you want to proceed anyways and leave those definitions + without names, use delete.namespace.force + +myproject/new> view dependent + + dependent : Nat + dependent = + use Nat + + dependency + 99 + +``` diff --git a/unison-src/transcripts/deleteReplacements.md b/unison-src/transcripts/deleteReplacements.md deleted file mode 100644 index 70ad9e6af..000000000 --- a/unison-src/transcripts/deleteReplacements.md +++ /dev/null @@ -1,94 +0,0 @@ -# Deleting term and type replacements from patches - -```unison -x = 1 -``` - -```ucm -.> add -``` - -```unison -x = 2 -``` - -```ucm -.> update.old -.> view.patch -``` - -```ucm -.> delete.term-replacement 1 -.> view.patch -``` - -```unison -unique[a] type Foo = Foo -``` - -```ucm -.> add -``` - -```unison -unique[b] type Foo = Foo | Bar -``` - -```ucm -.> update.old -.> view.patch -``` - -```ucm -.> delete.type-replacement 1 -.> view.patch -``` - -```unison -bar = 3 -unique[aa] type bar = Foo -``` - -```ucm -.> add -``` - -```unison -unique[bb] type bar = Foo | Bar -``` - -```ucm -.> update.old -.> view.patch -.> delete.type-replacement 1 -.> view.patch -``` - -we get an error when attempting to delete something that is neither a type nor a term -```ucm:error -.> view.patch -.> delete.type-replacement notHere -.> view.patch -``` - -When attempting to delete a type/term that doesn't exist, but a term/type exists -with that name, alert the user. -```unison -baz = 0 -``` - -```ucm:error -.> add baz -.> delete.type-replacement baz -.> view.patch -``` - -```unison -unique type qux = Qux -``` - -```ucm:error -.> add qux -.> delete.term-replacement qux -.> view.patch -``` diff --git a/unison-src/transcripts/deleteReplacements.output.md b/unison-src/transcripts/deleteReplacements.output.md deleted file mode 100644 index 9908542f7..000000000 --- a/unison-src/transcripts/deleteReplacements.output.md +++ /dev/null @@ -1,302 +0,0 @@ -# Deleting term and type replacements from patches - -```unison -x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : ##Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - x : ##Nat - -``` -```unison -x = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - x : ##Nat - -``` -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - x : ##Nat - -.> view.patch - - Edited Terms: 1. #gjmq673r1v -> 2. x - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -```ucm -.> delete.term-replacement 1 - - Done. - -.> view.patch - - This patch is empty. - -``` -```unison -unique[a] type Foo = Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -``` -```unison -unique[b] type Foo = Foo | Bar -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - type Foo - -.> view.patch - - Edited Types: 1. #ool30cf4ma -> 2. Foo - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -```ucm -.> delete.type-replacement 1 - - Done. - -.> view.patch - - This patch is empty. - -``` -```unison -bar = 3 -unique[aa] type bar = Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type bar - bar : ##Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type bar - bar : ##Nat - -``` -```unison -unique[bb] type bar = Foo | Bar -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type bar - -``` -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - type bar - -.> view.patch - - Edited Types: 1. #evhqg163jj -> 2. bar - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -.> delete.type-replacement 1 - - Done. - -.> view.patch - - This patch is empty. - -``` -we get an error when attempting to delete something that is neither a type nor a term -```ucm -.> view.patch - - This patch is empty. - -.> delete.type-replacement notHere - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - notHere - -.> view.patch - - This patch is empty. - -``` -When attempting to delete a type/term that doesn't exist, but a term/type exists -with that name, alert the user. -```unison -baz = 0 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - baz : ##Nat - -``` -```ucm -.> add baz - - ⍟ I've added these definitions: - - baz : ##Nat - -.> delete.type-replacement baz - - ⚠️ - - I was expecting the following names to be types, though I found terms instead. - baz - -.> view.patch - - This patch is empty. - -``` -```unison -unique type qux = Qux -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type qux - -``` -```ucm -.> add qux - - ⍟ I've added these definitions: - - type qux - -.> delete.term-replacement qux - - ⚠️ - - I was expecting the following names to be terms, though I found types instead. - qux - -.> view.patch - - This patch is empty. - -``` diff --git a/unison-src/transcripts/diff-namespace-to-patch.md b/unison-src/transcripts/diff-namespace-to-patch.md deleted file mode 100644 index 7bed7d82b..000000000 --- a/unison-src/transcripts/diff-namespace-to-patch.md +++ /dev/null @@ -1,43 +0,0 @@ -We can create a patch from the diff between two namespaces. - -```ucm:hide -.> builtins.merge -``` - -```unison:hide -one.a = 1 -one.b = 2 -oneconflicts.b = 20 -one.c = 3 -one.d = 4 -one.e = 4 - -two.a = 100 -two.b = 200 -two.c = 300 -twoconflicts.c = 30 -two.d = 5 -two.e = 6 -``` - -```ucm:hide -.> add -.> merge.old oneconflicts one -.> merge.old twoconflicts two -.> delete.namespace oneconflicts -.> delete.namespace twoconflicts -``` - -```ucm -.> find one. -.> find two. -.> diff.namespace.to-patch one two thepatch -``` - -A summary of the diff: - -* `one.a` -> `two.a` is a normal update. -* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`. -* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch. -* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch. -* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g` are not common to both namespaces. diff --git a/unison-src/transcripts/diff-namespace-to-patch.output.md b/unison-src/transcripts/diff-namespace-to-patch.output.md deleted file mode 100644 index 09798f8ae..000000000 --- a/unison-src/transcripts/diff-namespace-to-patch.output.md +++ /dev/null @@ -1,57 +0,0 @@ -We can create a patch from the diff between two namespaces. - -```unison -one.a = 1 -one.b = 2 -oneconflicts.b = 20 -one.c = 3 -one.d = 4 -one.e = 4 - -two.a = 100 -two.b = 200 -two.c = 300 -twoconflicts.c = 30 -two.d = 5 -two.e = 6 -``` - -```ucm -.> find one. - - 1. one.a : Nat - 2. one.b#cp6 : Nat - 3. one.b#dcg : Nat - 4. one.c : Nat - 5. one.d : Nat - - -.> find two. - - 1. two.a : Nat - 2. two.b : Nat - 3. two.c#k86 : Nat - 4. two.c#qpo : Nat - 5. two.d : Nat - 6. two.e : Nat - - -.> diff.namespace.to-patch one two thepatch - - Edited Terms: - 1. one.b#cp6ri8mtg0 -> 4. two.b - 2. one.b#dcgdua2lj6 -> 5. two.b - 3. one.a -> 6. two.a - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -A summary of the diff: - -* `one.a` -> `two.a` is a normal update. -* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`. -* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch. -* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch. -* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g are not common to both namespaces. diff --git a/unison-src/transcripts/diff-namespace.md b/unison-src/transcripts/diff-namespace.md index bbbf34046..5e938a79a 100644 --- a/unison-src/transcripts/diff-namespace.md +++ b/unison-src/transcripts/diff-namespace.md @@ -87,7 +87,6 @@ unique type Y a b = Y a b .> diff.namespace ns1 ns2 .> alias.type ns1.X ns1.X2 .> alias.type ns2.A' ns2.A'' -.> view.patch ns2.patch .> fork ns2 ns3 .> alias.term ns2.fromJust' ns2.yoohoo .> delete.term.verbose ns2.fromJust' diff --git a/unison-src/transcripts/diff-namespace.output.md b/unison-src/transcripts/diff-namespace.output.md index 929185b23..cacb9d1fc 100644 --- a/unison-src/transcripts/diff-namespace.output.md +++ b/unison-src/transcripts/diff-namespace.output.md @@ -297,16 +297,6 @@ unique type Y a b = Y a b Done. -.> view.patch ns2.patch - - Edited Terms: - 1. ns1.b -> 3. ns2.b - 2. ns1.fromJust' -> 4. ns2.fromJust - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - .> fork ns2 ns3 Done. diff --git a/unison-src/transcripts/empty-namespaces.md b/unison-src/transcripts/empty-namespaces.md index 32dd9942a..223ab34ba 100644 --- a/unison-src/transcripts/empty-namespaces.md +++ b/unison-src/transcripts/empty-namespaces.md @@ -45,7 +45,7 @@ stuff.thing = 2 ```ucm:hide .> add -.> delete.namespace .deleted +.> delete.namespace deleted ``` ## fork diff --git a/unison-src/transcripts/find-patch.md b/unison-src/transcripts/find-patch.md deleted file mode 100644 index a43106cc3..000000000 --- a/unison-src/transcripts/find-patch.md +++ /dev/null @@ -1,27 +0,0 @@ -# find.patch Test - -```ucm:hide -.> builtins.merge -``` - -```unison test.u -hey = "yello" -``` - -```ucm -.> add -``` - -Update - -```unison test.u -hey = "hello" -``` - -Update - -```ucm -.> update.old -.> find.patch -.> view.patch 1 -``` diff --git a/unison-src/transcripts/find-patch.output.md b/unison-src/transcripts/find-patch.output.md deleted file mode 100644 index d08e9f3a9..000000000 --- a/unison-src/transcripts/find-patch.output.md +++ /dev/null @@ -1,77 +0,0 @@ -# find.patch Test - -```unison ---- -title: test.u ---- -hey = "yello" - -``` - - -```ucm - - Loading changes detected in test.u. - - I found and typechecked these definitions in test.u. If you do - an `add` or `update`, here's how your codebase would change: - - ⍟ These new definitions are ok to `add`: - - hey : Text - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - hey : Text - -``` -Update - -```unison ---- -title: test.u ---- -hey = "hello" - -``` - - -```ucm - - Loading changes detected in test.u. - - I found and typechecked these definitions in test.u. If you do - an `add` or `update`, here's how your codebase would change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - hey : Text - -``` -Update - -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - hey : Text - -.> find.patch - - 1. patch - -.> view.patch 1 - - Edited Terms: 1. #m0kuh98ou7 -> 2. hey - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` diff --git a/unison-src/transcripts/fix1334.md b/unison-src/transcripts/fix1334.md index 6de756684..68e696748 100644 --- a/unison-src/transcripts/fix1334.md +++ b/unison-src/transcripts/fix1334.md @@ -1,8 +1,6 @@ Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` _only_ worked on hashes, and they had to be _full_ hashes. -With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual, and the arguments to `replace.term` and `replace.type` can be a short hash, a name, or a hash-qualified name. - -Note: `replace.term` and `replace.type` have since been replaced with just `replace`. +With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual. Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: @@ -10,29 +8,3 @@ Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: .> alias.type ##Nat Cat .> alias.term ##Nat.+ please_fix_763.+ ``` - -And some functions that use them: -```unison -f = 3 -g = 4 -h = f + 1 - -> h -``` - -```ucm -.> add -``` - -We used to have to know the full hash for a definition to be able to use the `replace` commands, but now we don't: -```ucm -.> names g -.> replace f g -.> names g -.> view.patch -``` - -The value of `h` should have been updated too: -```unison -> h -``` diff --git a/unison-src/transcripts/fix1334.output.md b/unison-src/transcripts/fix1334.output.md index 7bb95c96d..d397a51a1 100644 --- a/unison-src/transcripts/fix1334.output.md +++ b/unison-src/transcripts/fix1334.output.md @@ -1,8 +1,6 @@ Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` _only_ worked on hashes, and they had to be _full_ hashes. -With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual, and the arguments to `replace.term` and `replace.type` can be a short hash, a name, or a hash-qualified name. - -Note: `replace.term` and `replace.type` have since been replaced with just `replace`. +With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual. Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: @@ -16,96 +14,3 @@ Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: Done. ``` -And some functions that use them: -```unison -f = 3 -g = 4 -h = f + 1 - -> h -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - f : Cat - g : Cat - h : Cat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 5 | > h - ⧩ - 4 - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - f : Cat - g : Cat - h : Cat - -``` -We used to have to know the full hash for a definition to be able to use the `replace` commands, but now we don't: -```ucm -.> names g - - Term - Hash: #vcfbbslncd - Names: g - - Tip: Use `names.global` to see more results. - -.> replace f g - - Done. - -.> names g - - Term - Hash: #vcfbbslncd - Names: f g - - Tip: Use `names.global` to see more results. - -.> view.patch - - Edited Terms: 1. #f3lgjvjqoo -> 2. f - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -The value of `h` should have been updated too: -```unison -> h -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > h - ⧩ - 5 - -``` diff --git a/unison-src/transcripts/fix4898.md b/unison-src/transcripts/fix4898.md new file mode 100644 index 000000000..9bc68041b --- /dev/null +++ b/unison-src/transcripts/fix4898.md @@ -0,0 +1,17 @@ +```ucm +.> builtins.merge +``` + +```unison +double : Int -> Int +double x = x + x + +redouble : Int -> Int +redouble x = double x + double x +``` + +```ucm +.> add +.> dependents double +.> delete.term 1 +``` diff --git a/unison-src/transcripts/fix4898.output.md b/unison-src/transcripts/fix4898.output.md new file mode 100644 index 000000000..dceafc4cb --- /dev/null +++ b/unison-src/transcripts/fix4898.output.md @@ -0,0 +1,52 @@ +```ucm +.> builtins.merge + + Done. + +``` +```unison +double : Int -> Int +double x = x + x + +redouble : Int -> Int +redouble x = double x + double x +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + double : Int -> Int + redouble : Int -> Int + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + double : Int -> Int + redouble : Int -> Int + +.> dependents double + + Dependents of: double + + Terms: + + 1. redouble + + Tip: Try `view 1` to see the source of any numbered item in + the above list. + +.> delete.term 1 + + Done. + +``` diff --git a/unison-src/transcripts/merge.md b/unison-src/transcripts/merge.md index d74605f1c..e6475de63 100644 --- a/unison-src/transcripts/merge.md +++ b/unison-src/transcripts/merge.md @@ -1300,3 +1300,70 @@ project/alice> merge /bob ```ucm:hide .> project.delete project ``` + +## LCA precondition violations + +The LCA is not subject to most precondition violations, which is good, because the user can't easily manipulate it! + +Here's an example. We'll delete a constructor name from the LCA and still be able to merge Alice and Bob's stuff +together. + +```ucm:hide +.> project.create-empty project +project/main> builtins.mergeio +``` + +LCA: + +```unison +structural type Foo = Bar Nat | Baz Nat Nat +``` + +```ucm +project/main> add +project/main> delete.term Foo.Baz +``` + +Alice's branch: + +```ucm +project/main> branch alice +project/alice> delete.type Foo +project/alice> delete.term Foo.Bar +``` + +```unison +alice : Nat +alice = 100 +``` + +```ucm +project/alice> add +``` + +Bob's branch: + +```ucm +project/main> branch bob +project/bob> delete.type Foo +project/bob> delete.term Foo.Bar +``` + +```unison +bob : Nat +bob = 101 +``` + +```ucm +project/bob> add +``` + +Now we merge: + +```ucm +project/alice> merge /bob +``` + +```ucm:hide +.> project.delete project +``` diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index 5b70d7417..90412693d 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -24,7 +24,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar @@ -58,7 +58,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar @@ -101,7 +101,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar @@ -164,7 +164,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar baz @@ -234,7 +234,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar baz @@ -283,7 +283,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo @@ -325,7 +325,7 @@ Merge result: ```ucm project/alice> merge bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar baz @@ -446,7 +446,7 @@ project/bob> add project/alice> merge /bob - I fast-forward merged bob into alice. + I fast-forward merged project/bob into project/alice. ``` ## Merge failure: someone deleted something @@ -485,15 +485,12 @@ project/bob> add project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u --- The definitions below are not conflicted, but they each depend on one or more --- conflicted definitions above. - bar : Text bar = use Text ++ @@ -529,15 +526,12 @@ bar = foo ++ " - " ++ foo ```ucm project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u --- The definitions below are not conflicted, but they each depend on one or more --- conflicted definitions above. - bar : Text bar = use Text ++ @@ -585,9 +579,9 @@ baz = "bobs baz" ```ucm project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -642,9 +636,9 @@ unique type Foo = MkFoo Nat Text ```ucm project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -679,9 +673,9 @@ unique type Foo = Baz Nat | BobQux Text ```ucm project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -720,9 +714,9 @@ project/bob> move.term Foo.Qux Foo.Bob ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -754,9 +748,9 @@ unique ability my.cool where ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -800,9 +794,9 @@ These won't cleanly merge. ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -862,9 +856,9 @@ Notably, Alice's "unconflicted" update on the name "Foo.Bar.Baz" (because she ch ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -909,9 +903,9 @@ bob _ = 19 ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -970,7 +964,21 @@ baz = "baz" ```ucm project/alice> merge /bob - On alice, bar and foo are not aliases, but they used to be. + Sorry, I wasn't able to perform the merge: + + On the merge ancestor, bar and foo were aliases for the same + definition, but on project/alice the names have different + definitions currently. I'd need just a single new definition + to use in their dependents when I merge. + + Please fix up project/alice to resolve this. For example, + + * `update` the definitions to be the same again, so that + there's nothing for me to decide. + * `move` or `delete` all but one of the definitions; I'll + use the remaining name when propagating updates. + + and then try merging again. ``` ### Conflict involving builtin @@ -995,9 +1003,15 @@ unique type MyNat = MyNat Nat ```ucm project/alice> merge /bob + Sorry, I wasn't able to perform the merge: + There's a merge conflict on MyNat, but it's a builtin on one - or both branches. We can't yet handle merge conflicts on + or both branches. I can't yet handle merge conflicts involving builtins. + + Please eliminate this conflict by updating one branch or the + other, making MyNat the same on both branches, or making + neither of them a builtin, and then try the merge again. ``` ### Constructor alias @@ -1024,9 +1038,16 @@ bob = 100 ```ucm project/alice> merge /bob - On alice, Foo.Bar and Foo.some.other.Alias are aliases. Every - type declaration must have exactly one name for each - constructor. + Sorry, I wasn't able to perform the merge: + + On project/alice, the type Foo has a constructor with multiple + names, and I can't perform a merge in this situation: + + * Foo.Bar + * Foo.some.other.Alias + + Please delete all but one name for each constructor, and then + try merging again. ``` ### Missing constructor name @@ -1053,8 +1074,14 @@ bob = 100 ```ucm project/alice> merge /bob - The type Foo is missing a name for one of its constructors. - Please add one before merging. + Sorry, I wasn't able to perform the merge: + + On project/alice, the type Foo has some constructors with + missing names, and I can't perform a merge in this situation. + + You can use `view Foo` and + `alias.term Foo.` to give names to + each unnamed constructor, and then try the merge again. ``` ### Nested decl alias @@ -1086,8 +1113,10 @@ bob = 100 ```ucm project/alice> merge /bob - The type A.inner.X is an alias of A. Type aliases cannot be - nested. Please make them disjoint before merging. + On project/alice, the type A.inner.X is an alias of A. I'm not + able to perform a merge when a type exists nested under an + alias of itself. Please separate them or delete one copy, and + then try merging again. ``` ### Stray constructor alias @@ -1119,9 +1148,14 @@ project/bob> add ```ucm project/alice> merge bob - The constructor AliasOutsideFooNamespace is not in a - subnamespace of a name of its type. Please either delete it or - rename it before merging. + Sorry, I wasn't able to perform the merge, because I need all + constructor names to be nested somewhere beneath the + corresponding type name. + + On project/alice, the constructor AliasOutsideFooNamespace is + not nested beneath the corresponding type name. Please either + use `move` to move it, or if it's an extra copy, you can + simply `delete` it. Then try the merge again. ``` ### Term or type in `lib` @@ -1143,8 +1177,148 @@ bob = 100 ```ucm project/alice> merge /bob - 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. + Sorry, I wasn't able to perform the merge: + + On project/alice, there's a type or term at the top level of + the `lib` namespace, where I only expect to find subnamespaces + representing library dependencies. + + Please move or remove it and then try merging again. + +``` +## LCA precondition violations + +The LCA is not subject to most precondition violations, which is good, because the user can't easily manipulate it! + +Here's an example. We'll delete a constructor name from the LCA and still be able to merge Alice and Bob's stuff +together. + +LCA: + +```unison +structural type Foo = Bar Nat | Baz Nat Nat +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Foo + +``` +```ucm +project/main> add + + ⍟ I've added these definitions: + + structural type Foo + +project/main> delete.term Foo.Baz + + Done. + +``` +Alice's branch: + +```ucm +project/main> branch alice + + Done. I've created the alice branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /alice`. + +project/alice> delete.type Foo + + Done. + +project/alice> delete.term Foo.Bar + + Done. + +``` +```unison +alice : Nat +alice = 100 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + alice : Nat + +``` +```ucm +project/alice> add + + ⍟ I've added these definitions: + + alice : Nat + +``` +Bob's branch: + +```ucm +project/main> branch bob + + Done. I've created the bob branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /bob`. + +project/bob> delete.type Foo + + Done. + +project/bob> delete.term Foo.Bar + + Done. + +``` +```unison +bob : Nat +bob = 101 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bob : Nat + +``` +```ucm +project/bob> add + + ⍟ I've added these definitions: + + bob : Nat + +``` +Now we merge: + +```ucm +project/alice> merge /bob + + I merged project/bob into project/alice. ``` diff --git a/unison-src/transcripts/merges.md b/unison-src/transcripts/merges.md index ee2251e30..330e46857 100644 --- a/unison-src/transcripts/merges.md +++ b/unison-src/transcripts/merges.md @@ -52,7 +52,7 @@ We can also delete the fork if we're done with it. (Don't worry, even though the it's still in the `history` of the parent namespace and can be resurrected at any time.) ```ucm -.> delete.namespace .feature1 +.> delete.namespace feature1 .> history .feature1 .> history ``` diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 73c8a3931..8bfbb170f 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -106,7 +106,7 @@ We can also delete the fork if we're done with it. (Don't worry, even though the it's still in the `history` of the parent namespace and can be resurrected at any time.) ```ucm -.> delete.namespace .feature1 +.> delete.namespace feature1 Done. diff --git a/unison-src/transcripts/resolve.md b/unison-src/transcripts/resolve.md deleted file mode 100644 index 7b359a4f5..000000000 --- a/unison-src/transcripts/resolve.md +++ /dev/null @@ -1,116 +0,0 @@ -# Resolving edit conflicts in `ucm` - -```ucm:hide -.> builtins.merge -``` - -The `ucm` tool tracks edits to hashes in an object called a _patch_. When patches get merged, sometimes those patches will have conflicting edits. The `replace` command helps resolve such conflicts. - -First, let's make a new namespace, `example.resolve` and add the builtins: - -```ucm:hide -.example.resolve> builtins.merge -``` - -Now let's add a term named `a.foo`: - -```unison -a.foo = 42 -``` - -```ucm -.example.resolve> add -``` - -We'll fork the namespace `a` into a new namespace `b`, so we can edit the two concurrently. - -```ucm -.example.resolve> fork a b -``` - -We'll also make a second fork `c` which we'll use as the target for our patch later. - -```ucm -.example.resolve> fork a c -``` - -Now let's make a change to `foo` in the `a` namespace: - -```ucm -.example.resolve> deprecated.cd a -``` - -```unison -foo = 43 -``` - -```ucm -.example.resolve.a> update.old -``` - -And make a different change in the `b` namespace: - -```ucm -.example.resolve> deprecated.cd .example.resolve.b -``` - -```unison -foo = 44 -``` - -```ucm -.example.resolve.b> update.old -``` - -The `a` and `b` namespaces now each contain a patch named `patch`. We can view these: - -```ucm -.example.resolve.b> deprecated.cd .example.resolve -.example.resolve> view.patch a.patch -.example.resolve> view.patch b.patch -``` - -Let's now merge these namespaces into `c`: - -```ucm -.example.resolve> merge.old a c -``` -```ucm:error -.example.resolve> merge.old b c -``` - -The namespace `c` now has an edit conflict, since the term `foo` was edited in two different ways. - -```ucm:error -.example.resolve> deprecated.cd c -.example.resolve.c> todo -``` - -We see that the original hash of `a.foo` got replaced with _two different_ hashes. - -We can resolve this conflict by picking one of the terms as the "winner": - -```ucm -.example.resolve.c> replace 1 2 -``` - -This changes the merged `c.patch` so that only a single edit remains and resolves the conflict. - -```ucm -.example.resolve.c> view.patch -``` - -We still have a remaining _name conflict_ since it just so happened that both of the definitions in the edits were named `foo`. - -```ucm:error -.example.resolve.c> todo -``` - -We can resolve the name conflict by deleting one of the names. - -```ucm -.example.resolve.c> delete.term.verbose 2 -.example.resolve.c> todo -``` - -And that's how you resolve edit conflicts with UCM. diff --git a/unison-src/transcripts/resolve.output.md b/unison-src/transcripts/resolve.output.md deleted file mode 100644 index d4d9d4fe5..000000000 --- a/unison-src/transcripts/resolve.output.md +++ /dev/null @@ -1,265 +0,0 @@ -# Resolving edit conflicts in `ucm` - -The `ucm` tool tracks edits to hashes in an object called a _patch_. When patches get merged, sometimes those patches will have conflicting edits. The `replace` command helps resolve such conflicts. - -First, let's make a new namespace, `example.resolve` and add the builtins: - -Now let's add a term named `a.foo`: - -```unison -a.foo = 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a.foo : Nat - -``` -```ucm -.example.resolve> add - - ⍟ I've added these definitions: - - a.foo : Nat - -``` -We'll fork the namespace `a` into a new namespace `b`, so we can edit the two concurrently. - -```ucm -.example.resolve> fork a b - - Done. - -``` -We'll also make a second fork `c` which we'll use as the target for our patch later. - -```ucm -.example.resolve> fork a c - - Done. - -``` -Now let's make a change to `foo` in the `a` namespace: - -```ucm -.example.resolve> deprecated.cd a - -``` -```unison -foo = 43 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : ##Nat - -``` -```ucm -.example.resolve.a> update.old - - ⍟ I've updated these names to your new definition: - - foo : ##Nat - -``` -And make a different change in the `b` namespace: - -```ucm -.example.resolve> deprecated.cd .example.resolve.b - -``` -```unison -foo = 44 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : ##Nat - -``` -```ucm -.example.resolve.b> update.old - - ⍟ I've updated these names to your new definition: - - foo : ##Nat - -``` -The `a` and `b` namespaces now each contain a patch named `patch`. We can view these: - -```ucm -.example.resolve.b> deprecated.cd .example.resolve - -.example.resolve> view.patch a.patch - - Edited Terms: 1. c.foo -> 2. a.foo - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -.example.resolve> view.patch b.patch - - Edited Terms: 1. c.foo -> 2. b.foo - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -Let's now merge these namespaces into `c`: - -```ucm -.example.resolve> merge.old a c - - Here's what's changed in c after the merge: - - Updates: - - 1. foo : Nat - ↓ - 2. foo : Nat - - Added definitions: - - 3. patch patch (added 1 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -```ucm -.example.resolve> merge.old b c - - Here's what's changed in c after the merge: - - New name conflicts: - - 1. foo#emomp74i93 : Nat - ↓ - 2. ┌ foo#a84tg4er4k : Nat - 3. └ foo#emomp74i93 : Nat - - Updates: - - 4. patch patch (added 1 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - - I tried to auto-apply the patch, but couldn't because it - contained contradictory entries. - -``` -The namespace `c` now has an edit conflict, since the term `foo` was edited in two different ways. - -```ucm -.example.resolve> deprecated.cd c - -.example.resolve.c> todo - - ❓ - - These definitions were edited differently in namespaces that - have been merged into this one. You'll have to tell me what to - use as the new definition: - - The term 1. #qkhkl0n238 was replaced with - 2. foo#a84tg4er4k - 3. foo#emomp74i93 - -``` -We see that the original hash of `a.foo` got replaced with _two different_ hashes. - -We can resolve this conflict by picking one of the terms as the "winner": - -```ucm -.example.resolve.c> replace 1 2 - - Done. - -``` -This changes the merged `c.patch` so that only a single edit remains and resolves the conflict. - -```ucm -.example.resolve.c> view.patch - - Edited Terms: 1. #qkhkl0n238 -> 2. foo#a84tg4er4k - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -We still have a remaining _name conflict_ since it just so happened that both of the definitions in the edits were named `foo`. - -```ucm -.example.resolve.c> todo - - ❓ - - The term foo has conflicting definitions: - 1. foo#a84tg4er4k - 2. foo#emomp74i93 - - Tip: This occurs when merging branches that both independently - introduce the same name. Use `move.term` or `delete.term` - to resolve the conflicts. - -``` -We can resolve the name conflict by deleting one of the names. - -```ucm -.example.resolve.c> delete.term.verbose 2 - - Resolved name conflicts: - - 1. ┌ foo#a84tg4er4k : ##Nat - 2. └ foo#emomp74i93 : ##Nat - ↓ - 3. foo#a84tg4er4k : ##Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -.example.resolve.c> todo - - ✅ - - No conflicts or edits in progress. - -``` -And that's how you resolve edit conflicts with UCM. diff --git a/unison-src/transcripts/tab-completion.output.md b/unison-src/transcripts/tab-completion.output.md index 49ac0684f..34ce96db9 100644 --- a/unison-src/transcripts/tab-completion.output.md +++ b/unison-src/transcripts/tab-completion.output.md @@ -9,20 +9,16 @@ Test that tab completion works as expected. view view.global - view.patch .> debug.tab-complete delete. delete.branch delete.namespace delete.namespace.force - delete.patch delete.project delete.term - delete.term-replacement delete.term.verbose delete.type - delete.type-replacement delete.type.verbose delete.verbose diff --git a/unison-src/transcripts/todo.md b/unison-src/transcripts/todo.md index b1d214af5..39fece2f6 100644 --- a/unison-src/transcripts/todo.md +++ b/unison-src/transcripts/todo.md @@ -103,7 +103,6 @@ oldfoo = 801 ```ucm .lhs> add -.lhs> view.patch patch .lhs> todo ``` diff --git a/unison-src/transcripts/todo.output.md b/unison-src/transcripts/todo.output.md index 8290884f5..b0a9d69c6 100644 --- a/unison-src/transcripts/todo.output.md +++ b/unison-src/transcripts/todo.output.md @@ -205,14 +205,6 @@ oldfoo = 801 oldfoo : Nat -.lhs> view.patch patch - - Edited Terms: 1. oldfoo -> 2. foo - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - .lhs> todo ✅ diff --git a/unison-src/transcripts/update-on-conflict.md b/unison-src/transcripts/update-on-conflict.md index e9dfa574e..21b9a656c 100644 --- a/unison-src/transcripts/update-on-conflict.md +++ b/unison-src/transcripts/update-on-conflict.md @@ -17,7 +17,7 @@ Cause a conflict: .merged> merge.old .b ``` -Updating conflicted definitions works fine, and the associated patch contains two entries. +Updating conflicted definitions works fine. ```unison x = 3 @@ -25,5 +25,4 @@ x = 3 ```ucm .merged> update -.merged> view.patch ``` diff --git a/unison-src/transcripts/update-on-conflict.output.md b/unison-src/transcripts/update-on-conflict.output.md index f2888e1fc..6a9afd2e9 100644 --- a/unison-src/transcripts/update-on-conflict.output.md +++ b/unison-src/transcripts/update-on-conflict.output.md @@ -64,7 +64,7 @@ Cause a conflict: Applying changes from patch... ``` -Updating conflicted definitions works fine, and the associated patch contains two entries. +Updating conflicted definitions works fine. ```unison x = 3 @@ -92,8 +92,4 @@ x = 3 Done. -.merged> view.patch - - This patch is empty. - ``` diff --git a/unison-src/transcripts/upgrade-happy-path.md b/unison-src/transcripts/upgrade-happy-path.md index 3daf5f78e..c234e9ac7 100644 --- a/unison-src/transcripts/upgrade-happy-path.md +++ b/unison-src/transcripts/upgrade-happy-path.md @@ -15,6 +15,7 @@ proj/main> add ``` Test tab completion and fzf options of upgrade command. + ```ucm proj/main> debug.tab-complete upgrade ol proj/main> debug.fuzzy-options upgrade _ diff --git a/unison-src/transcripts/upgrade-happy-path.output.md b/unison-src/transcripts/upgrade-happy-path.output.md index 5e487a572..b2d8bb80a 100644 --- a/unison-src/transcripts/upgrade-happy-path.output.md +++ b/unison-src/transcripts/upgrade-happy-path.output.md @@ -30,6 +30,7 @@ proj/main> add ``` Test tab completion and fzf options of upgrade command. + ```ucm proj/main> debug.tab-complete upgrade ol diff --git a/unison-src/transcripts/upgrade-sad-path.md b/unison-src/transcripts/upgrade-sad-path.md index 4557c1cad..ccf51fd60 100644 --- a/unison-src/transcripts/upgrade-sad-path.md +++ b/unison-src/transcripts/upgrade-sad-path.md @@ -16,3 +16,17 @@ proj/main> add ```ucm:error proj/main> upgrade old new ``` + +Resolve the error and commit the upgrade. + +```unison +thingy = foo + +10 +``` + +```ucm +proj/upgrade-old-to-new> update +proj/upgrade-old-to-new> upgrade.commit +proj/main> view thingy +proj/main> ls lib +proj/main> branches +``` diff --git a/unison-src/transcripts/upgrade-sad-path.output.md b/unison-src/transcripts/upgrade-sad-path.output.md index 37f96f94e..e4ed5187b 100644 --- a/unison-src/transcripts/upgrade-sad-path.output.md +++ b/unison-src/transcripts/upgrade-sad-path.output.md @@ -44,3 +44,53 @@ thingy = foo + 10 ``` +Resolve the error and commit the upgrade. + +```unison +thingy = foo + +10 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + thingy : Int + +``` +```ucm +proj/upgrade-old-to-new> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +proj/upgrade-old-to-new> upgrade.commit + + I fast-forward merged proj/upgrade-old-to-new into proj/main. + +proj/main> view thingy + + thingy : Int + thingy = + use Int + + foo + +10 + +proj/main> ls lib + + 1. builtin/ (469 terms, 74 types) + 2. new/ (1 term) + +proj/main> branches + + Branch Remote branch + 1. main + +```